diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-11-06 18:49:38 -0500 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-11-06 18:49:38 -0500 |
commit | dd4d718ac9f0a9862ebef19beb568bbedcc85848 (patch) | |
tree | 89c4891d29fe4c10e81ed23ad7747b2a7d115064 /src | |
parent | 36952b2e49afdb4ba8024eb6372992e4b5d8df7a (diff) |
Tree demo works
Diffstat (limited to 'src')
-rw-r--r-- | src/c/urweb.c | 2 | ||||
-rw-r--r-- | src/cjr_print.sml | 9 | ||||
-rw-r--r-- | src/mono_reduce.sml | 440 | ||||
-rw-r--r-- | src/monoize.sml | 19 | ||||
-rw-r--r-- | src/urweb.grm | 13 | ||||
-rw-r--r-- | src/urweb.lex | 1 |
6 files changed, 285 insertions, 199 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c index 1530c138..e50d6965 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -174,7 +174,7 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { newLen = 1; else newLen = len * 2; - ctx->cleanup = realloc(ctx->cleanup, newLen); + ctx->cleanup = realloc(ctx->cleanup, newLen * sizeof(cleanup)); ctx->cleanup_front = ctx->cleanup + len; ctx->cleanup_back = ctx->cleanup + newLen; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b6c32e24..2485e317 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -70,13 +70,14 @@ fun isUnboxable (t : typ) = fun p_typ' par env (t, loc) = case t of - TFun (t1, t2) => parenIf par (box [p_typ' true env t2, + TFun (t1, t2) => parenIf par (box [string "(", + p_typ' true env t2, space, string "(*)", space, string "(", p_typ env t1, - string ")"]) + string "))"]) | TRecord i => box [string "struct", space, string "__uws_", @@ -1151,6 +1152,10 @@ fun p_exp' par env (e, loc) = p_exp env initial, string ";", newline, + case prepared of + NONE => box [string "printf(\"Executing: %s\\n\", query);", + newline] + | _ => box [], string "PGresult *res = ", case prepared of NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index bf68f175..dce6ef35 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -34,6 +34,8 @@ open Mono structure E = MonoEnv structure U = MonoUtil +structure IM = IntBinaryMap + fun impure (e, _) = case e of @@ -212,6 +214,8 @@ fun p_event e = | Unsure => string "Unsure" end +val p_events = Print.p_list p_event + fun patBinds (p, _) = case p of PWild => 0 @@ -223,218 +227,266 @@ fun patBinds (p, _) = | PNone _ => 0 | PSome (_, p) => patBinds p -fun summarize d (e, _) = - case e of - EPrim _ => [] - | ERel n => if n >= d then [UseRel (n - d)] else [] - | ENamed _ => [] - | ECon (_, _, NONE) => [] - | ECon (_, _, SOME e) => summarize d e - | ENone _ => [] - | ESome (_, e) => summarize d e - | EFfi _ => [] - | EFfiApp ("Basis", "set_cookie", _) => [Unsure] - | EFfiApp (_, _, es) => List.concat (map (summarize d) es) - | EApp ((EFfi _, _), e) => summarize d e - | EApp _ => [Unsure] - | EAbs _ => [] - - | EUnop (_, e) => summarize d e - | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - - | ERecord xets => List.concat (map (summarize d o #2) xets) - | EField (e, _) => summarize d e - - | ECase (e, pes, _) => - let - val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes - in - case lss of - [] => raise Fail "Empty pattern match" - | ls :: lss => - if List.all (fn ls' => ls' = ls) lss then - summarize d e @ ls - else - [Unsure] - end - | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 - - | EError (e, _) => summarize d e @ [Unsure] - - | EWrite e => summarize d e @ [WritePage] - - | ESeq (e1, e2) => summarize d e1 @ summarize d e2 - | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 - - | EClosure (_, es) => List.concat (map (summarize d) es) - - | EQuery {query, body, initial, ...} => - List.concat [summarize d query, - summarize (d + 2) body, - summarize d initial, - [ReadDb]] - - | EDml e => summarize d e @ [WriteDb] - | ENextval e => summarize d e @ [WriteDb] - | EUnurlify (e, _) => summarize d e - -fun exp env e = +fun reduce file = let - (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) - - val r = + fun countAbs (e, _) = + case e of + EAbs (_, _, _, e) => 1 + countAbs e + | _ => 0 + + val absCounts = + foldl (fn ((d, _), absCounts) => + case d of + DVal (_, n, _, e, _) => + IM.insert (absCounts, n, countAbs e) + | DValRec vis => + foldl (fn ((_, n, _, e, _), absCounts) => + IM.insert (absCounts, n, countAbs e)) + absCounts vis + | _ => absCounts) + IM.empty file + + fun summarize d (e, _) = case e of - ERel n => - (case E.lookupERel env n of - (_, _, SOME e') => #1 e' - | _ => e) - | ENamed n => - (case E.lookupENamed env n of - (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), - ("e'", MonoPrint.p_exp env e')];*) - #1 e') - | _ => e) - - | EApp ((EAbs (x, t, _, e1), loc), e2) => - ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), - ("e2", MonoPrint.p_exp env e2), - ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) - if impure e2 then - #1 (reduceExp env (ELet (x, t, e2, e1), loc)) - else - #1 (reduceExp env (subExpInExp (0, e2) e1))) - - | ECase (e', pes, {disc, result}) => + EPrim _ => [] + | ERel n => if n >= d then [UseRel (n - d)] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", _) => [Unsure] + | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => let - fun push () = - case result of - (TFun (dom, result), loc) => - if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then - EAbs ("_", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | _ => raise Fail "MonoReduce ECase") pes, - {disc = disc, result = result}), loc)) - else - e - | _ => e - - fun search pes = - case pes of - [] => push () - | (p, body) :: pes => - case match (env, p, e') of - No => search pes - | Maybe => push () - | Yes env => #1 (reduceExp env body) + fun unravel (e, ls) = + case e of + ENamed n => + let + val ls = rev ls + in + case IM.find (absCounts, n) of + NONE => [Unsure] + | SOME len => + if length ls < len then + ls + else + [Unsure] + end + | ERel n => List.revAppend (ls, [UseRel (n - d), Unsure]) + | EApp (f, x) => + unravel (#1 f, summarize d x @ ls) + | _ => [Unsure] in - search pes + unravel (e, []) end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EAbs _ => [] + + | EUnop (_, e) => summarize d e + | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + | ERecord xets => List.concat (map (summarize d o #2) xets) + | EField (e, _) => summarize d e + + | ECase (e, pes, _) => let - val e' = (ELet (x2, t2, e1, - (ELet (x1, t1, b1, - liftExpInExp 1 b2), loc)), loc) + val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes in - (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), - ("e'", MonoPrint.p_exp env e')];*) - #1 (reduceExp env e') + case lss of + [] => raise Fail "Empty pattern match" + | ls :: lss => + if List.all (fn ls' => ls' = ls) lss then + summarize d e @ ls + else + [Unsure] end - | EApp ((ELet (x, t, e, b), loc), e') => - #1 (reduceExp env (ELet (x, t, e, - (EApp (b, liftExpInExp 0 e'), loc)), loc)) - - | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => - (*if impure e' then - e - else*) - (* Seems unsound in general without the check... should revisit later *) - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) - - | ELet (x, t, e', b) => - let - fun doSub () = - #1 (reduceExp env (subExpInExp (0, e') b)) - - fun trySub () = - case t of - (TFfi ("Basis", "string"), _) => doSub () - | _ => - case e' of - (ECase _, _) => e - | _ => doSub () - in - if impure e' then + | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 + + | EError (e, _) => summarize d e @ [Unsure] + + | EWrite e => summarize d e @ [WritePage] + + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 + | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 + + | EClosure (_, es) => List.concat (map (summarize d) es) + + | EQuery {query, body, initial, ...} => + List.concat [summarize d query, + summarize (d + 2) body, + summarize d initial, + [ReadDb]] + + | EDml e => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e + + + fun exp env e = + let + (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + val r = + case e of + ERel n => + (case E.lookupERel env n of + (_, _, SOME e') => #1 e' + | _ => e) + | ENamed n => + (case E.lookupENamed env n of + (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), + ("e'", MonoPrint.p_exp env e')];*) + #1 e') + | _ => e) + + | EApp ((EAbs (x, t, _, e1), loc), e2) => + ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), + ("e2", MonoPrint.p_exp env e2), + ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) + if impure e2 then + #1 (reduceExp env (ELet (x, t, e2, e1), loc)) + else + #1 (reduceExp env (subExpInExp (0, e2) e1))) + + | ECase (e', pes, {disc, result}) => let - val effs_e' = summarize 0 e' - val effs_b = summarize 0 b - - fun does eff = List.exists (fn eff' => eff' = eff) effs_e' - val writesPage = does WritePage - val readsDb = does ReadDb - val writesDb = does WriteDb - - fun verifyUnused eff = - case eff of - UseRel r => r <> 0 - | Unsure => false - | _ => true - - fun verifyCompatible effs = - case effs of - [] => false - | eff :: effs => - case eff of - Unsure => false - | UseRel r => - if r = 0 then - List.all verifyUnused effs - else - verifyCompatible effs - | WritePage => not writesPage andalso verifyCompatible effs - | ReadDb => not writesDb andalso verifyCompatible effs - | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + fun push () = + case result of + (TFun (dom, result), loc) => + if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then + EAbs ("_", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | _ => raise Fail "MonoReduce ECase") pes, + {disc = disc, result = result}), loc)) + else + e + | _ => e + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e') of + No => search pes + | Maybe => push () + | Yes env => #1 (reduceExp env body) in - (*Print.prefaces "verifyCompatible" - [("e'", MonoPrint.p_exp env e'), - ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), - ("effs_e'", Print.p_list p_event effs_e'), - ("effs_b", Print.p_list p_event effs_b)];*) - if verifyCompatible effs_b then - trySub () - else - e + search pes end - else - trySub () - end - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EField ((ERecord xes, _), x) => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => #1 e + | NONE => e) - | _ => e - in - (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) - r - end + | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + let + val e' = (ELet (x2, t2, e1, + (ELet (x1, t1, b1, + liftExpInExp 1 b2), loc)), loc) + in + (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), + ("e'", MonoPrint.p_exp env e')];*) + #1 (reduceExp env e') + end + | EApp ((ELet (x, t, e, b), loc), e') => + #1 (reduceExp env (ELet (x, t, e, + (EApp (b, liftExpInExp 0 e'), loc)), loc)) + + | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + (*if impure e' then + e + else*) + (* Seems unsound in general without the check... should revisit later *) + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) + + | ELet (x, t, e', b) => + let + fun doSub () = + #1 (reduceExp env (subExpInExp (0, e') b)) + + fun trySub () = + case t of + (TFfi ("Basis", "string"), _) => doSub () + | _ => + case e' of + (ECase _, _) => e + | _ => doSub () + in + if impure e' then + let + val effs_e' = summarize 0 e' + val effs_b = summarize 0 b + + (*val () = Print.prefaces "Try" + [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + ("e'", p_events effs_e'), + ("b", p_events effs_b)]*) + + fun does eff = List.exists (fn eff' => eff' = eff) effs_e' + val writesPage = does WritePage + val readsDb = does ReadDb + val writesDb = does WriteDb + + fun verifyUnused eff = + case eff of + UseRel r => r <> 0 + | _ => true + + fun verifyCompatible effs = + case effs of + [] => false + | eff :: effs => + case eff of + Unsure => false + | UseRel r => + if r = 0 then + List.all verifyUnused effs + else + verifyCompatible effs + | WritePage => not writesPage andalso verifyCompatible effs + | ReadDb => not writesDb andalso verifyCompatible effs + | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + in + (*Print.prefaces "verifyCompatible" + [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("effs_e'", Print.p_list p_event effs_e'), + ("effs_b", Print.p_list p_event effs_b)];*) + if verifyCompatible effs_b then + trySub () + else + e + end + else + trySub () + end + + | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => + EPrim (Prim.String (s1 ^ s2)) -and 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 NONE - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s + | _ => e + in + (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + r + end -and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env + and 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 NONE + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s -fun decl env d = d + and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env -val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty + fun decl env d = d + in + U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file + end end diff --git a/src/monoize.sml b/src/monoize.sml index 70f15867..9e1a4d22 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1584,6 +1584,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_is_null"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun sc s = (L'.EPrim (Prim.String s), loc) + in + ((L'.EAbs ("s", s, s, + strcat loc [sc "(", + (L'.ERel 0, loc), + sc " IS NULL)"]), loc), + fm) + end + | L.EFfiApp ("Basis", "nextval", [e]) => let val (e, fm) = monoExp (env, st, fm) e diff --git a/src/urweb.grm b/src/urweb.grm index 2482be1b..4ac14450 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -346,7 +346,7 @@ fun tagIn bt = %right COMMA %right OR %right CAND -%nonassoc EQ NE LT LE GT GE +%nonassoc EQ NE LT LE GT GE IS %right ARROW %right PLUSPLUS MINUSMINUS %left PLUS MINUS @@ -1236,6 +1236,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) + | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1247,6 +1249,13 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + | sqlexp IS NULL (let + val loc = s (sqlexpleft, NULLright) + in + (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc), + sqlexp), loc) + end) + | LBRACE eexp RBRACE (sql_inject (#1 eexp, s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) diff --git a/src/urweb.lex b/src/urweb.lex index f4ae3a85..642282ec 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -358,6 +358,7 @@ notags = [^<{\n]+; <INITIAL> "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); <INITIAL> "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); <INITIAL> "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); +<INITIAL> "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); |