Represent 'unit' as C 'int'; change pattern match compilation to avoid 'goto'; change Postgres prepared statement compilation to make life easier for the GCC escape analysis; all this in support of better tail call optimization

1 files changed, 228 insertions, 289 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index fffeadcc..a41ba0d2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -73,6 +73,7 @@ fun p_typ' par env (t, loc) =
     case t of
         TFun (t1, t2) => (EM.errorAt loc "Function type remains";
                           string "<FUNCTION>")
+      | TRecord 0 => string "uw_unit"
       | TRecord i => box [string "struct",
                           space,
                           string "__uws_",
@@ -155,71 +156,36 @@ fun p_patCon env pc =
         PConVar n => p_con_named env n
       | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
 
-fun p_pat (env, exit, depth) (p, loc) =
+fun p_patMatch (env, disc) (p, loc) =
     case p of
-        PWild =>
-        (box [], env)
-      | PVar (x, t) =>
-        (box [string "__uwr_",
-              p_ident x,
-              string "_",
-              string (Int.toString (E.countERels env)),
-              space,
-              string "=",
-              space,
-              string "disc",
-              string (Int.toString depth),
-              string ";"],
-         E.pushERel env x t)
-      | PPrim (Prim.Int n) =>
-        (box [string "if",
-              space,
-              string "(disc",
-              string (Int.toString depth),
-              space,
-              string "!=",
-              space,
-              Prim.p_t_GCC (Prim.Int n),
-              string ")",
-              space,
-              exit],
-         env)
-      | PPrim (Prim.String s) =>
-        (box [string "if",
-              space,
-              string "(strcmp(disc",
-              string (Int.toString depth),
-              string ",",
-              space,
-              Prim.p_t_GCC (Prim.String s),
-              string "))",
-              space,
-              exit],
-         env)
-      | PPrim (Prim.Char ch) =>
-        (box [string "if",
-              space,
-              string "(disc",
-              string (Int.toString depth),
-              space,
-              string "!=",
-              space,
-              Prim.p_t_GCC (Prim.Char ch),
-              string ")",
-              space,
-              exit],
-         env)
+        PWild => string "1"
+      | PVar _ => string "1"
+      | PPrim (Prim.Int n) => box [string ("(" ^ disc),
+                                   space,
+                                   string "==",
+                                   space,
+                                   Prim.p_t_GCC (Prim.Int n),
+                                   string ")"]
+      | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc),
+                                      string ",",
+                                      space,
+                                      Prim.p_t_GCC (Prim.String s),
+                                      string ")"]
+      | PPrim (Prim.Char ch) => box [string ("(" ^ disc),
+                                     space,
+                                     string "==",
+                                     space,
+                                     Prim.p_t_GCC (Prim.Char ch),
+                                     string ")"]
       | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
 
       | PCon (dk, pc, po) =>
         let
-            val (p, env) =
+            val p =
                 case po of
-                    NONE => (box [], env)
+                    NONE => box []
                   | SOME p =>
                     let
-                        val (p, env) = p_pat (env, exit, depth + 1) p
-
                         val (x, to) = case pc of
                                           PConVar n =>
                                           let
@@ -233,169 +199,157 @@ fun p_pat (env, exit, depth) (p, loc) =
                         val t = case to of
                                     NONE => raise Fail "CjrPrint: Constructor mismatch"
                                   | SOME t => t
