Mercurial > urweb
changeset 183:c0ea24dcb86f
Optimizing 'case' in Mono_reduce
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 03 Aug 2008 13:30:27 -0400 |
| parents | d11754ffe252 |
| children | 98c29e3986d3 |
| files | src/c/lacweb.c src/compiler.sig src/compiler.sml src/mono_env.sig src/mono_env.sml src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/monoize.sml src/prim.sig src/prim.sml tests/caseMod.lac |
| diffstat | 12 files changed, 108 insertions(+), 25 deletions(-) [+] |
line wrap: on
line diff
--- a/src/c/lacweb.c Sun Aug 03 12:43:20 2008 -0400 +++ b/src/c/lacweb.c Sun Aug 03 13:30:27 2008 -0400 @@ -192,8 +192,9 @@ } 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 @@ 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 @@ strcat(s, s2); ctx->heap_front += len; + printf("s = %s\n", s); + return s; }
--- a/src/compiler.sig Sun Aug 03 12:43:20 2008 -0400 +++ b/src/compiler.sig Sun Aug 03 13:30:27 2008 -0400 @@ -31,6 +31,7 @@ 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
--- a/src/compiler.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/compiler.sml Sun Aug 03 13:30:27 2008 -0400 @@ -422,6 +422,19 @@ 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 @@ 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
--- a/src/mono_env.sig Sun Aug 03 12:43:20 2008 -0400 +++ b/src/mono_env.sig Sun Aug 03 13:30:27 2008 -0400 @@ -39,8 +39,8 @@ 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
--- a/src/mono_env.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/mono_env.sml Sun Aug 03 13:30:27 2008 -0400 @@ -39,7 +39,7 @@ 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 @@ 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 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
--- a/src/mono_opt.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/mono_opt.sml Sun Aug 03 13:30:27 2008 -0400 @@ -79,7 +79,7 @@ str ch else "%" ^ hexIt ch) - + fun exp e = case e of EPrim (Prim.String s) => @@ -132,6 +132,10 @@ 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) =>
--- a/src/mono_print.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/mono_print.sml Sun Aug 03 13:30:27 2008 -0400 @@ -143,7 +143,7 @@ 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, _) =>
--- a/src/mono_reduce.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/mono_reduce.sml Sun Aug 03 13:30:27 2008 -0400 @@ -63,14 +63,59 @@ 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 @@ | 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
--- a/src/monoize.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/monoize.sml Sun Aug 03 13:30:27 2008 -0400 @@ -63,6 +63,8 @@ | 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 @@ 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 @@ | _ => (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
--- a/src/prim.sig Sun Aug 03 12:43:20 2008 -0400 +++ b/src/prim.sig Sun Aug 03 13:30:27 2008 -0400 @@ -34,4 +34,6 @@ val p_t : t Print.printer + val equal : t * t -> bool + end
--- a/src/prim.sml Sun Aug 03 12:43:20 2008 -0400 +++ b/src/prim.sml Sun Aug 03 13:30:27 2008 -0400 @@ -41,4 +41,12 @@ | 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
--- a/tests/caseMod.lac Sun Aug 03 12:43:20 2008 -0400 +++ b/tests/caseMod.lac Sun Aug 03 13:30:27 2008 -0400 @@ -24,8 +24,11 @@ | C B => "C B" | D => "D" -val page = fn x => <html><body> - {cdata (toString x)} +val rec page = fn x => <html><body> + {cdata (toString x)}<br/> + <br/> + + <a link={page x}>Again!</a> </body></html> val main : unit -> page = fn () => <html><body>