aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 13:30:27 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 13:30:27 -0400
commitb6123d25d202d3cbe1f12d24dec129a90d5051ec (patch)
tree5537d58d7dba623127804b35813d7c0ec673f8b9
parent6314b4c27a14576b356258dad74607168135cb51 (diff)
Optimizing 'case' in Mono_reduce
-rw-r--r--src/c/lacweb.c9
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml23
-rw-r--r--src/mono_env.sig4
-rw-r--r--src/mono_env.sml8
-rw-r--r--src/mono_opt.sml6
-rw-r--r--src/mono_print.sml2
-rw-r--r--src/mono_reduce.sml57
-rw-r--r--src/monoize.sml6
-rw-r--r--src/prim.sig2
-rw-r--r--src/prim.sml8
-rw-r--r--tests/caseMod.lac7
12 files changed, 108 insertions, 25 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
diff --git a/tests/caseMod.lac b/tests/caseMod.lac
index 49bfdca8..0a870160 100644
--- a/tests/caseMod.lac
+++ b/tests/caseMod.lac
@@ -24,8 +24,11 @@ val toString = fn x =>
| 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>