+
+                        val x = case pc of
+                                    PConVar n =>
+                                    let
+                                        val (x, _, _) = E.lookupConstructor env n
+                                    in
+                                        "uw_" ^ ident x
+                                    end
+                                  | PConFfi {mod = m, con, ...} =>
+                                    "uw_" ^ ident m ^ "_" ^ ident con
+
+                        val disc' = case dk of
+                                        Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
+                                      | Default => disc ^ "->data." ^ x
+                                      | Option =>
+                                        if isUnboxable t then
+                                            disc
+                                        else
+                                            "(*" ^ disc ^ ")"
+
+                        val p = p_patMatch (env, disc') p
                     in
-                        (box [string "{",
-                              newline,
-                              p_typ env t,
-                              space,
-                              string "disc",
-                              string (Int.toString (depth + 1)),
-                              space,
-                              string "=",
-                              space,
-                              case dk of
-                                  Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
-                                | Default => box [string "disc",
-                                                  string (Int.toString depth),
-                                                  string "->data.",
-                                                  string x]
-                                | Option =>
-                                  if isUnboxable t then
-                                      box [string "disc",
-                                           string (Int.toString depth)]
-                                  else
-                                      box [string "*disc",
-                                           string (Int.toString depth)],
-                              string ";",
-                              newline,
-                              p,
-                              newline,
-                              string "}"],
-                         env)
+                        box [space,
+                             string "&&",
+                             space,
+                             p]
                     end
         in
-            (box [string "if",
-                  space,
-                  string "(disc",
-                  string (Int.toString depth),
-                  case (dk, po) of
-                      (Enum, _) => box [space,
-                                        string "!=",
-                                        space,
-                                        p_patCon env pc]
-                    | (Default, _) => box [string "->tag",
-                                           space,
-                                           string "!=",
-                                           space,
-                                           p_patCon env pc]
-                    | (Option, NONE) => box [space,
-                                             string "!=",
-                                             space,
-                                             string "NULL"]
-                    | (Option, SOME _) => box [space,
-                                               string "==",
-                                               space,
-                                               string "NULL"],
-                  string ")",
-                  space,
-                  exit,
-                  newline,
-                  p],
-             env)
+            box [string disc,
+                 case (dk, po) of
+                     (Enum, _) => box [space,
+                                       string "==",
+                                       space,
+                                       p_patCon env pc]
+                   | (Default, _) => box [string "->tag",
+                                          space,
+                                          string "==",
+                                          space,
+                                          p_patCon env pc]
+                   | (Option, NONE) => box [space,
+                                            string "==",
+                                            space,
+                                            string "NULL"]
+                   | (Option, SOME _) => box [space,
+                                              string "!=",
+                                              space,
+                                              string "NULL"],
+                 p]
         end
 
       | PRecord xps =>
+        p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps
+
+      | PNone _ =>
+        box [string disc,
+             space,
+             string "==",
+             space,
+             string "NULL"]
+
+      | PSome (t, p) =>
         let
-            val (xps, env) =
-                ListUtil.foldlMap (fn ((x, p, t), env) =>
-                                      let
-                                          val (p, env) = p_pat (env, exit, depth + 1) p
+            val disc' = if isUnboxable t then
+                            disc
+                        else
+                            "(*" ^ disc ^ ")"
 
-                                          val p = box [string "{",
-                                                       newline,
-                                                       p_typ env t,
-                                                       space,
-                                                       string "disc",
-                                                       string (Int.toString (depth + 1)),
-                                                       space,
-                                                       string "=",
-                                                       space,
-                                                       string "disc",
-                                                       string (Int.toString depth),
-                                                       string ".__uwf_",
-                                                       p_ident x,
-                                                       string ";",
-                                                       newline,
-                                                       p,
-                                                       newline,
-                                                       string "}"]
-                                      in
-                                          (p, env)
-                                      end) env xps
+            val p = p_patMatch (env, disc') p
         in
-            (p_list_sep newline (fn x => x) xps,
-             env)
+            box [string disc,
+                 space,
+                 string "!=",
+                 space,
+                 string "NULL",
+                 space,
+                 string "&&",
+                 space,
+                 p]
         end
 
-      | PNone t =>
-        (box [string "if",
-              space,
-              string "(disc",
-              string (Int.toString depth),
+fun p_patBind (env, disc) (p, loc) =
+    case p of
+        PWild =>
+        (box [], env)
+      | PVar (x, t) =>
+        (box [p_typ env t,
               space,
-              string "!=",
+              string "__uwr_",
+              p_ident x,
+              string "_",
+              string (Int.toString (E.countERels env)),
               space,
-              string "NULL)",
+              string "=",
               space,
-              exit,
+              string disc,
+              string ";",
               newline],
-         env)
+         E.pushERel env x t)
+      | PPrim _ => (box [], env)
 
-      | PSome (t, p) =>
+      | PCon (_, _, NONE) => (box [], env)
+
+      | PCon (dk, pc, SOME p) =>
         let
-            val (p, env) =
-                let
-                    val (p, env) = p_pat (env, exit, depth + 1) p
-                in
-                    (box [string "{",
-                          newline,
-                          p_typ env t,
-                          space,
-                          string "disc",
-                          string (Int.toString (depth + 1)),
-                          space,
-                          string "=",
-                          space,
-                          if isUnboxable t then
-                              box [string "disc",
-                                   string (Int.toString depth)]
-                          else
-                              box [string "*disc",
-                                   string (Int.toString depth)],
-                          string ";",
-                          newline,
-                          p,
-                          newline,
-                          string "}"],
-                     env)
-                end
+            val (x, to) = case pc of
+                              PConVar n =>
+                              let
+                                  val (x, to, _) = E.lookupConstructor env n
+                              in
+                                  ("uw_" ^ ident x, to)
+                              end
+                            | PConFfi {mod = m, con, arg, ...} =>
+                              ("uw_" ^ ident m ^ "_" ^ ident con, arg)
+
+            val t = case to of
+                        NONE => raise Fail "CjrPrint: Constructor mismatch"
+                      | SOME t => t
+
+            val disc' = case dk of
+                            Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
+                          | Default => disc ^  "->data." ^ x
+                          | Option =>
+                            if isUnboxable t then
+                                disc
+                            else
+                                "(*" ^ disc ^ ")"
         in
-            (box [string "if",
-                  space,
-                  string "(disc",
-                  string (Int.toString depth),
-                  space,
-                  string "==",
-                  space,
-                  string "NULL)",
-                  space,
-                  exit,
-                  newline,
-                  p],
+            p_patBind (env, disc') p
+        end
+
+      | PRecord xps =>
+        let
+            val (xps, env) =
+                ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p)
+                                  env xps
+        in
+            (p_list_sep (box []) (fn x => x) xps,
              env)
         end
 
-local
-    val count = ref 0
-in
-fun newGoto () =
-    let
-        val r = !count
-    in
-        count := r + 1;
-        string ("L" ^ Int.toString r)
-    end
-end
+      | PNone _ => (box [], env)
+
+      | PSome (t, p) =>
+        let
+            val disc' = if isUnboxable t then
+                            disc
+                        else
+                            "(*" ^ disc ^ ")"
+        in
+            p_patBind (env, disc') p
+        end
 
 fun patConInfo env pc =
     case pc of
@@ -1567,6 +1521,8 @@ fun p_exp' par env (e, loc) =
                               space,
                               p_exp' true env e2])
 
+      | ERecord (0, _) => string "0"
+
       | ERecord (i, xes) => box [string "({",
                                  space,
                                  string "struct",
@@ -1591,77 +1547,58 @@ fun p_exp' par env (e, loc) =
              p_ident x]
 
       | ECase (e, pes, {disc, result}) =>
-        let
-            val final = newGoto ()
-
-            val body = foldl (fn ((p, e), body) =>
-                               let
-                                   val exit = newGoto ()
-                                   val (pr, _) = p_pat_preamble env p
-                                   val (p, env) = p_pat (env,
-                                                         box [string "goto",
-                                                              space,
-                                                              exit,
-                                                              string ";"],
-                                                         0) p
-                               in
-                                   box [body,
-                                        box [string "{",
-                                             newline,
-                                             pr,
-                                             newline,
-                                             p,
-                                             newline,
-                                             string "result",
-                                             space,
-                                             string "=",
-                                             space,
-                                             p_exp env e,
-                                             string ";",
-                                             newline,
-                                             string "goto",
-                                             space,
-                                             final,
-                                             string ";",
-                                             newline,
-                                             string "}"],
-                                        newline,
-                                        exit,
-                                        string ":",
-                                        newline]
-                               end) (box []) pes
-        in
-            box [string "({",
-                 newline,
-                 p_typ env disc,
-                 space,
-                 string "disc0",
-                 space,
-                 string "=",
-                 space,
-                 p_exp env e,
-                 string ";",
-                 newline,
-                 p_typ env result,
-                 space,
-                 string "result;",
-                 newline,
-                 body,
-                 string "uw_error(ctx, FATAL, \"",
-                 string (ErrorMsg.spanToString loc),
-                 string ": pattern match failure\");",
-                 newline,
-                 final,
-                 string ":",
-                 space,
-                 string "result;",
-                 newline,
-                 string "})"]
-        end
+        box [string "({",
+             newline,
+             p_typ env disc,
+             space,
+             string "disc",
+             space,
+             string "=",
+             space,
+             p_exp env e,
+             string ";",
+             newline,
+             newline,
+             foldr (fn ((p, e), body) =>
+                       let
+                           val pm = p_patMatch (env, "disc") p
+                           val (pb, env) = p_patBind (env, "disc") p
+                       in
+                           box [pm,
+                                space,
+                                string "?",
+                                space,
+                                box [string "({",
+                                     pb,
+                                     p_exp env e,
+                                     string ";",
+                                     newline,
+                                     string "})"],
+                                newline,
+                                space,
+                                string ":",
+                                space,
+                                body]
+                       end) (box [string "({",
+                                  newline,
+                                  p_typ env result,
+                                  space,
+                                  string "tmp;",
+                                  newline,
+                                  string "uw_error(ctx, FATAL, \"",
+                                  string (ErrorMsg.spanToString loc),
+                                  string ": pattern match failure\");",
+                                  newline,
+                                  string "tmp;",
+                                  newline,
+                                  string "})"]) pes,
+             string ";",
+             newline,
+             string "})"]
 
       | EWrite e => box [string "(uw_write(ctx, ",
                          p_exp env e,
-                         string "), uw_unit_v)"]
+                         string "), 0)"]
 
       | ESeq (e1, e2) =>
         let
@@ -1904,7 +1841,7 @@ fun p_exp' par env (e, loc) =
              newline,
 
              case mode of
-                 Settings.Error => string "uw_unit_v;"
+                 Settings.Error => string "0;"
                | Settings.None => string "uw_dup_and_clear_error_message(ctx);",
 
              newline,
@@ -1942,7 +1879,7 @@ fun p_exp' par env (e, loc) =
              newline,
              newline,
 
-             string "uw_unit_v;",
+             string "0;",
              newline,
              string "})"]
 
@@ -2624,18 +2561,20 @@ fun p_file env (ds, ps) =
                                                                    newline]) xts),
                                        newline,
                                        box (map getInput xts),
