Optimizing 'case' in Mono_reduce

11 files changed, 103 insertions, 23 deletions

diff --git a/src/c/lacweb.c b/src/c/lacweb.c
index 7ee6daef..50f11ef1 100644
--- a/src/c/lacweb.c
+++ b/src/c/lacweb.c
@@ -192,8 +192,9 @@ static void lw_write_unsafe(lw_context ctx, const char* s) {
 }
 
 void lw_write(lw_context ctx, const char* s) {
-  lw_check(ctx, strlen(s));
+  lw_check(ctx, strlen(s) + 1);
   lw_write_unsafe(ctx, s);
+  *ctx->page_front = 0;
 }
 
 
@@ -510,7 +511,9 @@ lw_Basis_string lw_Basis_strcat(lw_context ctx, lw_Basis_string s1, lw_Basis_str
   int len = strlen(s1) + strlen(s2) + 1;
   char *s;
 
-  lw_check(ctx, len);
+  printf("s1 = %s\ns2 = %s\n", s1, s2);
+
+  lw_check_heap(ctx, len);
 
   s = ctx->heap_front;
 
@@ -518,5 +521,7 @@ lw_Basis_string lw_Basis_strcat(lw_context ctx, lw_Basis_string s1, lw_Basis_str
   strcat(s, s2);
   ctx->heap_front += len;
 
+  printf("s = %s\n", s);
+
   return s;
 }
diff --git a/src/compiler.sig b/src/compiler.sig
index dfe4e930..9f856158 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -31,6 +31,7 @@ signature COMPILER = sig
 
     type job = string list
     val compile : job -> unit
+    val compileC : {cname : string, oname : string, ename : string} -> unit
 
     val parseLig : string -> Source.sgn_item list option
     val testLig : string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index eadb58d7..2be17762 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -422,6 +422,19 @@ fun testCjrize job =
     handle CjrEnv.UnboundNamed n =>
            print ("Unbound named " ^ Int.toString n ^ "\n")
 
+fun compileC {cname, oname, ename} =
+    let
+        val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname
+        val link = "gcc -pthread -O3 clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
+    in
+        if not (OS.Process.isSuccess (OS.Process.system compile)) then
+            print "C compilation failed\n"
+        else if not (OS.Process.isSuccess (OS.Process.system link)) then
+                print "C linking failed\n"
+        else
+            print "Success\n"
+    end
+
 fun compile job =
     case cjrize job of
         NONE => print "Laconic compilation failed\n"
@@ -431,21 +444,13 @@ fun compile job =
             val oname = "/tmp/lacweb.o"
             val ename = "/tmp/webapp"
 
-            val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname
-            val link = "gcc -pthread -O3 clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
-
             val outf = TextIO.openOut cname
             val s = TextIOPP.openOut {dst = outf, wid = 80}
         in
             Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
             TextIO.closeOut outf;
 
-            if not (OS.Process.isSuccess (OS.Process.system compile)) then
-                print "C compilation failed\n"
-            else if not (OS.Process.isSuccess (OS.Process.system link)) then
-                print "C linking failed\n"
-            else
-                print "Success\n"
+            compileC {cname = cname, oname = oname, ename = ename}
         end
 
 end
diff --git a/src/mono_env.sig b/src/mono_env.sig
index 0c842de3..cb6f2352 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -39,8 +39,8 @@ signature MONO_ENV = sig
 
     val lookupConstructor : env -> int -> string * Mono.typ option * int
 
-    val pushERel : env -> string -> Mono.typ -> env
-    val lookupERel : env -> int -> string * Mono.typ
+    val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env
+    val lookupERel : env -> int -> string * Mono.typ * Mono.exp option
 
     val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env
     val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string
diff --git a/src/mono_env.sml b/src/mono_env.sml
index f2be9b4b..f5f1f3d9 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -39,7 +39,7 @@ type env = {
      datatypes : (string * (string * int * typ option) list) IM.map,
      constructors : (string * typ option * int) IM.map,
 
-     relE : (string * typ) list,
+     relE : (string * typ * exp option) list,
      namedE : (string * typ * exp option * string) IM.map
 }
 
@@ -70,11 +70,11 @@ fun lookupConstructor (env : env) n =
         NONE => raise UnboundNamed n
       | SOME x => x
 
-fun pushERel (env : env) x t =
+fun pushERel (env : env) x t eo =
     {datatypes = #datatypes env,
      constructors = #constructors env,
 
-     relE = (x, t) :: #relE env,
+     relE = (x, t, eo) :: #relE env,
      namedE = #namedE env}
 
 fun lookupERel (env : env) n =
@@ -110,7 +110,7 @@ fun declBinds env (d, loc) =
 fun patBinds env (p, loc) =
     case p of
         PWild => env
-      | PVar (x, t) => pushERel env x t
+      | PVar (x, t) => pushERel env x t NONE
       | PPrim _ => env
       | PCon (_, NONE) => env
       | PCon (_, SOME p) => patBinds env p
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 81e42b56..414d9677 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -79,7 +79,7 @@ val urlifyString = String.translate (fn #" " => "+"
                                                   str ch
                                               else
                                                   "%" ^ hexIt ch)
-                   
+        
 fun exp e =
     case e of
         EPrim (Prim.String s) =>
@@ -132,6 +132,10 @@ fun exp e =
         ESeq ((optExp (EWrite e1, loc), loc),
               (optExp (EWrite e2, loc), loc))
 
+      | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
+              (EWrite (EPrim (Prim.String s2), _), _)) =>
+        EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
+
       | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
         EPrim (Prim.String (htmlifyString s))
       | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
diff --git a/src/mono_print.sml b/src/mono_print.sml
index dcd4eb84..e069c1ec 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -143,7 +143,7 @@ fun p_exp' par env (e, _) =
                                                space,
                                                string "=>",
                                                space,
-                                               p_exp (E.pushERel env x t) e])
+                                               p_exp (E.pushERel env x t NONE) e])
 
       | ERecord xes => box [string "{",
                             p_list (fn (x, e, _) =>
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 9b9d8f6a..e780d6d8 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -63,14 +63,59 @@ val subExpInExp =
 fun bind (env, b) =
     case b of
         U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
-      | U.Decl.RelE (x, t) => E.pushERel env x t
+      | U.Decl.RelE (x, t) => E.pushERel env x t NONE
       | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
 
 fun typ c = c
 
+fun match (env, p : pat, e : exp) =
+    case (#1 p, #1 e) of
+        (PWild, _) => SOME env
+      | (PVar (x, t), _) => SOME (E.pushERel env x t (SOME e))
+
+      | (PPrim p, EPrim p') =>
+        if Prim.equal (p, p') then
+            SOME env
+        else
+            NONE
+
+      | (PCon (PConVar n1, NONE), ECon (n2, NONE)) =>
+        if n1 = n2 then
+            SOME env
+        else
+            NONE
+
+      | (PCon (PConVar n1, SOME p), ECon (n2, SOME e)) =>
+        if n1 = n2 then
+            match (env, p, e)
+        else
+            NONE
+
+      | (PRecord xps, ERecord xes) =>
+        let
+            fun consider (xps, env) =
+                case xps of
+                    [] => SOME env
+                  | (x, p, _) :: rest =>
+                    case List.find (fn (x', _, _) => x' = x) xes of
+                        NONE => NONE
+                      | SOME (_, e, _) =>
+                        case match (env, p, e) of
+                            NONE => NONE
+                          | SOME env => consider (rest, env)
+        in
+            consider (xps, env)
+        end
+
+      | _ => NONE
+
 fun exp env e =
     case e of
-        ENamed n =>
+        ERel n =>
+        (case E.lookupERel env n of
+             (_, _, SOME e') => #1 e'
+           | _ => e)
+      | ENamed n =>
         (case E.lookupENamed env n of
              (_, _, SOME e', _) => #1 e'
            | _ => e)
@@ -78,6 +123,14 @@ fun exp env e =
       | EApp ((EAbs (_, _, _, e1), loc), e2) =>
         #1 (reduceExp env (subExpInExp (0, e2) e1))
 
+      | ECase (disc, pes, t) =>
+        (case ListUtil.search (fn (p, body) =>
+                                  case match (env, p, disc) of
+                                      NONE => NONE
+                                    | SOME env => SOME (#1 (reduceExp env body))) pes of
+             NONE => e
+           | SOME e' => e')
+
       | _ => e
 
 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
diff --git a/src/monoize.sml b/src/monoize.sml
index dfd727f7..94442132 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -63,6 +63,8 @@ fun monoType env (all as (c, loc)) =
 
           | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
             (L'.TFfi ("Basis", "string"), loc)
+          | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
+            (L'.TFfi ("Basis", "string"), loc)
 
           | L.CRel _ => poly ()
           | L.CNamed n =>
@@ -164,7 +166,7 @@ fun fooifyExp fk env =
                 let
                     val (_, _, _, s) = Env.lookupENamed env fnam
                 in
-                    ((L'.EPrim (Prim.String s), loc), fm)
+                    ((L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
                 end
               | L'.EClosure (fnam, args) =>
                 let
@@ -187,7 +189,7 @@ fun fooifyExp fk env =
                           | _ => (E.errorAt loc "Type mismatch encoding attribute";
                                   (e, fm))
                 in
-                    attrify (args, ft, (L'.EPrim (Prim.String s), loc), fm)
+                    attrify (args, ft, (L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
                 end
               | _ =>
                 case t of
diff --git a/src/prim.sig b/src/prim.sig
index 6861ec8a..e443e515 100644
--- a/src/prim.sig
+++ b/src/prim.sig
@@ -34,4 +34,6 @@ signature PRIM = sig
 
     val p_t : t Print.printer
 
+    val equal : t * t -> bool
+
 end
diff --git a/src/prim.sml b/src/prim.sml
index f58918b7..3e8506a9 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -41,4 +41,12 @@ fun p_t t =
       | Float n => string (Real64.toString n)
       | String s => box [string "\"", string (String.toString s), string "\""]
 
+fun equal x =
+    case x of
+        (Int n1, Int n2) => n1 = n2
+      | (Float n1, Float n2) => Real64.== (n1, n2)
+      | (String s1, String s2) => s1 = s2
+
+      | _ => false
+
 end