From dc5e7102563b9c0714391f86b6dcf852445ee192 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 10 Nov 2014 22:04:40 -0500 Subject: Progress towards invalidation based on equalities of fields. --- src/iflow.sml | 116 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 58 insertions(+), 58 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 40cf8993..f68d8f72 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -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 @@ -115,36 +115,36 @@ fun p_reln r es = | PCon1 s => box [string (s ^ "("), p_list p_exp es, string ")"] - | Eq => p_bop "=" es - | Ne => p_bop "<>" es - | Lt => p_bop "<" es - | Le => p_bop "<=" es - | Gt => p_bop ">" es - | Ge => p_bop ">=" es + | Cmp Eq => p_bop "=" es + | Cmp Ne => p_bop "<>" es + | Cmp Lt => p_bop "<" es + | Cmp Le => p_bop "<=" es + | Cmp Gt => p_bop ">" es + | Cmp Ge => p_bop ">=" es fun p_prop p = case p of True => string "True" | False => string "False" | Unknown => string "??" - | And (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "&&", - space, - string "(", - p_prop p2, - string ")"] - | Or (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "||", - space, - string "(", - p_prop p2, - string ")"] + | Lop (And, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Lop (Or, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] | Reln (r, es) => p_reln r es | Cond (e, p) => box [string "(", p_exp e, @@ -518,7 +518,7 @@ fun representative (db : database, e) = Variety = Nothing, Known = ref (!(#Known (unNode r))), Ge = ref NONE}) - + val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), @@ -529,7 +529,7 @@ fun representative (db : database, e) = #Rep (unNode r) := SOME r''; r' end - | _ => raise Contradiction + | _ => raise Contradiction end in rep e @@ -687,9 +687,9 @@ fun assert (db, a) = end | _ => raise Contradiction end - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -734,14 +734,14 @@ fun check (db, a) = (case #Variety (unNode (representative (db, e))) of Dt1 (f', _) => f' = f | _ => false) - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) in repOf r1 = repOf r2 end - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -848,7 +848,7 @@ fun setHyps (n', hs) = (hyps := (n', hs, ref false); Cc.clear db; app (fn a => Cc.assert (db, a)) hs) - end + end fun useKeys () = let @@ -872,7 +872,7 @@ fun useKeys () = let val r = Cc.check (db, - AReln (Eq, [Proj (r1, f), + AReln (Cmp Eq, [Proj (r1, f), Proj (r2, f)])) in (*Print.prefaces "Fs" @@ -888,7 +888,7 @@ fun useKeys () = r end)) ks then (changed := true; - Cc.assert (db, AReln (Eq, [r1, r2])); + Cc.assert (db, AReln (Cmp Eq, [r1, r2])); finder (hyps, acc)) else finder (hyps, a :: acc) @@ -1115,7 +1115,7 @@ fun havocCookie cname = val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) end fun check a = Cc.check (db, a) @@ -1138,7 +1138,7 @@ fun removeDups (ls : (string * string) list) = val ls = removeDups ls in if List.exists (fn x' => x' = x) ls then - ls + ls else x :: ls end @@ -1171,7 +1171,7 @@ fun expIn rv env rvOf = | Null => inl (Func (DtCon0 "None", [])) | SqNot e => inr (case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) | inr _ => Unknown) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () @@ -1181,15 +1181,15 @@ fun expIn rv env rvOf = val e2 = expIn e2 in inr (case (bo, e1, e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, v1, v2) => + (RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2]) + | (RLop l, v1, v2) => let fun pin v = case v of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p in - f (pin v1, pin v2) + Lop (l, pin v1, pin v2) end | _ => Unknown) end @@ -1205,7 +1205,7 @@ fun expIn rv env rvOf = (case expIn e of inl e => inl (Func (Other f, [e])) | _ => default ()) - + | Unmodeled => inl (Func (Other "allow", [rv ()])) end in @@ -1219,8 +1219,8 @@ fun decomp {Save = save, Restore = restore, Add = add} = True => (k () handle Cc.Contradiction => ()) | False => () | Unknown => () - | And (p1, p2) => go p1 (fn () => go p2 k) - | Or (p1, p2) => + | Lop (And, p1, p2) => go p1 (fn () => go p2 k) + | Lop (Or, p1, p2) => let val saved = save () in @@ -1351,7 +1351,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = | SOME e => let val p = case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p val saved = #Save arg () @@ -1365,9 +1365,9 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun normal () = doWhere normal' in (case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + [SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo of + Gt => (case #Cont arg of SomeCol _ => () | AllCols k => @@ -1469,7 +1469,7 @@ fun evalExp env (e as (_, loc)) k = evalExp env e (fn e => doArgs (es, e :: acc)) in doArgs (es, []) - end + end in case #1 e of EPrim p => k (Const p) @@ -1519,7 +1519,7 @@ fun evalExp env (e as (_, loc)) k = ([], []) => (evalExp env' (#body rf) (fn _ => ()); St.reinstate saved; default ()) - + | (arg :: args, mode :: modes) => evalExp env arg (fn arg => let @@ -1663,7 +1663,7 @@ fun evalExp env (e as (_, loc)) k = Save = St.stash, Restore = St.reinstate, Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; + (St.assert [AReln (Cmp Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q end) | EDml (e, _) => @@ -1697,15 +1697,15 @@ fun evalExp env (e as (_, loc)) k = | Delete (tab, e) => let val old = St.nextVar () - + val expIn = expIn (Var o St.nextVar) env (fn "T" => Var old | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" | inr p => p - + val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), @@ -1748,7 +1748,7 @@ fun evalExp env (e as (_, loc)) k = (f, Proj (Var old, f)) :: fs) fs fs' val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" | inr p => p val saved = St.stash () in @@ -1764,7 +1764,7 @@ fun evalExp env (e as (_, loc)) k = k (Recd [])) handle Cc.Contradiction => ()) end) - + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () @@ -1780,7 +1780,7 @@ fun evalExp env (e as (_, loc)) k = val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) in - St.assert [AReln (Known, [e]), AReln (Eq, [e, e'])]; + St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])]; k e end @@ -2159,7 +2159,7 @@ fun check (file : file) = end | _ => ()) end - + | _ => () in app decl (#1 file) -- cgit v1.2.3 From 476f12674420391e24afd1846e176eabe550d36c Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 29 Nov 2014 03:37:59 -0500 Subject: Basic field-resolution invalidation. --- caching-tests/test.db | Bin 5120 -> 0 bytes caching-tests/test.sql | 16 ---- caching-tests/test.ur | 66 ++++++++-------- caching-tests/test.urs | 8 +- src/cjr_print.sml | 28 +++++-- src/cjrize.sml | 10 +-- src/iflow.sml | 10 ++- src/jscomp.sml | 19 ++--- src/mono.sml | 7 +- src/mono_opt.sml | 25 +++--- src/mono_print.sml | 8 +- src/mono_util.sml | 23 +++--- src/monoize.sig | 2 + src/monoize.sml | 38 +++++---- src/sqlcache.sml | 211 +++++++++++++++++++++++++++---------------------- src/urweb.lex | 14 ++-- 16 files changed, 266 insertions(+), 219 deletions(-) delete mode 100644 caching-tests/test.db delete mode 100644 caching-tests/test.sql (limited to 'src/iflow.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db deleted file mode 100644 index a4661341..00000000 Binary files a/caching-tests/test.db and /dev/null differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql deleted file mode 100644 index 7ade7278..00000000 --- a/caching-tests/test.sql +++ /dev/null @@ -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 diff --git a/caching-tests/test.ur b/caching-tests/test.ur index 931612bc..2722bcdc 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -11,26 +11,26 @@ fun cache01 () = | Some row => {[row.Foo01.Bar]}} -fun cache10 () = - res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) - (fn row => {[row.Foo10.Bar]}); - return - Reading 2. - {res} - +(* fun cache10 () = *) +(* res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) *) +(* (fn row => {[row.Foo10.Bar]}); *) +(* return *) +(* Reading 2. *) +(* {res} *) +(* *) -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 - Reading 1 and 2. - {case res of - None => ? - | Some row => {[row.Foo01.Bar]}} - {case bla of - None => ? - | Some row => {[row.Foo10.Bar]}} - +(* 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 *) +(* Reading 1 and 2. *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Foo01.Bar]}} *) +(* {case bla of *) +(* None => ? *) +(* | Some row => {[row.Foo10.Bar]}} *) +(* *) fun flush01 () = dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); @@ -39,18 +39,18 @@ fun flush01 () = Flushed 1! -fun flush10 () = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return - Flushed 2! - +(* fun flush10 () = *) +(* dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); *) +(* return *) +(* Flushed 2! *) +(* *) -fun flush11 () = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return - Flushed 1 and 2! - +(* fun flush11 () = *) +(* dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); *) +(* dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); *) +(* return *) +(* Flushed 1 and 2! *) +(* *) fun cache id = res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); @@ -63,9 +63,9 @@ fun cache id = 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 (* Flushed {[id]}! *) {case res of diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ace4ba28..30bff733 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -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 diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 56310b81..81dfefaa 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3410,14 +3410,22 @@ fun p_file env (ds, ps) = 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 @@ fun p_file env (ds, ps) = 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) diff --git a/src/cjrize.sml b/src/cjrize.sml index 11174162..b20d6d22 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -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 @@ fun cifyExp (eAll as (e, loc), sm) = | 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 @@ fun cifyDecl ((d, loc), sm) = 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 @@ fun cifyDecl ((d, loc), sm) = (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 @@ fun cifyDecl ((d, loc), sm) = sm vis in (SOME (L'.DFunRec vis, loc), NONE, sm) - end + end | L.DExport (ek, s, n, ts, t, b) => let diff --git a/src/iflow.sml b/src/iflow.sml index f68d8f72..b8346baa 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1870,14 +1870,15 @@ val namer = MonoUtil.File.map {typ = fn t => t, 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 @@ fun check (file : file) = | 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 => () diff --git a/src/jscomp.sml b/src/jscomp.sml index 1a476739..a4ee95f0 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -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 @@ fun process (file : file) = 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 @@ fun process (file : file) = 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 @@ fun process (file : file) = | _ => default () in seek (e', [x]) - end + end | ECase (e', pes, _) => let @@ -1030,7 +1030,7 @@ fun process (file : file) = | 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 @@ fun process (file : file) = 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 @@ fun process (file : file) = ((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 @@ fun process (file : file) = 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 @@ fun process (file : file) = in ((ESignalSource e, loc), st) end - + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st) diff --git a/src/mono.sml b/src/mono.sml index 1e402e57..5185e48c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -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 @@ datatype exp' = 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 @@ datatype exp' = | ESignalReturn of exp | ESignalBind of exp * exp | ESignalSource of exp - + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index d1e5ce55..97f78d3d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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 @@ fun exp e = 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) diff --git a/src/mono_print.sml b/src/mono_print.sml index c81b362a..0ff51f37 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -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 @@ fun p_exp' par env (e, _) = 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 @@ fun p_vali env (x, n, t, e, s) = string "__", string (Int.toString n)] else - string x + string x in box [xp, space, @@ -541,7 +541,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_policy env p] | DOnError _ => string "ONERROR" - + fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => diff --git a/src/mono_util.sml b/src/mono_util.sml index fd80c64f..ba10ad32 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -314,7 +314,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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, diff --git a/src/monoize.sig b/src/monoize.sig index 951db01b..549bf6ee 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -31,4 +31,6 @@ signature MONOIZE = sig val liftExpInExp : int -> Mono.exp -> Mono.exp + val urlifiedUnit : Mono.exp + end diff --git a/src/monoize.sml b/src/monoize.sml index 2d225813..5c314c54 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -681,6 +681,16 @@ fun fooifyExp fk env = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index d8169926..b555ca7a 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -176,12 +176,10 @@ fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) = 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 @@ val compare = 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 @@ structure UF = UnionFindFn(AtomExpKey) (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 @@ fun valsToFormula (table, vals) = 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 fileMapfold doExp file start = 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 @@ fun addChecking file = 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 @@ fun addChecking file = 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 @@ fun invalidations (nQueryArgs, query, dml) = 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 @@ fun invalidations (nQueryArgs, query, dml) = (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 diff --git a/src/urweb.lex b/src/urweb.lex index 0d316ed2..785f7a81 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -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 @@ in else (); commentLevel := !commentLevel + 1) - + fun exitComment () = (ignore (commentLevel := !commentLevel - 1); if !commentLevel = 0 then @@ -58,15 +58,15 @@ in 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 @@ fun unescape loc s = %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 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; 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); -- cgit v1.2.3 From 68879bbb4bf58e4709c96ba6904071ce5d24a906 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 13 Sep 2015 17:02:17 -0400 Subject: Make Mono.file a record for readability upon extension. --- src/cjrize.sml | 2 +- src/dbmodecheck.sml | 7 +++---- src/fuse.sml | 8 ++++---- src/iflow.sml | 4 ++-- src/jscomp.sml | 6 +++--- src/mono.sml | 2 +- src/mono_print.sml | 4 ++-- src/mono_reduce.sml | 8 ++++---- src/mono_shake.sml | 11 ++++++----- src/mono_util.sml | 16 ++++++++-------- src/monoize.sml | 2 +- src/name_js.sml | 12 ++++++------ src/pathcheck.sml | 6 +++--- src/scriptcheck.sml | 9 ++++----- src/sigcheck.sml | 8 ++++---- src/sqlcache.sml | 2 +- src/untangle.sml | 4 ++-- 17 files changed, 55 insertions(+), 56 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index b20d6d22..870c66be 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -701,7 +701,7 @@ fun cifyDecl ((d, loc), sm) = | L.DPolicy _ => (NONE, NONE, sm) | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) -fun cjrize (ds, sideInfo) = +fun cjrize {decls = ds, sideInfo} = let val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml index eb416cea..491927c0 100644 --- a/src/dbmodecheck.sml +++ b/src/dbmodecheck.sml @@ -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 @@ -31,7 +31,7 @@ open Mono structure IM = IntBinaryMap -fun classify (ds, ps) = +fun classify {decls = ds, sideInfo = ps} = let fun mergeModes (m1, m2) = case (m1, m2) of @@ -79,8 +79,7 @@ fun classify (ds, ps) = val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes in - (ds, ps) + {decls = ds, sideInfo = ps} end end - diff --git a/src/fuse.sml b/src/fuse.sml index 5193e59a..017f79d5 100644 --- a/src/fuse.sml +++ b/src/fuse.sml @@ -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 @@ -139,14 +139,14 @@ fun fuse file = in (U.Decl.map {typ = fn x => x, exp = exp, - decl = fn x => x} + decl = fn x => x} d, (funcs, maxName)) end - val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file) + val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#decls file) in - (ds, #2 file) + {decls = ds, sideInfo = #sideInfo file} end end diff --git a/src/iflow.sml b/src/iflow.sml index b8346baa..6ed7e69d 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1900,7 +1900,7 @@ fun check (file : file) = val exptd = foldl (fn ((d, _), exptd) => case d of DExport (_, _, n, _, _, _) => IS.add (exptd, n) - | _ => exptd) IS.empty (#1 file) + | _ => exptd) IS.empty (#decls file) fun decl (d, loc) = case d of @@ -2164,7 +2164,7 @@ fun check (file : file) = | _ => () in - app decl (#1 file) + app decl (#decls file) end val check = fn file => diff --git a/src/jscomp.sml b/src/jscomp.sml index e5f7d234..29b11820 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -79,7 +79,7 @@ fun process (file : file) = someTs) someTs dts, nameds) | (_, state) => state) - (IM.empty, IM.empty) (#1 file) + (IM.empty, IM.empty) (#decls file) fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) @@ -1335,7 +1335,7 @@ fun process (file : file) = listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - (#1 file) + (#decls file) val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) fun lines acc = @@ -1365,7 +1365,7 @@ fun process (file : file) = "" in TextIO.closeIn inf; - ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) + {decls = (DJavaScript script, ErrorMsg.dummySpan) :: ds, sideInfo = #sideInfo file} end end diff --git a/src/mono.sml b/src/mono.sml index 5185e48c..94c47814 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -168,6 +168,6 @@ datatype dbmode = | OneQuery | AnyDb -type file = decl list * (int * sidedness * dbmode) list +type file = {decls : decl list, sideInfo : (int * sidedness * dbmode) list} end diff --git a/src/mono_print.sml b/src/mono_print.sml index 0ff51f37..0b5fdadc 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -542,12 +542,12 @@ fun p_decl env (dAll as (d, _) : decl) = p_policy env p] | DOnError _ => string "ONERROR" -fun p_file env (file, _) = +fun p_file env (file : file) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => (p_decl env d, E.declBinds env d)) - env file + env (#decls file) in p_list_sep newline (fn x => x) pds end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 61866af7..19c07f12 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -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 @@ -390,7 +390,7 @@ fun reduce' (file : file) = absCounts vis) | _ => (timpures, impures, absCounts) end) - (IS.empty, IS.empty, IM.empty) (#1 file) + (IS.empty, IS.empty, IM.empty) (#decls file) val uses = U.File.fold {typ = fn (_, m) => m, exp = fn (e, m) => @@ -406,7 +406,7 @@ fun reduce' (file : file) = val functionInside' = U.Typ.exists (fn c => case c of TFun _ => true | _ => false) - + fun functionInside t = case #1 t of TFun (t1, t2) => functionInside' t1 orelse functionInside t2 @@ -520,7 +520,7 @@ fun reduce' (file : file) = | ERedirect (e, _) => summarize d e @ [Abort] | EWrite e => summarize d e @ [WritePage] - + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2 diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 5818fea0..b394af5b 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -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 @@ -60,7 +60,7 @@ fun shake (file : file) = | ((DTask _, _), acc) => acc | ((DPolicy _, _), acc) => acc | ((DOnError _, _), acc) => acc) - (IM.empty, IM.empty) (#1 file) + (IM.empty, IM.empty) (#decls file) fun typ (c, s) = case c of @@ -130,7 +130,7 @@ fun shake (file : file) = usedVars st e1 end | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) - | (_, st) => st) (IS.empty, IS.empty) (#1 file) + | (_, st) => st) (IS.empty, IS.empty) (#decls file) val s = {con = page_cs, exp = page_es} @@ -145,7 +145,8 @@ fun shake (file : file) = NONE => raise Fail "MonoShake: Couldn't find 'val'" | SOME (t, e) => shakeExp s e) s page_es in - (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts + {decls = + List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true @@ -158,7 +159,7 @@ fun shake (file : file) = | (DStyle _, _) => true | (DTask _, _) => true | (DPolicy _, _) => true - | (DOnError _, _) => true) (#1 file), #2 file) + | (DOnError _, _) => true) (#decls file), sideInfo = #sideInfo file} end end diff --git a/src/mono_util.sml b/src/mono_util.sml index ba10ad32..64aeb318 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -695,9 +695,9 @@ fun mapfoldB (all as {bind, ...}) = let val mfd = Decl.mapfoldB all - fun mff ctx (ds, ps) = - case ds of - nil => S.return2 (nil, ps) + fun mff ctx (file : file) = + case #decls file of + nil => S.return2 {decls = nil, sideInfo = #sideInfo file} | d :: ds' => S.bind2 (mfd ctx d, fn d' => @@ -736,9 +736,9 @@ fun mapfoldB (all as {bind, ...}) = | DPolicy _ => ctx | DOnError _ => ctx in - S.map2 (mff ctx' (ds', ps), - fn (ds', _) => - (d' :: ds', ps)) + S.map2 (mff ctx' {decls = ds', sideInfo = #sideInfo file}, + fn {decls = ds', ...} => + {decls = d' :: ds', sideInfo = #sideInfo file}) end) in mff @@ -791,7 +791,7 @@ fun maxName (f : file) = | DStyle _ => count | DTask _ => count | DPolicy _ => count - | DOnError _ => count) 0 (#1 f) + | DOnError _ => count) 0 (#decls f) fun appLoc f (fl : file) = let @@ -822,7 +822,7 @@ fun appLoc f (fl : file) = | PolUpdate e1 => eal e1 | PolSequence e1 => eal e1 in - app appl (#1 fl) + app appl (#decls fl) end end diff --git a/src/monoize.sml b/src/monoize.sml index d8c4d276..d0b93c50 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4786,7 +4786,7 @@ fun monoize env file = pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - (rev ds, []) + {decls = rev ds, sideInfo = []} end end diff --git a/src/name_js.sml b/src/name_js.sml index f10e5938..b838d1d3 100644 --- a/src/name_js.sml +++ b/src/name_js.sml @@ -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 @@ -92,7 +92,7 @@ fun rewrite file = | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis | _ => dontName else - dontName) IS.empty (#1 file) + dontName) IS.empty (#decls file) val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => let @@ -126,9 +126,9 @@ fun rewrite file = val vs = freeVars e' val vs = IS.listItems vs - + val x = "script" ^ Int.toString nextName - + val un = (TRecord [], loc) val s = (TFfi ("Basis", "string"), loc) val base = (TFun (un, s), loc) @@ -165,9 +165,9 @@ fun rewrite file = DValRec vis => [(DValRec (vis @ newDs), #2 d)] | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), nextName) - end) (U.File.maxName file + 1) (#1 file) + end) (U.File.maxName file + 1) (#decls file) in - (ds, #2 file) + {decls = ds, sideInfo = #sideInfo file} end end diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 3533032e..2de3b544 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -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 @@ -68,7 +68,7 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = in case d of DExport (_, s, _, _, _, _) => doFunc s - + | DTable (s, _, pe, ce) => let fun constraints (e, rels) = @@ -110,6 +110,6 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = | _ => (funcs, rels, cookies, styles) end -fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) +fun check (file : file) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) (#decls file)) end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 0d30ebcb..d1e893dd 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -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 @@ -91,7 +91,7 @@ fun dump (r : rpcmap) = dump r')) m; print "\n") -fun classify (ds, ps) = +fun classify {decls = ds, sideInfo = ps} = let val proto = Settings.currentProtocol () @@ -100,7 +100,7 @@ fun classify (ds, ps) = fun hasClient {basis, rpcs, funcs, push} = MonoUtil.Exp.exists {typ = fn _ => false, exp = fn ERecv _ => push - | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | EFfiApp ("Basis", x, _) => SS.member (basis, x) | EJavaScript _ => not push | ENamed n => IS.member (funcs, n) | EServerCall (e, _, _, _) => @@ -175,8 +175,7 @@ fun classify (ds, ps) = else ServerOnly, AnyDb)) (IS.listItems all_ids) in - (ds, ps) + {decls = ds, sideInfo = ps} end end - diff --git a/src/sigcheck.sml b/src/sigcheck.sml index a6ed7653..35302bae 100644 --- a/src/sigcheck.sml +++ b/src/sigcheck.sml @@ -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 @@ -32,7 +32,7 @@ open Mono structure IS = IntBinarySet structure E = ErrorMsg -fun check (ds, sl) = +fun check (file : file) = let fun isSiggy siggers = MonoUtil.Decl.exists {typ = fn _ => false, @@ -89,9 +89,9 @@ fun check (ds, sl) = (sigify sigdecs d, (siggers, sigdecs)) | _ => (sigify sigdecs d, (siggers, sigdecs)) - val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) ds + val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) (#decls file) in - (ds, sl) + {decls = ds, sideInfo = #sideInfo file} end end diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 8efe999c..40081351 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -101,7 +101,7 @@ fun effectful (effs : IS.set) = end (* TODO: test this. *) -fun effectfulDecls (decls, _) = +fun effectfulDecls ({decls, ...} : file) = let fun doVal ((_, name, _, e, _), effs) = if effectful effs MonoEnv.empty e diff --git a/src/untangle.sml b/src/untangle.sml index bcb90ed6..8ed9c8f6 100644 --- a/src/untangle.sml +++ b/src/untangle.sml @@ -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 @@ -208,7 +208,7 @@ fun untangle (file : file) = end | _ => [dAll] in - (ListUtil.mapConcat decl (#1 file), #2 file) + {decls = ListUtil.mapConcat decl (#decls file), sideInfo = #sideInfo file} end end -- cgit v1.2.3 From 3e42cccfaef1157ca14cd102959b867c996503a9 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 21 Sep 2015 10:16:55 -0400 Subject: Revert to revision 2222. --- src/cjrize.sml | 2 +- src/dbmodecheck.sml | 7 ++++--- src/fuse.sml | 8 ++++---- src/iflow.sml | 4 ++-- src/jscomp.sml | 6 +++--- src/mono.sml | 2 +- src/mono_print.sml | 4 ++-- src/mono_reduce.sml | 8 ++++---- src/mono_shake.sml | 11 +++++------ src/mono_util.sml | 16 ++++++++-------- src/monoize.sml | 2 +- src/name_js.sml | 12 ++++++------ src/pathcheck.sml | 6 +++--- src/scriptcheck.sml | 9 +++++---- src/sigcheck.sml | 8 ++++---- src/sqlcache.sml | 2 +- src/untangle.sml | 4 ++-- 17 files changed, 56 insertions(+), 55 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 870c66be..b20d6d22 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -701,7 +701,7 @@ fun cifyDecl ((d, loc), sm) = | L.DPolicy _ => (NONE, NONE, sm) | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) -fun cjrize {decls = ds, sideInfo} = +fun cjrize (ds, sideInfo) = let val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml index 491927c0..eb416cea 100644 --- a/src/dbmodecheck.sml +++ b/src/dbmodecheck.sml @@ -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 @@ -31,7 +31,7 @@ open Mono structure IM = IntBinaryMap -fun classify {decls = ds, sideInfo = ps} = +fun classify (ds, ps) = let fun mergeModes (m1, m2) = case (m1, m2) of @@ -79,7 +79,8 @@ fun classify {decls = ds, sideInfo = ps} = val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes in - {decls = ds, sideInfo = ps} + (ds, ps) end end + diff --git a/src/fuse.sml b/src/fuse.sml index 017f79d5..5193e59a 100644 --- a/src/fuse.sml +++ b/src/fuse.sml @@ -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 @@ -139,14 +139,14 @@ fun fuse file = in (U.Decl.map {typ = fn x => x, exp = exp, - decl = fn x => x} + decl = fn x => x} d, (funcs, maxName)) end - val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#decls file) + val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file) in - {decls = ds, sideInfo = #sideInfo file} + (ds, #2 file) end end diff --git a/src/iflow.sml b/src/iflow.sml index 6ed7e69d..b8346baa 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1900,7 +1900,7 @@ fun check (file : file) = val exptd = foldl (fn ((d, _), exptd) => case d of DExport (_, _, n, _, _, _) => IS.add (exptd, n) - | _ => exptd) IS.empty (#decls file) + | _ => exptd) IS.empty (#1 file) fun decl (d, loc) = case d of @@ -2164,7 +2164,7 @@ fun check (file : file) = | _ => () in - app decl (#decls file) + app decl (#1 file) end val check = fn file => diff --git a/src/jscomp.sml b/src/jscomp.sml index 29b11820..e5f7d234 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -79,7 +79,7 @@ fun process (file : file) = someTs) someTs dts, nameds) | (_, state) => state) - (IM.empty, IM.empty) (#decls file) + (IM.empty, IM.empty) (#1 file) fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) @@ -1335,7 +1335,7 @@ fun process (file : file) = listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - (#decls file) + (#1 file) val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) fun lines acc = @@ -1365,7 +1365,7 @@ fun process (file : file) = "" in TextIO.closeIn inf; - {decls = (DJavaScript script, ErrorMsg.dummySpan) :: ds, sideInfo = #sideInfo file} + ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) end end diff --git a/src/mono.sml b/src/mono.sml index 94c47814..5185e48c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -168,6 +168,6 @@ datatype dbmode = | OneQuery | AnyDb -type file = {decls : decl list, sideInfo : (int * sidedness * dbmode) list} +type file = decl list * (int * sidedness * dbmode) list end diff --git a/src/mono_print.sml b/src/mono_print.sml index 0b5fdadc..0ff51f37 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -542,12 +542,12 @@ fun p_decl env (dAll as (d, _) : decl) = p_policy env p] | DOnError _ => string "ONERROR" -fun p_file env (file : file) = +fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => (p_decl env d, E.declBinds env d)) - env (#decls file) + env file in p_list_sep newline (fn x => x) pds end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 19c07f12..61866af7 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -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 @@ -390,7 +390,7 @@ fun reduce' (file : file) = absCounts vis) | _ => (timpures, impures, absCounts) end) - (IS.empty, IS.empty, IM.empty) (#decls file) + (IS.empty, IS.empty, IM.empty) (#1 file) val uses = U.File.fold {typ = fn (_, m) => m, exp = fn (e, m) => @@ -406,7 +406,7 @@ fun reduce' (file : file) = val functionInside' = U.Typ.exists (fn c => case c of TFun _ => true | _ => false) - + fun functionInside t = case #1 t of TFun (t1, t2) => functionInside' t1 orelse functionInside t2 @@ -520,7 +520,7 @@ fun reduce' (file : file) = | ERedirect (e, _) => summarize d e @ [Abort] | EWrite e => summarize d e @ [WritePage] - + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2 diff --git a/src/mono_shake.sml b/src/mono_shake.sml index b394af5b..5818fea0 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -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 @@ -60,7 +60,7 @@ fun shake (file : file) = | ((DTask _, _), acc) => acc | ((DPolicy _, _), acc) => acc | ((DOnError _, _), acc) => acc) - (IM.empty, IM.empty) (#decls file) + (IM.empty, IM.empty) (#1 file) fun typ (c, s) = case c of @@ -130,7 +130,7 @@ fun shake (file : file) = usedVars st e1 end | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) - | (_, st) => st) (IS.empty, IS.empty) (#decls file) + | (_, st) => st) (IS.empty, IS.empty) (#1 file) val s = {con = page_cs, exp = page_es} @@ -145,8 +145,7 @@ fun shake (file : file) = NONE => raise Fail "MonoShake: Couldn't find 'val'" | SOME (t, e) => shakeExp s e) s page_es in - {decls = - List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts + (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true @@ -159,7 +158,7 @@ fun shake (file : file) = | (DStyle _, _) => true | (DTask _, _) => true | (DPolicy _, _) => true - | (DOnError _, _) => true) (#decls file), sideInfo = #sideInfo file} + | (DOnError _, _) => true) (#1 file), #2 file) end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 64aeb318..ba10ad32 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -695,9 +695,9 @@ fun mapfoldB (all as {bind, ...}) = let val mfd = Decl.mapfoldB all - fun mff ctx (file : file) = - case #decls file of - nil => S.return2 {decls = nil, sideInfo = #sideInfo file} + fun mff ctx (ds, ps) = + case ds of + nil => S.return2 (nil, ps) | d :: ds' => S.bind2 (mfd ctx d, fn d' => @@ -736,9 +736,9 @@ fun mapfoldB (all as {bind, ...}) = | DPolicy _ => ctx | DOnError _ => ctx in - S.map2 (mff ctx' {decls = ds', sideInfo = #sideInfo file}, - fn {decls = ds', ...} => - {decls = d' :: ds', sideInfo = #sideInfo file}) + S.map2 (mff ctx' (ds', ps), + fn (ds', _) => + (d' :: ds', ps)) end) in mff @@ -791,7 +791,7 @@ fun maxName (f : file) = | DStyle _ => count | DTask _ => count | DPolicy _ => count - | DOnError _ => count) 0 (#decls f) + | DOnError _ => count) 0 (#1 f) fun appLoc f (fl : file) = let @@ -822,7 +822,7 @@ fun appLoc f (fl : file) = | PolUpdate e1 => eal e1 | PolSequence e1 => eal e1 in - app appl (#decls fl) + app appl (#1 fl) end end diff --git a/src/monoize.sml b/src/monoize.sml index d0b93c50..d8c4d276 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4786,7 +4786,7 @@ fun monoize env file = pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - {decls = rev ds, sideInfo = []} + (rev ds, []) end end diff --git a/src/name_js.sml b/src/name_js.sml index b838d1d3..f10e5938 100644 --- a/src/name_js.sml +++ b/src/name_js.sml @@ -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 @@ -92,7 +92,7 @@ fun rewrite file = | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis | _ => dontName else - dontName) IS.empty (#decls file) + dontName) IS.empty (#1 file) val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => let @@ -126,9 +126,9 @@ fun rewrite file = val vs = freeVars e' val vs = IS.listItems vs - + val x = "script" ^ Int.toString nextName - + val un = (TRecord [], loc) val s = (TFfi ("Basis", "string"), loc) val base = (TFun (un, s), loc) @@ -165,9 +165,9 @@ fun rewrite file = DValRec vis => [(DValRec (vis @ newDs), #2 d)] | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), nextName) - end) (U.File.maxName file + 1) (#decls file) + end) (U.File.maxName file + 1) (#1 file) in - {decls = ds, sideInfo = #sideInfo file} + (ds, #2 file) end end diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 2de3b544..3533032e 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -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 @@ -68,7 +68,7 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = in case d of DExport (_, s, _, _, _, _) => doFunc s - + | DTable (s, _, pe, ce) => let fun constraints (e, rels) = @@ -110,6 +110,6 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = | _ => (funcs, rels, cookies, styles) end -fun check (file : file) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) (#decls file)) +fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index d1e893dd..0d30ebcb 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -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 @@ -91,7 +91,7 @@ fun dump (r : rpcmap) = dump r')) m; print "\n") -fun classify {decls = ds, sideInfo = ps} = +fun classify (ds, ps) = let val proto = Settings.currentProtocol () @@ -100,7 +100,7 @@ fun classify {decls = ds, sideInfo = ps} = fun hasClient {basis, rpcs, funcs, push} = MonoUtil.Exp.exists {typ = fn _ => false, exp = fn ERecv _ => push - | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | EFfiApp ("Basis", x, _) => SS.member (basis, x) | EJavaScript _ => not push | ENamed n => IS.member (funcs, n) | EServerCall (e, _, _, _) => @@ -175,7 +175,8 @@ fun classify {decls = ds, sideInfo = ps} = else ServerOnly, AnyDb)) (IS.listItems all_ids) in - {decls = ds, sideInfo = ps} + (ds, ps) end end + diff --git a/src/sigcheck.sml b/src/sigcheck.sml index 35302bae..a6ed7653 100644 --- a/src/sigcheck.sml +++ b/src/sigcheck.sml @@ -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 @@ -32,7 +32,7 @@ open Mono structure IS = IntBinarySet structure E = ErrorMsg -fun check (file : file) = +fun check (ds, sl) = let fun isSiggy siggers = MonoUtil.Decl.exists {typ = fn _ => false, @@ -89,9 +89,9 @@ fun check (file : file) = (sigify sigdecs d, (siggers, sigdecs)) | _ => (sigify sigdecs d, (siggers, sigdecs)) - val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) (#decls file) + val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) ds in - {decls = ds, sideInfo = #sideInfo file} + (ds, sl) end end diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 40081351..8efe999c 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -101,7 +101,7 @@ fun effectful (effs : IS.set) = end (* TODO: test this. *) -fun effectfulDecls ({decls, ...} : file) = +fun effectfulDecls (decls, _) = let fun doVal ((_, name, _, e, _), effs) = if effectful effs MonoEnv.empty e diff --git a/src/untangle.sml b/src/untangle.sml index 8ed9c8f6..bcb90ed6 100644 --- a/src/untangle.sml +++ b/src/untangle.sml @@ -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 @@ -208,7 +208,7 @@ fun untangle (file : file) = end | _ => [dAll] in - {decls = ListUtil.mapConcat decl (#decls file), sideInfo = #sideInfo file} + (ListUtil.mapConcat decl (#1 file), #2 file) end end -- cgit v1.2.3 From 97115c5f804824c024a0c08c288889d29f743e64 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 21 Sep 2015 16:45:59 -0400 Subject: Use new refactored urlification in Sqlcache. --- src/cjrize.sml | 2 +- src/iflow.sml | 10 ++++------ src/jscomp.sml | 5 ++--- src/mono.sml | 3 +-- src/mono_opt.sml | 11 ++++------- src/mono_print.sml | 2 +- src/mono_util.sml | 22 +++++++++------------- src/monoize.sig | 2 -- src/monoize.sml | 14 +------------- src/sqlcache.sml | 11 ++++------- 10 files changed, 27 insertions(+), 55 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index b20d6d22..5f6ae4d8 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -431,7 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; (dummye, sm)) - | L.EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => + | L.EQuery {exps, tables, state, query, body, initial} => let val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => let diff --git a/src/iflow.sml b/src/iflow.sml index b8346baa..f68d8f72 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1870,15 +1870,14 @@ val namer = MonoUtil.File.map {typ = fn t => t, case e of EDml (e, fm) => nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e - | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => + | EQuery {exps, tables, state, query, body, initial} => nameSubexps (fn (liftBy, e') => (EQuery {exps = exps, tables = tables, state = state, query = e', body = mliftExpInExp liftBy 2 body, - initial = mliftExpInExp liftBy 0 initial, - sqlcacheInfo = sqlcacheInfo}, + initial = mliftExpInExp liftBy 0 initial}, #2 query)) query | _ => e, decl = fn d => d} @@ -2071,12 +2070,11 @@ fun check (file : file) = | 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, sqlcacheInfo} => + | EQuery {exps, tables, state, query, body, initial} => (EQuery {exps = exps, tables = tables, state = state, query = doExp env query, body = doExp (Unknown :: Unknown :: env) body, - initial = doExp env initial, - sqlcacheInfo = sqlcacheInfo}, loc) + initial = doExp env initial}, loc) | EDml (e1, mode) => (case parse dml e1 of NONE => () diff --git a/src/jscomp.sml b/src/jscomp.sml index e5f7d234..4c6bf0a9 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -1178,7 +1178,7 @@ fun process (file : file) = ((EClosure (n, es), loc), st) end - | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => + | EQuery {exps, tables, state, query, body, initial} => 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 @@ -1189,8 +1189,7 @@ fun process (file : file) = val (initial, st) = exp outer (initial, st) in ((EQuery {exps = exps, tables = tables, state = state, - query = query, body = body, initial = initial, - sqlcacheInfo = sqlcacheInfo}, loc), st) + query = query, body = body, initial = initial}, loc), st) end | EDml (e, mode) => let diff --git a/src/mono.sml b/src/mono.sml index 5185e48c..b05c3dcc 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -107,8 +107,7 @@ datatype exp' = state : typ, query : exp, (* exp of string type containing sql query *) body : exp, - initial : exp, - sqlcacheInfo : exp } + initial : exp } | EDml of exp * failure_mode | ENextval of exp | ESetval of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index f4cd6895..186f6c62 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -405,20 +405,18 @@ fun exp e = initial = (EPrim (Prim.String (k, "")), _), body = (EStrcat ((EPrim (Prim.String (_, s)), _), (EStrcat ((ERel 0, _), - e'), _)), _), - sqlcacheInfo}, loc) => + e'), _)), _)}, 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), - sqlcacheInfo = Monoize.urlifiedUnit} + body = (optExp (EWrite e', loc), loc)} else e | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String (_, "")), _), - body, sqlcacheInfo}, loc) => + body}, loc) => let fun passLets (depth, (e', _), lets) = case e' of @@ -433,8 +431,7 @@ fun exp e = EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = body, - sqlcacheInfo = Monoize.urlifiedUnit} + body = body} end else e diff --git a/src/mono_print.sml b/src/mono_print.sml index 0ff51f37..3e498d2c 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -310,7 +310,7 @@ fun p_exp' par env (e, _) = p_exp env e]) es, string ")"] - | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => + | EQuery {exps, tables, state, query, body, initial} => box [string "query[", p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, string "] [", diff --git a/src/mono_util.sml b/src/mono_util.sml index ba10ad32..5d7eb164 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -314,7 +314,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fn es' => (EClosure (n, es'), loc)) - | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => + | EQuery {exps, tables, state, query, body, initial} => S.bind2 (ListUtil.mapfold (fn (x, t) => S.map2 (mft t, fn t' => (x, t'))) exps, @@ -335,19 +335,15 @@ fun mapfoldB {typ = fc, exp = fe, bind} = body, fn body' => (* ASK: is this the right thing to do? *) - S.bind2 (mfe ctx initial, + S.map2 (mfe ctx initial, fn initial' => - 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)))))))) + (EQuery {exps = exps', + tables = tables', + state = state', + query = query', + body = body', + initial = initial'}, + loc))))))) | EDml (e, fm) => S.map2 (mfe ctx e, diff --git a/src/monoize.sig b/src/monoize.sig index 549bf6ee..951db01b 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -31,6 +31,4 @@ signature MONOIZE = sig val liftExpInExp : int -> Mono.exp -> Mono.exp - val urlifiedUnit : Mono.exp - end diff --git a/src/monoize.sml b/src/monoize.sml index f92d7511..8f6b298d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -395,16 +395,6 @@ fun fooifyExp fk env = val attrifyExp = fooifyExp MonoFooify.Attr val urlifyExp = fooifyExp MonoFooify.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 @@ -1687,14 +1677,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - 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}, + initial = (L'.ERel 1, loc)}, loc) in ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 8efe999c..6b4216ea 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -493,16 +493,16 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = +fun cacheWrap (env, query, i, resultTyp, args) = let val () = ffiInfo := {index = i, params = length args} :: !ffiInfo val loc = dummyLoc + val rel0 = (ERel 0, loc) (* We ensure before this step that all arguments aren't effectful. by turning them into local variables as needed. *) val argsInc = map (incRels 1) args val check = (check (i, args), dummyLoc) - val store = (store (i, argsInc, urlifiedRel0), dummyLoc) - val rel0 = (ERel 0, loc) + val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc) in ECase (check, [((PNone stringTyp, loc), @@ -563,8 +563,6 @@ fun addChecking file = let fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = fn e' as EQuery {query = origQueryText, - (* ASK: could this get messed up by inlining? *) - sqlcacheInfo = urlifiedRel0, state = resultTyp, initial, body, tables, exps} => let @@ -572,7 +570,6 @@ fun addChecking file = (* Increment once for each new variable just made. *) val queryExp = incRels numArgs (EQuery {query = newQueryText, - sqlcacheInfo = urlifiedRel0, state = resultTyp, initial = initial, body = body, @@ -599,7 +596,7 @@ fun addChecking file = (* Ziv misses Haskell's do notation.... *) guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( bind (Sql.parse Sql.query queryText) (fn queryParsed => - SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), + SOME (wrapLets (cacheWrap (env, queryExp, index, resultTyp, args)), (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), -- cgit v1.2.3