-                                       string "struct __uws_",
-                                       string (Int.toString i),
-                                       space,
-                                       string "uw_inputs",
-                                       space,
-                                       string "= {",
-                                       newline,
-                                       box (map (fn (x, _) => box [string "uw_input_",
-                                                                   p_ident x,
-                                                                   string ",",
-                                                                   newline]) xts),
-                                       string "};",
+                                       case i of
+                                           0 => string "uw_unit uw_inputs;"
+                                         | _ => box [string "struct __uws_",
+                                                     string (Int.toString i),
+                                                     space,
+                                                     string "uw_inputs",
+                                                     space,
+                                                     string "= {",
+                                                     newline,
+                                                     box (map (fn (x, _) => box [string "uw_input_",
+                                                                                 p_ident x,
+                                                                                 string ",",
+                                                                                 newline]) xts),
+                                                     string "};"],
                                        newline],
                                   box [string ",",
                                        space,
@@ -2780,7 +2719,7 @@ fun p_file env (ds, ps) =
                                      (string "ctx"
                                       :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
                           inputsVar,
-                          string ", uw_unit_v);",
+                          string ", 0);",
                           newline,
                           box (case ek of
                                    Core.Rpc _ => [urlify env ran]
@@ -3012,9 +2951,9 @@ fun p_file env (ds, ps) =
                                          newline,
                                          box [string "uw_unit __uwr_",
                                               string x1,
-                                              string "_0 = uw_unit_v, __uwr_",
+                                              string "_0 = 0, __uwr_",
                                               string x2,
-                                              string "_1 = uw_unit_v;",
+                                              string "_1 = 0;",
                                               newline,
                                               p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
                                               string ";",
@@ -3114,7 +3053,7 @@ fun p_file env (ds, ps) =
                                                               newline,
                                                               string "uw_unit __uwr_",
                                                               string x2,
-                                                              string "_1 = uw_unit_v;",
+                                                              string "_1 = 0;",
                                                               newline,
                                                               p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
                                                                                 x2 dummyt) e,
@@ -3138,9 +3077,9 @@ fun p_file env (ds, ps) =
                                                               newline,
                                                               string "uw_unit __uwr_",
                                                               string x1,
-                                                              string "_0 = uw_unit_v, __uwr_",
+                                                              string "_0 = 0, __uwr_",
                                                               string x2,
-                                                              string "_1 = uw_unit_v;",
+                                                              string "_1 = 0;",
                                                               newline,
                                                               p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
                                                               string ";",
@@ -3149,7 +3088,7 @@ fun p_file env (ds, ps) =
                                                               newline]) initializers,
                   if hasDb then
                       box [p_enamed env (!initialize),
-                           string "(ctx, uw_unit_v);",
+                           string "(ctx, 0);",
                            newline]
                   else
                       box []],
@@ -3162,7 +3101,7 @@ fun p_file env (ds, ps) =
                                 newline,
                                 box [string "uw_write(ctx, ",
                                      p_enamed env n,
-                                     string "(ctx, msg, uw_unit_v));",
+                                     string "(ctx, msg, 0));",
                                      newline],
                                 string "}",
                                 newline,