Mercurial > urweb
changeset 2221:278e10629ba1
Basic field-resolution invalidation.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Sat, 29 Nov 2014 03:37:59 -0500 |
| parents | 794017f378de |
| children | 4d967a4ddb82 |
| files | caching-tests/test.db caching-tests/test.sql caching-tests/test.ur caching-tests/test.urs src/cjr_print.sml src/cjrize.sml src/iflow.sml src/jscomp.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_util.sml src/monoize.sig src/monoize.sml src/sqlcache.sml src/urweb.lex |
| diffstat | 16 files changed, 266 insertions(+), 219 deletions(-) [+] |
line wrap: on
line diff
--- a/caching-tests/test.sql Mon Nov 24 20:47:38 2014 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -CREATE TABLE uw_Test_foo01(uw_id int8 NOT NULL, uw_bar text NOT NULL, - PRIMARY KEY (uw_id) - - ); - - CREATE TABLE uw_Test_foo10(uw_id int8 NOT NULL, uw_bar text NOT NULL, - PRIMARY KEY (uw_id) - - ); - - CREATE TABLE uw_Test_tab(uw_id int8 NOT NULL, uw_val int8 NOT NULL, - PRIMARY KEY (uw_id) - - ); - - \ No newline at end of file
--- a/caching-tests/test.ur Mon Nov 24 20:47:38 2014 -0500 +++ b/caching-tests/test.ur Sat Nov 29 03:37:59 2014 -0500 @@ -11,26 +11,26 @@ | Some row => <xml>{[row.Foo01.Bar]}</xml>} </body></xml> -fun cache10 () = - res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) - (fn row => <xml>{[row.Foo10.Bar]}</xml>); - return <xml><body> - Reading 2. - {res} - </body></xml> +(* fun cache10 () = *) +(* res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) *) +(* (fn row => <xml>{[row.Foo10.Bar]}</xml>); *) +(* return <xml><body> *) +(* Reading 2. *) +(* {res} *) +(* </body></xml> *) -fun cache11 () = - res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); - bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); - return <xml><body> - Reading 1 and 2. - {case res of - None => <xml>?</xml> - | Some row => <xml>{[row.Foo01.Bar]}</xml>} - {case bla of - None => <xml>?</xml> - | Some row => <xml>{[row.Foo10.Bar]}</xml>} - </body></xml> +(* fun cache11 () = *) +(* res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); *) +(* bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); *) +(* return <xml><body> *) +(* Reading 1 and 2. *) +(* {case res of *) +(* None => <xml>?</xml> *) +(* | Some row => <xml>{[row.Foo01.Bar]}</xml>} *) +(* {case bla of *) +(* None => <xml>?</xml> *) +(* | Some row => <xml>{[row.Foo10.Bar]}</xml>} *) +(* </body></xml> *) fun flush01 () = dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); @@ -39,18 +39,18 @@ Flushed 1! </body></xml> -fun flush10 () = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return <xml><body> - Flushed 2! - </body></xml> +(* fun flush10 () = *) +(* dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); *) +(* return <xml><body> *) +(* Flushed 2! *) +(* </body></xml> *) -fun flush11 () = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return <xml><body> - Flushed 1 and 2! - </body></xml> +(* fun flush11 () = *) +(* dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); *) +(* dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); *) +(* return <xml><body> *) +(* Flushed 1 and 2! *) +(* </body></xml> *) fun cache id = res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); @@ -63,9 +63,9 @@ fun flush id = res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); - dml (case res of - None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0)) - | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]})); + (case res of + None => dml (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0)) + | Some row => dml (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]})); return <xml><body> (* Flushed {[id]}! *) {case res of
--- a/caching-tests/test.urs Mon Nov 24 20:47:38 2014 -0500 +++ b/caching-tests/test.urs Sat Nov 29 03:37:59 2014 -0500 @@ -1,8 +1,8 @@ val cache01 : unit -> transaction page -val cache10 : unit -> transaction page -val cache11 : unit -> transaction page +(* val cache10 : unit -> transaction page *) +(* val cache11 : unit -> transaction page *) val flush01 : unit -> transaction page -val flush10 : unit -> transaction page -val flush11 : unit -> transaction page +(* val flush10 : unit -> transaction page *) +(* val flush11 : unit -> transaction page *) val cache : int -> transaction page val flush : int -> transaction page
--- a/src/cjr_print.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/cjr_print.sml Sat Nov 29 03:37:59 2014 -0500 @@ -3410,14 +3410,22 @@ fun paramRepeatInit itemi sep = if params = 0 then "" else sep ^ paramRepeat itemi sep val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " - val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n" + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" + ^ p ^ " = NULL;") + "\n" val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p - ^ " = strdup(p" ^ p ^ ");") "\n" - val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n" - (* Starting || makes logic easier when there are no parameters. *) + ^ " = strdup(p" ^ p ^ ");") + "\n" + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") + "\n" val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p ^ ", p" ^ p ^ ")") " || " + (* Using [!=] instead of [==] to mimic [strcmp]. *) + val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || " + ^ "!strcmp(param" ^ i ^ "_" + ^ p ^ ", p" ^ p ^ "))") + " && " in box [string "static char *cacheQuery", string i, string " = NULL;", @@ -3471,13 +3479,21 @@ newline, string "static uw_unit uw_Sqlcache_flush", string i, - string "(uw_context ctx) {\n free(cacheQuery", + string "(uw_context ctx", + string args, + string ") {\n if (cacheQuery", + string i, + string " != NULL", + string eqsNull, + string ") {\n free(cacheQuery", string i, string ");\n cacheQuery", string i, string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string ".\");\n return uw_unit_v;\n };", + string ".\");}\n else { puts(\"SQLCACHE: keeping ", + string i, + string "\"); } return uw_unit_v;\n };", newline, newline] end)
--- a/src/cjrize.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/cjrize.sml Sat Nov 29 03:37:59 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -431,7 +431,7 @@ | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; (dummye, sm)) - | L.EQuery {exps, tables, state, query, body, initial} => + | L.EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => let val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => let @@ -586,7 +586,7 @@ let val (vis, sm) = ListUtil.foldlMap (fn ((x, n, t, e, _), sm) => - let + let val (t, sm) = cifyTyp (t, sm) fun unravel (tAll as (t, _), eAll as (e, _)) = @@ -601,7 +601,7 @@ (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; ([], tAll, eAll)) | _ => ([], tAll, eAll) - + val (args, ran, e) = unravel (t, e) val (e, sm) = cifyExp (e, sm) in @@ -610,7 +610,7 @@ sm vis in (SOME (L'.DFunRec vis, loc), NONE, sm) - end + end | L.DExport (ek, s, n, ts, t, b) => let
--- a/src/iflow.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/iflow.sml Sat Nov 29 03:37:59 2014 -0500 @@ -1870,14 +1870,15 @@ case e of EDml (e, fm) => nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => nameSubexps (fn (liftBy, e') => (EQuery {exps = exps, tables = tables, state = state, query = e', body = mliftExpInExp liftBy 2 body, - initial = mliftExpInExp liftBy 0 initial}, + initial = mliftExpInExp liftBy 0 initial, + sqlcacheInfo = sqlcacheInfo}, #2 query)) query | _ => e, decl = fn d => d} @@ -2070,11 +2071,12 @@ | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) | ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc) | EClosure (n, es) => (EClosure (n, map (doExp env) es), loc) - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => (EQuery {exps = exps, tables = tables, state = state, query = doExp env query, body = doExp (Unknown :: Unknown :: env) body, - initial = doExp env initial}, loc) + initial = doExp env initial, + sqlcacheInfo = sqlcacheInfo}, loc) | EDml (e1, mode) => (case parse dml e1 of NONE => ()
--- a/src/jscomp.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/jscomp.sml Sat Nov 29 03:37:59 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -195,7 +195,7 @@ str loc "}"])], {disc = t, result = s}), loc) val body = (EAbs ("x", t, s, body), loc) - + val st = {decls = ("jsify", n', (TFun (t, s), loc), body, "jsify") :: #decls st, script = #script st, @@ -575,7 +575,7 @@ val e = String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" | ch => String.str ch) e - + val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'" ^ e ^ "'};\n" in @@ -799,7 +799,7 @@ | _ => default () in seek (e', [x]) - end + end | ECase (e', pes, _) => let @@ -1030,7 +1030,7 @@ | ERel _ => (e, st) | ENamed _ => (e, st) | ECon (_, _, NONE) => (e, st) - | ECon (dk, pc, SOME e) => + | ECon (dk, pc, SOME e) => let val (e, st) = exp outer (e, st) in @@ -1082,7 +1082,7 @@ in ((EBinop (bi, s, e1, e2), loc), st) end - + | ERecord xets => let val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => @@ -1176,7 +1176,7 @@ ((EClosure (n, es), loc), st) end - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => let val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row @@ -1187,7 +1187,8 @@ val (initial, st) = exp outer (initial, st) in ((EQuery {exps = exps, tables = tables, state = state, - query = query, body = body, initial = initial}, loc), st) + query = query, body = body, initial = initial, + sqlcacheInfo = sqlcacheInfo}, loc), st) end | EDml (e, mode) => let @@ -1257,7 +1258,7 @@ in ((ESignalSource e, loc), st) end - + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st)
--- a/src/mono.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/mono.sml Sat Nov 29 03:37:59 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -107,7 +107,8 @@ state : typ, query : exp, (* exp of string type containing sql query *) body : exp, - initial : exp } + initial : exp, + sqlcacheInfo : exp } | EDml of exp * failure_mode | ENextval of exp | ESetval of exp * exp @@ -119,7 +120,7 @@ | ESignalReturn of exp | ESignalBind of exp * exp | ESignalSource of exp - + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp
--- a/src/mono_opt.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/mono_opt.sml Sat Nov 29 03:37:59 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -166,7 +166,7 @@ e | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) - + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => let val s = @@ -179,7 +179,7 @@ in EPrim (Prim.String (Prim.Html, s)) end - + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => EPrim (Prim.String (Prim.Normal, s1 ^ s2)) @@ -397,18 +397,20 @@ initial = (EPrim (Prim.String (k, "")), _), body = (EStrcat ((EPrim (Prim.String (_, s)), _), (EStrcat ((ERel 0, _), - e'), _)), _)}, loc) => + e'), _)), _), + sqlcacheInfo}, loc) => if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = (optExp (EWrite e', loc), loc)} + body = (optExp (EWrite e', loc), loc), + sqlcacheInfo = Monoize.urlifiedUnit} else e | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String (_, "")), _), - body}, loc) => + body, sqlcacheInfo}, loc) => let fun passLets (depth, (e', _), lets) = case e' of @@ -423,7 +425,8 @@ EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = body} + body = body, + sqlcacheInfo = Monoize.urlifiedUnit} end else e @@ -532,7 +535,7 @@ else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -560,7 +563,7 @@ EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -585,7 +588,7 @@ EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => EPrim (Prim.String (Prim.Normal, unAs s)) | EFfiApp ("Basis", "unAs", [(e', _)]) => let @@ -620,7 +623,7 @@ EFfiApp ("Basis", "attrifyChar_w", [e]) | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) - + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
--- a/src/mono_print.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/mono_print.sml Sat Nov 29 03:37:59 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -310,7 +310,7 @@ p_exp env e]) es, string ")"] - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => box [string "query[", p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, string "] [", @@ -391,7 +391,7 @@ string "__", string (Int.toString n)] else - string x + string x in box [xp, space, @@ -541,7 +541,7 @@ space, p_policy env p] | DOnError _ => string "ONERROR" - + fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
--- a/src/mono_util.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/mono_util.sml Sat Nov 29 03:37:59 2014 -0500 @@ -314,7 +314,7 @@ fn es' => (EClosure (n, es'), loc)) - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => S.bind2 (ListUtil.mapfold (fn (x, t) => S.map2 (mft t, fn t' => (x, t'))) exps, @@ -334,15 +334,20 @@ RelE ("acc", dummyt))) body, fn body' => - S.map2 (mfe ctx initial, + (* ASK: is this the right thing to do? *) + S.bind2 (mfe ctx initial, fn initial' => - (EQuery {exps = exps', - tables = tables', - state = state', - query = query', - body = body', - initial = initial'}, - loc))))))) + S.map2 (mfe (bind (ctx, RelE ("queryResult", dummyt))) + sqlcacheInfo, + fn sqlcacheInfo' => + (EQuery {exps = exps', + tables = tables', + state = state', + query = query', + body = body', + initial = initial', + sqlcacheInfo = sqlcacheInfo}, + loc)))))))) | EDml (e, fm) => S.map2 (mfe ctx e,
--- a/src/monoize.sig Mon Nov 24 20:47:38 2014 -0500 +++ b/src/monoize.sig Sat Nov 29 03:37:59 2014 -0500 @@ -31,4 +31,6 @@ val liftExpInExp : int -> Mono.exp -> Mono.exp + val urlifiedUnit : Mono.exp + end
--- a/src/monoize.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/monoize.sml Sat Nov 29 03:37:59 2014 -0500 @@ -681,6 +681,16 @@ val attrifyExp = fooifyExp Attr val urlifyExp = fooifyExp Url +val urlifiedUnit = + let + val loc = ErrorMsg.dummySpan + (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *) + val (urlified, _) = urlifyExp CoreEnv.empty (Fm.empty 0) + ((L'.ERel 0, loc), (L'.TRecord [], loc)) + in + urlified + end + datatype 'a failable_search = Found of 'a | NotFound @@ -1957,26 +1967,24 @@ (L'.TFun (un, state), loc)), loc)), loc) - val body'' = (L'.EApp ( + val body' = (L'.EApp ( (L'.EApp ( (L'.EApp ((L'.ERel 4, loc), (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - val body' = (L'.EQuery {exps = exps, - tables = tables, - state = state, - query = (L'.ERel 3, loc), - body = body'', - initial = (L'.ERel 1, loc)}, - loc) - val (body, fm) = if Settings.getSqlcache () then - let - val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) - in - (Sqlcache.instrumentQuery (body', urlifiedRel0), fm) - end - else (body', fm) + val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) + val body = (L'.EQuery {exps = exps, + tables = tables, + state = state, + query = (L'.ERel 3, loc), + body = body', + initial = (L'.ERel 1, loc), + sqlcacheInfo = urlifiedRel0}, + loc) + val body = if Settings.getSqlcache () + then Sqlcache.instrumentQuery (body, urlifiedRel0) + else body in ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
--- a/src/sqlcache.sml Mon Nov 24 20:47:38 2014 -0500 +++ b/src/sqlcache.sml Sat Nov 29 03:37:59 2014 -0500 @@ -176,12 +176,10 @@ fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false -fun mapFormulaSigned positive mf = - fn Atom x => Atom (mf (positive, x)) - | Negate f => Negate (mapFormulaSigned (not positive) mf f) - | Combo (n, fs) => Combo (n, map (mapFormulaSigned positive mf) fs) - -fun mapFormula mf = mapFormulaSigned true (fn (_, x) => mf x) +fun mapFormula mf = + fn Atom x => Atom (mf x) + | Negate f => Negate (mapFormula mf f) + | Combo (n, fs) => Combo (n, map (mapFormula mf) fs) (* SQL analysis. *) @@ -225,11 +223,10 @@ end structure UF = UnionFindFn(AtomExpKey) - -(* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) -(* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) -(* -> Mono.exp' IM.map list = *) -(* let *) +val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula + * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula + -> atomExp IM.map list = + let val toKnownEquality = (* [NONE] here means unkown. Anything that isn't a comparison between two knowns shouldn't be used, and simply dropping unused terms is @@ -297,12 +294,12 @@ (SOME IM.empty) fun dnf (fQuery, fDml) = normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml])) - (* in *) - val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula - * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula - -> atomExp IM.map list = - List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf - (* end *) + in + (* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) + (* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) + (* -> atomExp IM.map list = *) + List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf + end val rec sqexpToFormula = fn Sql.SqTrue => Combo (Cnf, []) @@ -338,32 +335,21 @@ Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) val rec dmlToFormula = - fn Sql.Insert tableVals => valsToFormula tableVals + fn Sql.Insert (table, vals) => valsToFormula (table, vals) | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher) - (* TODO: refine formula for the vals part, which could take into account the wher part. *) - (* TODO: use pushNegate instead of mapFormulaSigned? *) | Sql.Update (table, vals, wher) => let - val f = sqexpToFormula wher - fun update (positive, a) = - let - fun updateIfNecessary field = - case List.find (fn (f, _) => field = f) vals of - SOME (_, v) => (if positive then Sql.Eq else Sql.Ne, - Sql.Field (table, field), - v) - | NONE => a - in - case a of - (_, Sql.Field (_, field), _) => updateIfNecessary field - | (_, _, Sql.Field (_, field)) => updateIfNecessary field - | _ => a - end + val fWhere = sqexpToFormula wher + val fVals = valsToFormula (table, vals) + (* TODO: don't use field name hack. *) + val markField = + fn Sql.Field (t, v) => Sql.Field (t, v ^ "*") + | e => e + val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) in renameTables [(table, "T")] - (Combo (Dnf, [f, - Combo (Cnf, [valsToFormula (table, vals), - mapFormulaSigned true update f])])) + (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]), + Combo (Cnf, [mark fVals, fWhere])])) end val rec tablesQuery = @@ -482,54 +468,62 @@ fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) +fun factorOutNontrivial text = + let + val loc = ErrorMsg.dummySpan + fun strcat (e1, e2) = (EStrcat (e1, e2), loc) + val chunks = Sql.chunkify text + val (newText, newVariables) = + (* Important that this is foldr (to oppose foldl below). *) + List.foldr + (fn (chunk, (qText, newVars)) => + (* Variable bound to the head of newBs will have the lowest index. *) + case chunk of + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => + let + val n = length newVars + in + (* This is the (n + 1)th new variable, so there are + already n new variables bound, so we increment + indices by n. *) + (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) + end + | Sql.String s => (strcat (stringExp s, qText), newVars)) + (stringExp "", []) + chunks + fun wrapLets e' = + (* Important that this is foldl (to oppose foldr above). *) + List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables + in + (newText, wrapLets, numArgs) + end + fun addChecking file = let - fun doExp (queryInfo as (tableToIndices, indexToQuery)) = + fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) = fn e' as ELet (v, t, - queryExp' as (EQuery {query = origQueryText, - initial, body, state, tables, exps}, queryLoc), + (EQuery {query = origQueryText, + initial, body, state, tables, exps, sqlcacheInfo}, queryLoc), letBody) => let - val loc = ErrorMsg.dummySpan - val chunks = Sql.chunkify origQueryText - fun strcat (e1, e2) = (EStrcat (e1, e2), loc) - val (newQueryText, newVariables) = - (* Important that this is foldr (to oppose foldl below). *) - List.foldr - (fn (chunk, (qText, newVars)) => - (* Variable bound to the head of newBs will have the lowest index. *) - case chunk of - Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) - | Sql.Exp e => - let - val n = length newVars - in - (* This is the (n + 1)th new variable, so - there are already n new variables bound, - so we increment indices by n. *) - (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) - end - | Sql.String s => (strcat (stringExp s, qText), newVars)) - (stringExp "", []) - chunks - fun wrapLets e' = - (* Important that this is foldl (to oppose foldr above). *) - List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) - e' - newVariables - val numArgs = length newVariables + val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText (* Increment once for each new variable just made. *) - val queryExp = incRels (length newVariables) + val queryExp = incRels numArgs (EQuery {query = newQueryText, initial = initial, body = body, state = state, tables = tables, - exps = exps}, + exps = exps, + sqlcacheInfo = sqlcacheInfo}, queryLoc) val (EQuery {query = queryText, ...}, _) = queryExp - val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); - val args = List.tabulate (numArgs, fn n => (ERel n, loc)) + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) + val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) fun bind x f = Option.mapPartial f x fun guard b x = if b then x else NONE (* DEBUG: set first boolean argument to true to turn on printing. *) @@ -542,11 +536,11 @@ bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 => SOME (wrapLets (ELet (v, t, cacheWrap (queryExp, index, urlifiedRel0, args), - incRelsBound 1 (length newVariables) letBody)), + incRelsBound 1 numArgs letBody)), (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), - IM.insert (indexToQuery, index, (queryParsed, numArgs)))))))) + IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)))))))) in case attempt of SOME pair => pair @@ -558,10 +552,12 @@ fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty) end +val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] + val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) * ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref [] -fun invalidations (nQueryArgs, query, dml) = +fun invalidations ((query, numArgs), dml) = let val loc = ErrorMsg.dummySpan val optionAtomExpToExp = @@ -578,9 +574,10 @@ let fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) in - inv (nQueryArgs - 1) + inv (numArgs - 1) end - (* *) + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = fn ([], []) => true | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys) @@ -601,39 +598,67 @@ (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss end -val gunk : Mono.exp list list list ref = ref [] -fun addFlushing (file, queryInfo as (tableToIndices, indexToQuery)) = +(* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) + +fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) = let - val allIndices = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices - val flushes = map (fn i => ffiAppCache' ("flush", i, [])) + (* TODO: write this. *) + val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) + val flushes = List.concat o + map (fn (i, argss) => + map (fn args => + ffiAppCache' ("flush", i, + map (fn arg => (arg, stringTyp)) args)) argss) val doExp = - fn dmlExp as EDml (dmlText, _) => + fn EDml (origDmlText, failureMode) => let - val indices = + val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText + val dmlText = incRels numArgs newDmlText + val dmlExp = EDml (dmlText, failureMode) + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) + val invs = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - map (fn i => ((case IM.find (indexToQuery, i) of - NONE => () - | SOME (queryParsed, numArgs) => - gunk := invalidations (numArgs, queryParsed, dmlParsed) :: !gunk); - i)) (SIMM.findList (tableToIndices, tableDml dmlParsed)) - | NONE => allIndices + map (fn i => (case IM.find (indexToQueryNumArgs, i) of + SOME queryNumArgs => + (i, invalidations (queryNumArgs, dmlParsed)) + (* TODO: fail more gracefully. *) + | NONE => raise Match)) + (SIMM.findList (tableToIndices, tableDml dmlParsed)) + (* TODO: fail more gracefully. *) + | NONE => raise Match in - sequence (flushes indices @ [dmlExp]) + wrapLets (sequence (flushes invs @ [dmlExp])) end | e' => e' in fileMap doExp file end +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + fun go file = let val () = Sql.sqlcacheMode := true - val file' = addFlushing (addChecking file) + val file' = addFlushing (addChecking (inlineSql file)) val () = Sql.sqlcacheMode := false in - file' + file' end end
--- a/src/urweb.lex Mon Nov 24 20:47:38 2014 -0500 +++ b/src/urweb.lex Sat Nov 29 03:37:59 2014 -0500 @@ -18,7 +18,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -50,7 +50,7 @@ else (); commentLevel := !commentLevel + 1) - + fun exitComment () = (ignore (commentLevel := !commentLevel - 1); if !commentLevel = 0 then @@ -58,15 +58,15 @@ else ()) - fun eof () = - let + fun eof () = + let val pos = ErrorMsg.lastLineStart () in if !commentLevel > 0 then ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" else (); - Tokens.EOF (pos, pos) + Tokens.EOF (pos, pos) end end @@ -177,7 +177,7 @@ %s COMMENT STRING CHAR XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; -xmlid = [A-Za-z][A-Za-z0-9-_]*; +xmlid = [A-Za-z][A-Za-z0-9_-]*; cid = [A-Z][A-Za-z0-9_]*; ws = [\ \t\012\r]; intconst = [0-9]+; @@ -300,7 +300,7 @@ Tokens.XML_END (yypos, yypos + size yytext)) else Tokens.END_TAG (id, yypos, yypos + size yytext) - | _ => + | _ => Tokens.END_TAG (id, yypos, yypos + size yytext) end);