From 93d6de491838eb3607a12686bfdc250366aa60e4 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 25 Mar 2014 02:04:06 -0400 Subject: ML half of initial prototype. (Doesn't compile because there's no C yet.) --- caching-tests/test.urs | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 caching-tests/test.urs (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.urs b/caching-tests/test.urs new file mode 100644 index 00000000..ce7d0350 --- /dev/null +++ b/caching-tests/test.urs @@ -0,0 +1,6 @@ +val cache01 : 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 -- cgit v1.2.3 From 75d1eedd15edc41b1c2bc9d1fce7a74f37bd78a1 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 14 Oct 2014 18:05:09 -0400 Subject: Complete overhaul: cache queries based on immediate query result, not eventual HTML output. --- caching-tests/test.db | Bin 3072 -> 5120 bytes caching-tests/test.sql | 7 +- caching-tests/test.ur | 74 +++++++++----- caching-tests/test.urp | 1 + caching-tests/test.urs | 2 + src/cjr_print.sml | 70 +++++++++---- src/compiler.sig | 1 - src/compiler.sml | 6 +- src/monoize.sig | 2 +- src/monoize.sml | 24 +++-- src/multimap_fn.sml | 10 +- src/settings.sig | 3 + src/settings.sml | 4 + src/sources | 2 + src/sql.sig | 2 + src/sql.sml | 20 +++- src/sqlcache.sml | 266 +++++++++++++++++++++++++++++++++++++++++++++---- 17 files changed, 411 insertions(+), 83 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.db b/caching-tests/test.db index a5c91e8f..944aa851 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql index 862245b7..efa271ec 100644 --- a/caching-tests/test.sql +++ b/caching-tests/test.sql @@ -8,4 +8,9 @@ CREATE TABLE uw_Test_foo01(uw_id integer NOT NULL, uw_bar text NOT NULL, ); - \ No newline at end of file + CREATE TABLE uw_Test_tab(uw_id integer NOT NULL, uw_val integer 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 a99a387b..cb391da7 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,52 +1,74 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id +table tab : {Id : int, Val : int} PRIMARY KEY Id -fun flush01 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); - return - Flushed 1! - - -fun flush10 () : transaction page = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return - Flushed 2! - - -fun flush11 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return - Flushed 1 and 2! - - -fun cache01 () : transaction page = +fun cache01 () = res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); return Reading 1. {case res of - None => + None => ? | Some row => {[row.Foo01.Bar]}} -fun cache10 () : transaction page = +fun cache10 () = res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); return Reading 2. {case res of - None => + None => ? | Some row => {[row.Foo10.Bar]}} -fun cache11 () : transaction page = +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 => + None => ? | Some row => {[row.Foo01.Bar]}} {case bla of - None => + None => ? | Some row => {[row.Foo10.Bar]}} + +fun flush01 () = + dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); + return + Flushed 1! + + +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 cache id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + return + Reading {[id]}. + {case res of + None => ? + | Some row => {[row.Tab.Val]}} + + +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]})); + return + (* Flushed {[id]}! *) + {case res of + None => Initialized {[id]}! + | Some row => Incremented {[id]}!} + diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 123f58e5..7ac469f9 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -3,5 +3,6 @@ sql test.sql safeGet Test/flush01 safeGet Test/flush10 safeGet Test/flush11 +safeGet Test/flush test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ce7d0350..ace4ba28 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -4,3 +4,5 @@ val cache11 : unit -> transaction page val flush01 : 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 8ca35234..6427cf3d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3395,49 +3395,77 @@ fun p_file env (ds, ps) = (* For sqlcache. *) box (List.map - (fn index => + (fn {index, params} => let val i = Int.toString index + fun paramRepeat itemi sep = + let + val rec f = + fn 0 => itemi (Int.toString 0) + | n => f (n-1) ^ itemi (Int.toString n) + in + f (params - 1) + end + val args = paramRepeat (fn p => "uw_Basis_string p" ^ p) ", " + 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" + val eqs = paramRepeat (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") " || " in box [string "static char *cache", string i, string " = NULL;", newline, - string "static uw_Basis_bool uw_Cache_check", - string i, - string "(uw_context ctx) { puts(\"SQLCACHE: checked ", + string decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", string i, - string ".\"); if (cache", + string "(uw_context ctx, ", + string args, + string ") {\n puts(\"SQLCACHE: checked ", string i, - string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + string ".\");\n if (cache", string i, - string "); puts(\"SQLCACHE: used ", + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL || ", + string eqs, + string ") {\n puts(\"miss D:\"); puts(p0);\n return NULL;\n } else {\n puts(\"hit :D\");\n return cache", string i, - string ".\"); return uw_Basis_True; } };", + string ";\n } };", newline, - string "static uw_unit uw_Cache_store", + string "static uw_unit uw_Sqlcache_store", string i, - string "(uw_context ctx) { cache", + string "(uw_context ctx, uw_Basis_string s, ", + string args, + string ") {\n free(cache", string i, - string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", + string ");", + newline, + string frees, + newline, + string "cache", string i, - string ".\"); return uw_unit_v; };", + string " = strdup(s);", + newline, + string sets, newline, - string "static uw_unit uw_Cache_flush", + string "puts(\"SQLCACHE: stored ", string i, - string "(uw_context ctx) { free(cache", + string ".\"); puts(p0);\n return uw_unit_v;\n };", + newline, + string "static uw_unit uw_Sqlcache_flush", string i, - string "); cache", + string "(uw_context ctx) {\n free(cache", string i, - string " = NULL; puts(\"SQLCACHE: flushed ", + string ");\n cache", string i, - string ".\"); return uw_unit_v; };", - newline, - string "static uw_unit uw_Cache_ready", + string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string "(uw_context ctx) { return uw_unit_v; };", + string ".\");\n return uw_unit_v;\n };", newline, newline] end) - (!Sqlcache.ffiIndices)), + (Sqlcache.getFfiInfo ())), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/compiler.sig b/src/compiler.sig index fb0245ea..c154240a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -199,7 +199,6 @@ signature COMPILER = sig val enableBoot : unit -> unit val doIflow : bool ref - val doSqlcache : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index d7ee8700..fc4067a4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -83,7 +83,6 @@ type ('src, 'dst) transform = { val debug = ref false val dumpSource = ref false val doIflow = ref false -val doSqlcache = ref false val doDumpSource = ref (fn () => ()) @@ -1457,7 +1456,10 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck val sqlcache = { - func = (fn file => (if !doSqlcache then Sqlcache.go file else file)), + func = (fn file => + if Settings.getSqlcache () + then let val file = MonoInline.inlineFull file in Sqlcache.go file end + else file), print = MonoPrint.p_file MonoEnv.empty } diff --git a/src/monoize.sig b/src/monoize.sig index 838d7c4c..951db01b 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -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 diff --git a/src/monoize.sml b/src/monoize.sml index 6073a21f..d609a67d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1957,20 +1957,26 @@ 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' = (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) 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/multimap_fn.sml b/src/multimap_fn.sml index 585b741f..3dab68a5 100644 --- a/src/multimap_fn.sml +++ b/src/multimap_fn.sml @@ -1,14 +1,16 @@ functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct type key = KeyMap.Key.ord_key type item = ValSet.item - type items = ValSet.set + type itemSet = ValSet.set type multimap = ValSet.set KeyMap.map - fun inserts (kToVs : multimap, k : key, vs : items) : multimap = + val empty : multimap = KeyMap.empty + fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap = KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) fun insert (kToVs : multimap, k : key, v : item) : multimap = - inserts (kToVs, k, ValSet.singleton v) - fun find (kToVs : multimap, k : key) = + insertSet (kToVs, k, ValSet.singleton v) + fun findSet (kToVs : multimap, k : key) = case KeyMap.find (kToVs, k) of SOME vs => vs | NONE => ValSet.empty + val findList : multimap * key -> item list = ValSet.listItems o findSet end diff --git a/src/settings.sig b/src/settings.sig index 9b32e502..e94832e0 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -279,6 +279,9 @@ signature SETTINGS = sig val setLessSafeFfi : bool -> unit val getLessSafeFfi : unit -> bool + val setSqlcache : bool -> unit + val getSqlcache : unit -> bool + val setFilePath : string -> unit (* Sets the directory where we look for files being added below. *) diff --git a/src/settings.sml b/src/settings.sml index eb350c95..81c33c08 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,6 +744,10 @@ val less = ref false fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare diff --git a/src/sources b/src/sources index 8860b310..518b7484 100644 --- a/src/sources +++ b/src/sources @@ -212,6 +212,8 @@ $(SRC)/multimap_fn.sml $(SRC)/sqlcache.sig $(SRC)/sqlcache.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sig b/src/sql.sig index 2623f5e7..2aba8383 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -2,6 +2,8 @@ signature SQL = sig val debug : bool ref +val sqlcacheMode : bool ref + type lvar = int datatype func = diff --git a/src/sql.sml b/src/sql.sml index 8d245660..d38de055 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -270,6 +270,22 @@ fun sqlify chs = | _ => NONE +fun sqlifySqlcache chs = + case chs of + (* Match entire FFI application, not just its argument. *) + Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME ((e', ErrorMsg.dummySpan), chs) + else + NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => + SOME (e, chs) + + | _ => NONE + fun constK s = wrap (const s) (fn () => s) val funcName = altL [constK "COUNT", @@ -281,6 +297,8 @@ val funcName = altL [constK "COUNT", val unmodeled = altL [const "COUNT(*)", const "CURRENT_TIMESTAMP"] +val sqlcacheMode = ref false; + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, @@ -292,7 +310,7 @@ fun sqexp chs = wrap known SqKnown, wrap func SqFunc, wrap unmodeled (fn () => Unmodeled), - wrap sqlify Inj, + wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) (fn ((), (e, _)) => e), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index b01de4c9..563b2162 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,21 +1,247 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* :> SQLCACHE *) = struct open Sql open Mono structure IS = IntBinarySet structure IM = IntBinaryMap -structure StringKey = struct type ord_key = string val compare = String.compare end -structure SS = BinarySetFn (StringKey) -structure SM = BinaryMapFn (StringKey) -structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) +structure SK = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) -val ffiIndices : int list ref = ref [] +(* Filled in by cacheWrap during Sqlcache. *) +val ffiInfo : {index : int, params : int} list ref = ref [] -(* Expression construction utilities. *) +fun getFfiInfo () = !ffiInfo + +(* Program analysis. *) + +val useInjIfPossible = + fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan) + | sqexp => sqexp + +fun equalities (canonicalTable : string -> string) : + sqexp -> ((string * string) * Mono.exp) list option = + let + val rec eqs = + fn Binop (Exps f, e1, e2) => + (* TODO: use a custom datatype in Exps instead of a function. *) + (case f (Var 1, Var 2) of + Reln (Eq, [Var 1, Var 2]) => + let + val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2) + in + case (e1', e2') of + (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)] + | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)] + | _ => NONE + end + | _ => NONE) + | Binop (Props f, e1, e2) => + (* TODO: use a custom datatype in Props instead of a function. *) + (case f (True, False) of + And (True, False) => + (case (eqs e1, eqs e2) of + (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2) + | _ => NONE) + | _ => NONE) + | _ => NONE + in + eqs + end + +val equalitiesQuery = + fn Query1 {From = tablePairs, Where = SOME exp, ...} => + equalities + (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *) + (fn t => + case List.find (fn (_, tAs) => t = tAs) tablePairs of + NONE => t + | SOME (tOrig, _) => tOrig) + exp + | Query1 {Where = NONE, ...} => SOME [] + | _ => NONE + +val equalitiesDml = + fn Insert (tab, eqs) => SOME (List.mapPartial + (fn (name, sqexp) => + case useInjIfPossible sqexp of + Inj e => SOME ((tab, name), e) + | _ => NONE) + eqs) + | Delete (tab, exp) => equalities (fn _ => tab) exp + (* TODO: examine the updated values and not just the way they're filtered. *) + (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the + Id = 42 and Id = 9001 cache entries. Could also think of it as doing a + Delete immediately followed by an Insert. *) + | Update (tab, _, exp) => equalities (fn _ => tab) exp + +val rec tablesQuery = + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) + +val tableDml = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + + +(* Program instrumentation. *) + +val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) + +val sequence = + fn (exp :: exps) => + let + val loc = ErrorMsg.dummySpan + in + List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps + end + | _ => raise Match + +fun ffiAppCache' (func, index, args) : Mono.exp' = + EFfiApp ("Sqlcache", func ^ Int.toString index, args) + +fun ffiAppCache (func, index, args) : Mono. exp = + (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) + +val varPrefix = "queryResult" + +fun indexOfName varName = + if String.isPrefix varPrefix varName + then Int.fromString (String.extract (varName, String.size varPrefix, NONE)) + else NONE + +val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x} + +(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) +val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty + +(* Used by Monoize. *) +val instrumentQuery = + let + val nextQuery = ref 0 + fun iq (query, urlifiedRel0) = + case query of + (EQuery {state = typ, ...}, loc) => + let + val i = !nextQuery before nextQuery := !nextQuery + 1 + in + urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0); + (* ASK: name variables properly? *) + (ELet (varPrefix ^ Int.toString i, typ, query, + (* Uses a dummy FFI call to keep the urlified expression around, which + in turn keeps the declarations required for urlification safe from + MonoShake. The dummy call is removed during Sqlcache. *) + (* ASK: is there a better way? *) + (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), + (ERel 0, loc)), + loc)), + loc) + end + | _ => raise Match + in + iq + end + +val gunk : ((string * string) * Mono.exp) list list ref = ref [[]] + +fun cacheWrap (query, i, urlifiedRel0, eqs) = + case query of + (EQuery {state = typ, ...}, _) => + let + val loc = ErrorMsg.dummySpan + (* TODO: deal with effectful injected expressions. *) + val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo; + map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk + val argsInc = map (fn (e, t) => (incRels e, t)) args + in + (ECase (ffiAppCache ("check", i, args), + [((PNone stringTyp, loc), + (ELet ("q", typ, query, + (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc), + (ERel 0, loc)), + loc)), + loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* ASK: what does this bool do? *) + (EUnurlify ((ERel 0, loc), typ, false), loc))], + {disc = stringTyp, result = typ}), + loc) + end + | _ => raise Match + +fun fileMapfold doExp file start = + case MonoUtil.File.mapfold {typ = Search.return2, + exp = fn x => (fn s => Search.Continue (doExp x s)), + decl = Search.return2} file start of + Search.Continue x => x + | Search.Return _ => raise Match + +fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) + +val addChecking = + let + fun doExp queryInfo = + fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) => + let + fun bind x f = Option.mapPartial f x + val attempt = + (* Ziv misses Haskell's do notation.... *) + bind (parse query queryText) (fn queryParsed => + (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp)); + bind (indexOfName v) (fn i => + bind (equalitiesQuery queryParsed) (fn eqs => + bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 => + SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body), + SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) + queryInfo + (tablesQuery queryParsed))))))) + in + case attempt of + SOME pair => pair + | NONE => (e', queryInfo) + end + | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) + | e' => (e', queryInfo) + in + fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty + end + +fun addFlushing (file, queryInfo) = + let + val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo + fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices + val doExp = + fn dmlExp as EDml (dmlText, _) => + let + val indices = + case parse dml dmlText of + SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed) + | NONE => allIndices + in + sequence (flushes indices @ [dmlExp]) + end + | e' => e' + in + fileMap doExp file + end + +fun go file = + let + val () = Sql.sqlcacheMode := true + in + addFlushing (addChecking file) before Sql.sqlcacheMode := false + end + + +(* BEGIN OLD fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc) + fun boolPat (b, loc) = (PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, con = if b then "True" else "False"}, @@ -23,11 +249,13 @@ fun boolPat (b, loc) = (PCon (Enum, loc) fun boolTyp loc = (TFfi ("Basis", "int"), loc) -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) +fun ffiAppExp (module, func, index, args, loc) = + (EFfiApp (module, func ^ Int.toString index, args), loc) -fun sequence ((exp :: exps), loc) = +val sequence = + fn ((exp :: exps), loc) => List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps + | _ => raise Match fun antiguardUnit (cond, exp, loc) = (ECase (cond, @@ -41,11 +269,10 @@ fun underAbs f (exp as (exp', loc)) = EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) | _ => f exp -(* Program analysis and augmentation. *) val rec tablesRead = - fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2) val tableWritten = fn Insert (tab, _) => tab @@ -57,7 +284,7 @@ fun tablesInExp' exp' = val nothing = {read = SS.empty, written = SS.empty} in case exp' of - EQuery {query=e, ...} => + EQuery {query = e, ...} => (case parse query e of SOME q => {read = tablesRead q, written = SS.empty} | NONE => nothing) @@ -71,8 +298,11 @@ fun tablesInExp' exp' = val tablesInExp = let fun addTables (exp', {read, written}) = - let val {read = r, written = w} = tablesInExp' exp' - in {read = SS.union (r, read), written = SS.union (w, written)} end + let + val {read = r, written = w} = tablesInExp' exp' + in + {read = SS.union (r, read), written = SS.union (w, written)} + end in MonoUtil.Exp.fold {typ = #2, exp = addTables} {read = SS.empty, written = SS.empty} @@ -150,7 +380,7 @@ fun fileFoldMapiSelected f init (file, indices) = in case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of Search.Continue x => x - | _ => (file, init) (* Should never happen. *) + | _ => raise Match (* Should never happen. *) end fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () @@ -178,4 +408,6 @@ fun go file = addCacheFlushing (fileWithChecks, tablesToIndices, writers) end +END OLD *) + end -- 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 'caching-tests/test.urs') 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 bef4dd04f19c2001561e9e889116f5a2f8905bc0 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 27 Mar 2015 11:19:15 -0400 Subject: Simplify example. --- caching-tests/test.ur | 68 ++++++++------------------------------------------ caching-tests/test.urp | 3 --- caching-tests/test.urs | 6 ----- 3 files changed, 11 insertions(+), 66 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index 2722bcdc..8035e336 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,59 +1,9 @@ -table foo01 : {Id : int, Bar : string} PRIMARY KEY Id -table foo10 : {Id : int, Bar : string} PRIMARY KEY Id table tab : {Id : int, Val : int} PRIMARY KEY Id -fun cache01 () = - res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 43); - return - Reading 1. - {case res of - None => ? - | 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 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")); - (* dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); *) - return - Flushed 1! - - -(* 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 cache id = - res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + res <- oneOrNoRows (SELECT tab.Val + FROM tab + WHERE tab.Id = {[id]}); return Reading {[id]}. {case res of @@ -62,12 +12,16 @@ fun cache id = fun flush id = - res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + res <- oneOrNoRows (SELECT tab.Val + FROM tab + WHERE tab.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]})); + 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 None => Initialized {[id]}! | Some row => Incremented {[id]}!} diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 7ac469f9..796a6257 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,8 +1,5 @@ database test.db sql test.sql -safeGet Test/flush01 -safeGet Test/flush10 -safeGet Test/flush11 safeGet Test/flush test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index 30bff733..6d4cedf2 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,8 +1,2 @@ -val cache01 : 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 cache : int -> transaction page val flush : int -> transaction page -- cgit v1.2.3 From 02e3a75b12e9f2dc7077d2cd2a8903db2bff92b4 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 19 Jul 2015 19:12:50 -0700 Subject: Add parameterless query to caching test. --- caching-tests/test.ur | 8 ++++++++ caching-tests/test.urp | 1 + caching-tests/test.urs | 1 + 3 files changed, 10 insertions(+) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index f6568db4..578d59b3 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -19,6 +19,14 @@ fun flush id = Changed {[id]}! +val flush17 = + dml (UPDATE tab + SET Val = Val * (Id + 2) / Val - 3 + WHERE Id = 17); + return + Changed specifically 17! + + (* fun flush id = *) (* res <- oneOrNoRows (SELECT tab.Val *) (* FROM tab *) diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 796a6257..2e07dad3 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,5 +1,6 @@ database test.db sql test.sql safeGet Test/flush +safeGet Test/flush17 test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index 6d4cedf2..e9e09ac8 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,2 +1,3 @@ val cache : int -> transaction page val flush : int -> transaction page +val flush17 : transaction page -- cgit v1.2.3 From f425194d947691ceeaad9ec73fdc7c2c176ebfe3 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 15 Oct 2015 00:52:04 -0400 Subject: Make SQL caches use more of the pure caching machinery, but it's brittle. --- caching-tests/test.ur | 11 ++++++++ caching-tests/test.urs | 1 + src/sqlcache.sml | 69 +++++++++++++++++++++++++------------------------- 3 files changed, 46 insertions(+), 35 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index 578d59b3..00f05768 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -11,6 +11,17 @@ fun cache id = | Some row => {[row.Tab.Val]}} +fun cache2 id v = + res <- oneOrNoRows (SELECT tab.Val + FROM tab + WHERE tab.Id = {[id]} AND tab.Val = {[v]}); + return + Reading {[id]}. + {case res of + None => Nope, that's not it. + | Some _ => Hooray! You guessed it!} + + fun flush id = dml (UPDATE tab SET Val = Val * (Id + 2) / Val - 3 diff --git a/caching-tests/test.urs b/caching-tests/test.urs index e9e09ac8..fc23c47d 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,3 +1,4 @@ val cache : int -> transaction page +val cache2 : int -> int -> transaction page val flush : int -> transaction page val flush17 : transaction page diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 42bd724c..f98ff4bb 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -675,6 +675,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t + | EQuery {state, ...} => SOME state | _ => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -770,17 +771,35 @@ val runSubexp : subexp * state -> exp * state = (* TODO: pick a number. *) val sizeWorthCaching = 5 +val worthCaching = + fn EQuery _ => true + | exp' => expSize (exp', dummyLoc) > sizeWorthCaching + +fun cachePure (env, exp', state as (_, _, _, index)) = + case (worthCaching exp') + + typOfExp' env exp' of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + (List.foldr (fn (_, NONE) => NONE + | ((n, typ), SOME args) => + (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) + + (fn arg => SOME (arg :: args))) + (SOME []) + (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) + (ListMergeSort.sort op> (freeVars (exp', dummyLoc))))) + + (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state)) + fun cacheQuery (effs, env, state, q) : (exp' * state) = let val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state - val {query = queryText, - state = resultTyp, - initial, body, tables, exps} = q + val {query = queryText, initial, body, ...} = q val numArgs = maxFreeVar queryText + 1 - val queryExp = (EQuery q, dummyLoc) (* DEBUG *) (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) - val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) (* We use dummyTyp here. I think this is okay because databases don't store (effectful) functions, but perhaps there's some pathalogical corner case missing.... *) @@ -790,6 +809,8 @@ fun cacheQuery (effs, env, state, q) : (exp' * state) = (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) bound env) + val {state = resultTyp, ...} = q + val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) val attempt = (* Ziv misses Haskell's do notation.... *) (safe 0 queryText andalso safe 0 initial andalso safe 2 body) @@ -797,7 +818,7 @@ fun cacheQuery (effs, env, state, q) : (exp' * state) = Sql.parse Sql.query queryText (fn queryParsed => - (cacheWrap (env, queryExp, resultTyp, args, state)) + (cachePure (env, EQuery q, state)) (fn (cachedExp, state) => SOME (cachedExp, @@ -813,24 +834,6 @@ fun cacheQuery (effs, env, state, q) : (exp' * state) = | NONE => (EQuery q, state) end -fun cachePure (env, exp', state as (_, _, _, index)) = - case (expSize (exp', dummyLoc) > sizeWorthCaching) - - typOfExp' env exp' of - NONE => NONE - | SOME (TFun _, _) => NONE - | SOME typ => - (List.foldr (fn (_, NONE) => NONE - | ((n, typ), SOME args) => - (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) - - (fn arg => SOME (arg :: args))) - (SOME []) - (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) - (freeVars (exp', dummyLoc)))) - - (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state)) - fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) = let fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) = @@ -896,13 +899,13 @@ fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) = in (Impure (exp', loc), state) end - | _ => if effectful effs env exp - then (Impure exp, state) - else (Cachable (fn state => + | _ => (if effectful effs env exp + then Impure exp + else Cachable (fn state => case cachePure (env, exp', state) of - NONE => ((exp', loc), state) - | SOME (exp', state) => ((exp', loc), state)), - state) + NONE => ((exp', loc), state) + | SOME (exp', state) => ((exp', loc), state)), + state) end fun addCaching file = @@ -934,11 +937,7 @@ structure Invalidations = struct loc) fun eqsToInvalidation numArgs eqs = - let - fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) - in - inv (numArgs - 1) - end + List.tabulate (numArgs, (fn n => IM.find (eqs, n))) (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here represents unknown, which means a wider invalidation. *) -- cgit v1.2.3 From 1c2069212a7dec30db45e02391d7ca0154cd5709 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 7 Nov 2015 15:16:44 -0500 Subject: Fix some table renaming issues. --- caching-tests/test.ur | 52 ++++++++++++------- caching-tests/test.urp | 5 +- caching-tests/test.urs | 6 ++- src/sqlcache.sml | 136 +++++++++++++++++++------------------------------ 4 files changed, 93 insertions(+), 106 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index 338f9236..e08c6e47 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,4 +1,4 @@ -table tab : {Id : int, Val : int} PRIMARY KEY Id +table tab : {Id : int, Val : int, Foo : int} PRIMARY KEY Id fun cache id = res <- oneOrNoRows (SELECT tab.Val @@ -22,19 +22,19 @@ fun cache id = (* | Some _ => Hooray! You guessed it!} *) (* *) -fun cache2 id1 id2 = - res1 <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[id1]}); - res2 <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[id2]}); - return - Reading {[id1]} and {[id2]}. - {case (res1, res2) of - (Some _, Some _) => Both are there. - | _ => One of them is missing.} - +(* fun cache2 id1 id2 = *) +(* res1 <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id1]}); *) +(* res2 <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id2]}); *) +(* return *) +(* Reading {[id1]} and {[id2]}. *) +(* {case (res1, res2) of *) +(* (Some _, Some _) => Both are there. *) +(* | _ => One of them is missing.} *) +(* *) fun flush id = dml (UPDATE tab @@ -44,14 +44,30 @@ fun flush id = Changed {[id]}! -val flush17 = +fun flash id = dml (UPDATE tab - SET Val = Val * (Id + 2) / Val - 3 - WHERE Id = 17); + SET Foo = Val + WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); return - Changed specifically 17! + Maybe changed {[id]}? +fun floosh id = + dml (UPDATE tab + SET Id = {[id + 1]} + WHERE Id = {[id]}); + return + Shifted {[id]}! + + +(* val flush17 = *) +(* dml (UPDATE tab *) +(* SET Val = Val * (Id + 2) / Val - 3 *) +(* WHERE Id = 17); *) +(* return *) +(* Changed specifically 17! *) +(* *) + (* fun flush id = *) (* res <- oneOrNoRows (SELECT tab.Val *) (* FROM tab *) diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 55b0bed7..62041bdd 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,7 +1,8 @@ database test.db sql test.sql safeGet Test/flush -safeGet Test/flush17 -minHeap 4096 +safeGet Test/flash +safeGet Test/floosh +# safeGet Test/flush17 test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index fc23c47d..ebe6bf56 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,4 +1,6 @@ val cache : int -> transaction page -val cache2 : int -> int -> transaction page +(* val cache2 : int -> int -> transaction page *) val flush : int -> transaction page -val flush17 : transaction page +val flash : int -> transaction page +val floosh : int -> transaction page +(* val flush17 : transaction page *) diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 7a7358f0..7b3a5225 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,4 +1,4 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* DEBUG :> SQLCACHE *) = struct open Mono @@ -567,6 +567,12 @@ end = struct end +(* DEBUG *) +val gunk0 : ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula + * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula) list ref = ref [] +val gunk1 : (Sql.cmp * atomExp option * atomExp option) list list list ref = ref [] +val gunk2 : exp list ref = ref [] + structure UF = UnionFindFn(AtomExpKey) val rec sqexpToFormula = @@ -579,18 +585,22 @@ val rec sqexpToFormula = (* ASK: any other sqexps that can be props? *) | _ => raise Match +fun mapSqexpFields f = + fn Sql.Field (t, v) => f (t, v) + | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) + | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) + | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) + | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e) + | e => e + fun renameTables tablePairs = let - fun renameString table = + fun rename table = case List.find (fn (_, t) => table = t) tablePairs of NONE => table | SOME (realTable, _) => realTable - val renameSqexp = - fn Sql.Field (table, field) => Sql.Field (renameString table, field) - | e => e - (* fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2) *) in - mapFormulaExps renameSqexp + mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) end fun queryToFormula marker = @@ -598,26 +608,25 @@ fun queryToFormula marker = let val fWhere = case wher of NONE => Combo (Conj, []) - | SOME e => sqexpToFormula e + | SOME e => sqexpToFormula (renameTables tablePairs e) in - renameTables tablePairs - (case marker of - NONE => fWhere - | SOME markFields => - let - val fWhereMarked = mapFormulaExps markFields fWhere - val toSqexp = - fn Sql.SqField tf => Sql.Field tf - | Sql.SqExp (se, _) => se - fun ineq se = Atom (Sql.Ne, se, markFields se) - val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems) - in - (Combo (Conj, - [fWhere, - Combo (Disj, - [Negate fWhereMarked, - Combo (Conj, [fWhereMarked, fIneqs])])])) - end) + case marker of + NONE => fWhere + | SOME markFields => + let + val fWhereMarked = mapFormulaExps markFields fWhere + val toSqexp = + fn Sql.SqField tf => Sql.Field tf + | Sql.SqExp (se, _) => se + fun ineq se = Atom (Sql.Ne, se, markFields se) + val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems) + in + (Combo (Conj, + [fWhere, + Combo (Disj, + [Negate fWhereMarked, + Combo (Conj, [fWhereMarked, fIneqs])])])) + end end | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2]) @@ -629,70 +638,33 @@ fun valsToFormula (markLeft, markRight) (table, vals) = (* TODO: verify logic for insertion and deletion. *) val rec dmlToFormulaMarker = fn Sql.Insert (table, vals) => (valsToFormula (id, id) (table, vals), NONE) - | Sql.Delete (table, wher) => (renameTables [(table, "T")] (sqexpToFormula wher), NONE) + | Sql.Delete (table, wher) => (sqexpToFormula (renameTables [(table, "T")] wher), NONE) | Sql.Update (table, vals, wher) => let - val fWhere = sqexpToFormula wher + val fWhere = sqexpToFormula (renameTables [(table, "T")] wher) fun fVals marks = valsToFormula marks (table, vals) val modifiedFields = SS.addList (SS.empty, map #1 vals) (* TODO: don't use field name hack. *) - fun markFields table = - fn e as Sql.Field (t, v) => if t = table andalso SS.member (modifiedFields, v) - then Sql.Field (t, v ^ "'") - else e - | Sql.SqNot e => Sql.SqNot (markFields table e) - | Sql.Binop (r, e1, e2) => Sql.Binop (r, markFields table e1, markFields table e2) - | Sql.SqKnown e => Sql.SqKnown (markFields table e) - | Sql.SqFunc (s, e) => Sql.SqFunc (s, markFields table e) - | e => e - val mark = mapFormulaExps (markFields "T") + val markFields = + mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v) + then ((* DEBUG *) print ("yep" ^ Int.toString (length (!gunk0))); + Sql.Field (t, v ^ "'")) + else ((* DEBUG *) print (table ^ " " ^ t ^ "\n"); Sql.Field (t, v))) + val mark = mapFormulaExps markFields in - (* Inside renameTables, we mark with table "T". Outside, we use the real table name. *) - (renameTables [(table, "T")] - (Combo (Disj, [Combo (Conj, [fVals (id, markFields "T"), mark fWhere]), - Combo (Conj, [fVals (markFields "T", id), fWhere])])), - SOME (markFields table)) + ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]), + Combo (Conj, [fVals (markFields, id), fWhere])])), + SOME markFields) end fun pairToFormulas (query, dml) = let - val (fDml, marker) = dmlToFormulaMarker dml + val (fDml, marker) = ((* DEBUG *) print "dml\n"; dmlToFormulaMarker dml) in + (* DEBUG *) print "query\n"; (queryToFormula marker query, fDml) end -(* structure ToFormula = struct *) - -(* val testOfQuery : Sql.query1 -> (Sql.cmp * Sql.sqexp * Sql.sqexp) formula = *) -(* fn {From = tablePairs, Where = SOME e, ...} => renameTables tablePairs (sqexpToFormula e) *) -(* | {Where = NONE, ...} => Combo (Conj, []) *) - -(* (* If selecting some parsable subset of fields, says which ones. [NONE] *) -(* means anything could be selected. *) *) -(* fun fieldsOfQuery (q : Sql.query1) = *) -(* osequence (map (fn Sql.SqField tf => SOME tf *) -(* | Sql.SqExp (Sql.Field tf) => SOME tf *) -(* | _ => NONE) (#Select q)) *) - -(* fun fieldsOfVals (table, vals, wher) = *) -(* let *) -(* val fWhere = renameTables [(table, "T")] (sqexpToFormula wher) *) -(* val fVals = valsToFormula (table, vals) *) -(* val modifiedFields = SS.addList (SS.empty, map #1 vals) *) -(* (* TODO: don't use field name hack. *) *) -(* val markField = *) -(* fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v) *) -(* then Sql.Field (t, v ^ "'") *) -(* else e *) -(* | e => e *) -(* val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) *) -(* in *) -(* renameTables [(table, "T")] *) -(* (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]), *) -(* Combo (Conj, [mark fVals, fWhere])])) *) -(* end *) -(* end *) - structure ConflictMaps = struct structure TK = TripleKeyFn(structure I = CmpKey @@ -716,7 +688,7 @@ structure ConflictMaps = struct atoms val contradiction = fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) - andalso not (UF.together (uf, ae1, ae2)) + andalso UF.together (uf, ae1, ae2) (* If we don't know one side of the comparision, not a contradiction. *) | _ => false in @@ -814,7 +786,9 @@ structure ConflictMaps = struct val conflictMaps = List.mapPartial (mergeEqs o map eqsOfClass) o List.mapPartial equivClasses + o (fn x => (gunk1 := x :: !gunk1; x)) o dnf + o (fn x => (gunk0 := x :: !gunk0; x)) end @@ -1317,10 +1291,6 @@ end val invalidations = Invalidations.invalidations -(* DEBUG *) -(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) -(* val gunk' : exp list ref = ref [] *) - fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) = let val flushes = List.concat @@ -1329,7 +1299,7 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state fn dmlExp as EDml (dmlText, failureMode) => let (* DEBUG *) - (* val () = gunk' := origDmlText :: !gunk' *) + (* val () = gunk2 := dmlText :: !gunk2 *) (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) val inval = case Sql.parse Sql.dml dmlText of @@ -1352,8 +1322,6 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state val file = fileMap doExp file in - (* DEBUG *) - (* gunk := []; *) ffiInfoRef := ffiInfo; file end -- cgit v1.2.3 From aa2c8c64542d7930773da26573e186ec3753c268 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 9 Nov 2015 13:37:31 -0500 Subject: Progress on free paths, but consolidation seems to fail more with them. --- caching-tests/test.ur | 18 +++- caching-tests/test.urp | 1 + caching-tests/test.urs | 1 + src/sources | 3 + src/sqlcache.sml | 222 ++++++++++++++++++++++++++++++++++--------------- 5 files changed, 177 insertions(+), 68 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index e08c6e47..0549840d 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -5,7 +5,23 @@ fun cache id = FROM tab WHERE tab.Id = {[id]}); return - Reading {[id]}. + (* Reading {[id]}. *) + {case res of + None => ? + | Some row => {[row.Tab.Val]}} + + +(* fun sillyRecursive {Id = id, FooBar = fooBar} = *) +(* if fooBar <= 0 *) +(* then 0 *) +(* else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} *) + +fun cacheR (r : {Id : int, FooBar : int}) = + res <- oneOrNoRows (SELECT tab.Val + FROM tab + WHERE tab.Id = {[r.Id]}); + return + (* Reading {[r.Id]}. *) {case res of None => ? | Some row => {[row.Tab.Val]}} diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 62041bdd..cea8821e 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -4,5 +4,6 @@ safeGet Test/flush safeGet Test/flash safeGet Test/floosh # safeGet Test/flush17 +minHeap 4096 test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ebe6bf56..1fa5a9c2 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,4 +1,5 @@ val cache : int -> transaction page +val cacheR : {Id : int, FooBar : int} -> transaction page (* val cache2 : int -> int -> transaction page *) val flush : int -> transaction page val flash : int -> transaction page diff --git a/src/sources b/src/sources index 1303b46e..8bf80bc6 100644 --- a/src/sources +++ b/src/sources @@ -176,7 +176,10 @@ $(SRC)/sql.sml $(SRC)/union_find_fn.sml $(SRC)/multimap_fn.sml + +$(SRC)/list_key_fn.sml $(SRC)/option_key_fn.sml +$(SRC)/pair_key_fn.sml $(SRC)/triple_key_fn.sml $(SRC)/cache.sml diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 7b3a5225..ce383f18 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -2,6 +2,7 @@ structure Sqlcache (* DEBUG :> SQLCACHE *) = struct open Mono +structure IK = struct type ord_key = int val compare = Int.compare end structure IS = IntBinarySet structure IM = IntBinaryMap structure SK = struct type ord_key = string val compare = String.compare end @@ -330,11 +331,89 @@ val freeVars = 0 IS.empty +(* A path is a number of field projections of a variable. *) +structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK)) +structure PS = BinarySetFn(PK) + +(* DEBUG *) +val gunk3 : (PS.set * PS.set) list ref = ref [] +val gunk4 : (PS.set * PS.set) list ref = ref [] + +val pathOfExp = + let + fun readFields acc exp = + acc + <\obind\> + (fn fs => + case #1 exp of + ERel n => SOME (n, fs) + | EField (exp, f) => readFields (SOME (f::fs)) exp + | _ => NONE) + in + readFields (SOME []) + end + +fun expOfPath (n, fs) = + List.foldl (fn (f, exp) => (EField (exp, f), dummyLoc)) (ERel n, dummyLoc) fs + +fun freePaths'' bound exp paths = + case pathOfExp (exp, dummyLoc) of + NONE => paths + | SOME (n, fs) => if n < bound then paths else PS.add (paths, (n - bound, fs)) + +(* ASK: nicer way? :( *) +fun freePaths' bound exp = + case #1 exp of + EPrim _ => id + | e as ERel _ => freePaths'' bound e + | ENamed _ => id + | ECon (_, _, data) => (case data of NONE => id | SOME e => freePaths' bound e) + | ENone _ => id + | ESome (_, e) => freePaths' bound e + | EFfi _ => id + | EFfiApp (_, _, args) => + List.foldl (fn ((e, _), acc) => freePaths' bound e o acc) id args + | EApp (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EAbs (_, _, _, e) => freePaths' (bound + 1) e + | EUnop (_, e) => freePaths' bound e + | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields + | e as EField _ => freePaths'' bound e + | ECase (e, cases, _) => + List.foldl (fn ((p, e), acc) => freePaths' (bound + MonoEnv.patBindsN p) e o acc) + (freePaths' bound e) + cases + | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EError (e, _) => freePaths' bound e + | EReturnBlob {blob, mimeType = e, ...} => + freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e) + | ERedirect (e, _) => freePaths' bound e + | EWrite e => freePaths' bound e + | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ELet (_, _, e1, e2) => freePaths' (bound + 1) e1 o freePaths' bound e2 + | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es + | EQuery {query = e1, body = e2, initial = e3, ...} => + freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3 + | EDml (e, _) => freePaths' bound e + | ENextval e => freePaths' bound e + | ESetval (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EUnurlify (e, _, _) => freePaths' bound e + | EJavaScript (_, e) => freePaths' bound e + | ESignalReturn e => freePaths' bound e + | ESignalBind (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ESignalSource e => freePaths' bound e + | EServerCall (e, _, _, _) => freePaths' bound e + | ERecv (e, _) => freePaths' bound e + | ESleep e => freePaths' bound e + | ESpawn e => freePaths' bound e + +fun freePaths exp = freePaths' 0 exp PS.empty + datatype unbind = Known of exp | Unknowns of int datatype cacheArg = AsIs of exp | Urlify of exp -structure InvalInfo :> sig +structure InvalInfo (* DEBUG :> sig type t type state = {tableToIndices : SIMM.multimap, indexToInvalInfo : (t * int) IntBinaryMap.map, @@ -347,9 +426,10 @@ structure InvalInfo :> sig val unbind : t * unbind -> t option val union : t * t -> t val updateState : t * int * state -> state -end = struct +end *) = struct - datatype sqlArg = FreeVar of int | Sqlify of string * string * sqlArg * typ + (* Variable, field projections, possible wrapped sqlification FFI call. *) + type sqlArg = int * string list * (string * string * typ) option type subst = sqlArg IM.map @@ -361,24 +441,14 @@ end = struct ffiInfo : {index : int, params : int} list, index : int} - structure AM = BinaryMapFn(struct - type ord_key = sqlArg - (* Saw this on MLton wiki. *) - fun ifNotEq (cmp, thunk) = case cmp of - EQUAL => thunk () - | _ => cmp - fun try f x () = f x - val rec compare = - fn (FreeVar n1, FreeVar n2) => - Int.compare (n1, n2) - | (FreeVar _, _) => LESS - | (_, FreeVar _) => GREATER - | (Sqlify (m1, x1, arg1, t1), Sqlify (m2, x2, arg2, t2)) => - String.compare (m1, m2) - <\ifNotEq\> try String.compare (x1, x2) - <\ifNotEq\> try MonoUtil.Typ.compare (t1, t2) - <\ifNotEq\> try compare (arg1, arg2) - end) + structure AK = TripleKeyFn( + structure I = IK + structure J = ListKeyFn(SK) + structure K = OptionKeyFn(TripleKeyFn( + structure I = SK + structure J = SK + structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) + structure AM = BinaryMapFn(AK) (* Traversal Utilities *) (* TODO: get rid of unused ones. *) @@ -423,9 +493,21 @@ end = struct fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = let - val rec mp = - fn FreeVar n => f n - | Sqlify (m, x, arg, t) => lift (fn mparg => Sqlify (m, x, mparg, t)) (mp arg) + fun mp (n, fields, sqlify) = + lift (fn (n', fields', sqlify') => + let + fun wrap sq = (n', fields' @ fields, sq) + in + case (fields', sqlify', fields, sqlify) of + (_, NONE, _, NONE) => wrap NONE + | (_, NONE, _, sq as SOME _) => wrap sq + (* Last case should suffice because we don't + project from a sqlified value (which is a + string). *) + | (_, sq as SOME _, [], NONE) => wrap sq + | _ => raise Match + end) + (f n) in traverseIM ops (fn (_, v) => mp v) end @@ -447,7 +529,7 @@ end = struct IS.empty (fn e' => freeVars (e', dummyLoc)) - val varsOfSubst = foldMapSubst IS.union IS.empty IS.singleton + fun varsOfSubst subst = foldMapSubst IS.union IS.empty IS.singleton subst val varsOfList = fn [] => IS.empty @@ -457,7 +539,7 @@ end = struct val empty = [] - fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, FreeVar n)) + fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, (n, [], NONE))) IM.empty (varsOfQuery q))] @@ -477,21 +559,30 @@ end = struct AM.map count args end - val rec expOfArg = - fn FreeVar n => (ERel n, dummyLoc) - | Sqlify (m, x, arg, t) => (EFfiApp (m, x, [(expOfArg arg, t)]), dummyLoc) + fun expOfArg (n, fields, sqlify) = + let + val exp = List.foldl (fn (field, exp) => (EField (exp, field), dummyLoc)) + (ERel n, dummyLoc) + fields + in + case sqlify of + NONE => exp + | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc) + end - fun orderArgs (qs : t, vars) = + fun orderArgs (qs : t, paths) = let fun erel n = (ERel n, dummyLoc) val argsMap = sqlArgsMap qs val args = map (expOfArg o #1) (AM.listItemsi argsMap) - val invalVars = List.foldl IS.union IS.empty (map freeVars args) + val invalPaths = List.foldl PS.union PS.empty (map freePaths args) + (* DEBUG *) + val () = gunk3 := (paths, invalPaths) :: !gunk3 in (* Put arguments we might invalidate by first. *) map AsIs args (* TODO: make sure these variables are okay to remove from the argument list. *) - @ map (Urlify o erel) (IS.listItems (IS.difference (vars, invalVars))) + @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths))) end (* As a kludge, we rename the variables in the query to correspond to the @@ -527,13 +618,23 @@ end = struct | [] => raise Match end - val rec argOfExp = - fn (ERel n, _) => SOME (FreeVar n) - | (EFfiApp ("Basis", x, [(exp, t)]), _) => - if String.isPrefix "sqlify" x - then omap (fn arg => Sqlify ("Basis", x, arg, t)) (argOfExp exp) - else NONE - | _ => NONE + val argOfExp = + let + fun doFields acc exp = + acc + <\obind\> + (fn (fs, sqlify) => + case #1 exp of + ERel n => SOME (n, fs, sqlify) + | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp + | _ => NONE) + in + fn (EFfiApp ("Basis", x, [(exp, typ)]), _) => + if String.isPrefix "sqlify" x + then doFields (SOME ([], SOME ("Basis", x, typ))) exp + else NONE + | exp => doFields (SOME ([], NONE)) exp + end val unbind1 = fn Known e => @@ -541,9 +642,9 @@ end = struct val replacement = argOfExp e in omapSubst (fn 0 => replacement - | n => SOME (FreeVar (n-1))) + | n => SOME (n-1, [], NONE)) end - | Unknowns k => omapSubst (fn n => if n >= k then NONE else SOME (FreeVar (n-k))) + | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME (n-k, [], NONE)) fun unbind (qs, ub) = case ub of @@ -647,9 +748,8 @@ val rec dmlToFormulaMarker = (* TODO: don't use field name hack. *) val markFields = mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v) - then ((* DEBUG *) print ("yep" ^ Int.toString (length (!gunk0))); - Sql.Field (t, v ^ "'")) - else ((* DEBUG *) print (table ^ " " ^ t ^ "\n"); Sql.Field (t, v))) + then Sql.Field (t, v ^ "'") + else Sql.Field (t, v)) val mark = mapFormulaExps markFields in ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]), @@ -659,9 +759,8 @@ val rec dmlToFormulaMarker = fun pairToFormulas (query, dml) = let - val (fDml, marker) = ((* DEBUG *) print "dml\n"; dmlToFormulaMarker dml) + val (fDml, marker) = dmlToFormulaMarker dml in - (* DEBUG *) print "query\n"; (queryToFormula marker query, fDml) end @@ -993,7 +1092,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t | EQuery {state, ...} => SOME state - | _ => NONE + | e => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -1002,22 +1101,6 @@ and typOfExp env (e', loc) = typOfExp' env e' (* Caching *) (***********) -(* - -To get the invalidations for a dml, we need (each <- is list-monad-y): - * table <- dml - * cache <- table - * query <- cache - * inval <- (query, dml), -where inval is a list of query argument indices, so - * way to change query args in inval to cache args. -For now, the last one is just - * a map from query arg number to the corresponding free variable (per query) - * a map from free variable to cache arg number (per cache). -Both queries and caches should have IDs. - -*) - type state = InvalInfo.state datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp @@ -1062,7 +1145,7 @@ fun cacheWrap (env, exp, typ, args, index) = val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 (* TODO: pick a number. *) -val sizeWorthCaching = 5 +val sizeWorthCaching = ~1 val worthCaching = fn EQuery _ => true @@ -1074,7 +1157,7 @@ fun cacheExp (env, exp', invalInfo, state : state) = | SOME (TFun _, _) => NONE | SOME typ => let - val args = InvalInfo.orderArgs (invalInfo, freeVars (exp', dummyLoc)) + val args = InvalInfo.orderArgs (invalInfo, freePaths (exp', dummyLoc)) val numArgs = length args in (List.foldr (fn (arg, acc) => acc @@ -1135,7 +1218,12 @@ fun cacheQuery (effs, env, q) : subexp = | SOME subexp => subexp end -fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = +(* DEBUG *) +(* fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = *) +(* (Print.preface ("cacheTree> ", MonoPrint.p_exp MonoEnv.empty exp); *) +(* cacheTree' effs ((env, exp), state)) *) + +and cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = let fun wrapBindN (f : exp list -> exp') (args : ((MonoEnv.env * exp) * unbind) list) = @@ -1300,7 +1388,7 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state let (* DEBUG *) (* val () = gunk2 := dmlText :: !gunk2 *) - (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) + (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) val inval = case Sql.parse Sql.dml dmlText of SOME dmlParsed => -- cgit v1.2.3 From bfcd84434ee997b474935aa13ae7bc1f3801d795 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 19 Nov 2015 01:59:00 -0500 Subject: Support nested queries but disable UrFlow for now. --- caching-tests/test.ur | 71 ++++++----- caching-tests/test.urp | 4 +- caching-tests/test.urs | 7 +- src/compiler.sig | 4 +- src/compiler.sml | 4 +- src/sources | 3 - src/sql.sig | 13 ++- src/sql.sml | 86 +++++++++----- src/sqlcache.sml | 310 ++++++++++++++++++++++++++++++++++--------------- 9 files changed, 332 insertions(+), 170 deletions(-) (limited to 'caching-tests/test.urs') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index cbfde556..ea64bb2d 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,9 +1,7 @@ table tab : {Id : int, Val : int, Foo : int} PRIMARY KEY Id fun cache id = - res <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[id]}); + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); return cache {case res of @@ -11,21 +9,32 @@ fun cache id = | Some row => {[row.Tab.Val]}} -fun sillyRecursive {Id = id : int, FooBar = fooBar} = - if fooBar <= 0 - then 0 - else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} +(* fun cacheAlt id = *) +(* res <- oneOrNoRows (SELECT Q.Id *) +(* FROM (SELECT Tab.Id AS Id FROM tab WHERE Tab.Id = {[id]}) *) +(* AS Q); *) +(* return *) +(* cacheAlt *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Q.Id]}} *) +(* *) -fun cacheR (r : {Id : int, FooBar : int}) = - res <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[r.Id]}); - return - cacheR {[r.FooBar]} - {case res of - None => ? - | Some row => {[row.Tab.Val]}} - +(* fun sillyRecursive {Id = id : int, FooBar = fooBar} = *) +(* if fooBar <= 0 *) +(* then 0 *) +(* else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} *) + +(* fun cacheR (r : {Id : int, FooBar : int}) = *) +(* res <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[r.Id]}); *) +(* return *) +(* cacheR {[r.FooBar]} *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Tab.Val]}} *) +(* *) (* fun cache2 id v = *) (* res <- oneOrNoRows (SELECT tab.Val *) @@ -60,21 +69,21 @@ fun flush id = Changed {[id]}! -fun flash id = - dml (UPDATE tab - SET Foo = Val - WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); - return - Maybe changed {[id]}? - +(* fun flash id = *) +(* dml (UPDATE tab *) +(* SET Foo = Val *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return *) +(* Maybe changed {[id]}? *) +(* *) -fun floosh id = - dml (UPDATE tab - SET Id = {[id + 1]} - WHERE Id = {[id]}); - return - Shifted {[id]}! - +(* fun floosh id = *) +(* dml (UPDATE tab *) +(* SET Id = {[id + 1]} *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return *) +(* Shifted {[id]}! *) +(* *) (* val flush17 = *) (* dml (UPDATE tab *) diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 07922e69..2cb9e711 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,8 +1,8 @@ database host=localhost sql test.sql safeGet Test/flush -safeGet Test/flash -safeGet Test/floosh +# safeGet Test/flash +# safeGet Test/floosh # safeGet Test/flush17 minHeap 4096 diff --git a/caching-tests/test.urs b/caching-tests/test.urs index 1fa5a9c2..d6e8dd2e 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,7 +1,8 @@ val cache : int -> transaction page -val cacheR : {Id : int, FooBar : int} -> transaction page +(* val cacheAlt : int -> transaction page *) +(* val cacheR : {Id : int, FooBar : int} -> transaction page *) (* val cache2 : int -> int -> transaction page *) val flush : int -> transaction page -val flash : int -> transaction page -val floosh : int -> transaction page +(* val flash : int -> transaction page *) +(* val floosh : int -> transaction page *) (* val flush17 : transaction page *) diff --git a/src/compiler.sig b/src/compiler.sig index c154240a..1ab0f7ae 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -114,7 +114,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase - val iflow : (Mono.file, Mono.file) phase + (* val iflow : (Mono.file, Mono.file) phase *) val namejs : (Mono.file, Mono.file) phase val scriptcheck : (Mono.file, Mono.file) phase val jscomp : (Mono.file, Mono.file) phase @@ -169,7 +169,7 @@ signature COMPILER = sig val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform - val toIflow : (string, Mono.file) transform + (* val toIflow : (string, Mono.file) transform *) val toNamejs : (string, Mono.file) transform val toNamejs_untangle : (string, Mono.file) transform val toScriptcheck : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 814c48d3..d91d02aa 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1372,19 +1372,21 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +(* val iflow = { func = (fn file => (if !doIflow then Iflow.check file else (); file)), print = MonoPrint.p_file MonoEnv.empty } val toIflow = transform iflow "iflow" o toMono_opt2 +*) val namejs = { func = NameJS.rewrite, print = MonoPrint.p_file MonoEnv.empty } -val toNamejs = transform namejs "namejs" o toIflow +val toNamejs = transform namejs "namejs" o toMono_opt2 val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs diff --git a/src/sources b/src/sources index 8bf80bc6..1436575d 100644 --- a/src/sources +++ b/src/sources @@ -207,9 +207,6 @@ $(SRC)/mono_shake.sml $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/iflow.sig -$(SRC)/iflow.sml - $(SRC)/name_js.sig $(SRC)/name_js.sml diff --git a/src/sql.sig b/src/sql.sig index 5f5d1b23..317c157f 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -81,12 +81,15 @@ datatype sitem = SqField of string * string | SqExp of sqexp * string -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} +datatype jtype = Inner | Left | Right | Full -datatype query = - Query1 of query1 +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} | Union of query * query val query : query parser diff --git a/src/sql.sml b/src/sql.sml index 08315a16..16d4210c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -382,48 +382,72 @@ val select = log "select" (wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls)) -val fitem = wrap (follow uw_ident - (follow (const " AS ") - t_ident)) - (fn (t, ((), f)) => (t, f)) +datatype jtype = Inner | Left | Right | Full -val from = log "from" - (wrap (follow (const "FROM ") (list fitem)) - (fn ((), ls) => ls)) +val jtype = wrap (ws (follow (opt (altL [wrap (const "LEFT") (fn () => Left), + wrap (const "RIGHT") (fn () => Right), + wrap (const "FULL") (fn () => Full)])) + (const " JOIN "))) + (fn (SOME jt, ()) => jt | (NONE, ()) => Inner) -val wher = wrap (follow (ws (const "WHERE ")) sqexp) - (fn ((), ls) => ls) - -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} - -val query1 = log "query1" - (wrap (follow (follow select from) (opt wher)) - (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) -datatype query = - Query1 of query1 + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} | Union of query * query +val wher = wrap (follow (ws (const "WHERE ")) sqexp) + (fn ((), ls) => ls) + val orderby = log "orderby" (wrap (follow (ws (const "ORDER BY ")) (follow (list sqexp) (opt (ws (const "DESC"))))) ignore) -fun query chs = log "query" - (wrap - (follow - (alt (wrap (follow (const "((") - (follow query - (follow (const ") UNION (") - (follow query (const "))"))))) - (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) - (wrap query1 Query1)) - (opt orderby)) - #1) - chs +fun fitem chs = altL [wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => Table (t, f)), + wrap (follow (const "(") + (follow fitem + (follow jtype + (follow fitem + (follow (const " ON ") + (follow sqexp + (const ")"))))))) + (fn ((), (fi1, (jt, (fi2, ((), (se, ())))))) => + Join (jt, fi1, fi2, se)), + wrap (follow (const "(") + (follow query + (follow (const ") AS ") t_ident))) + (fn ((), (q, ((), f))) => Nested (q, f))] + chs + +and query1 chs = log "query1" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) + chs + +and from chs = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) + chs + +and query chs = log "query" + (wrap (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (opt orderby)) + #1) + chs datatype dml = Insert of string * (string * sqexp) list diff --git a/src/sqlcache.sml b/src/sqlcache.sml index a8ef647b..9ff7c61d 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -30,11 +30,18 @@ fun mapFst f (x, y) = (f x, y) (* Option monad. *) fun obind (x, f) = Option.mapPartial f x -fun oguard (b, x) = if b then x else NONE +fun oguard (b, x) = if b then x () else NONE fun omap f = fn SOME x => SOME (f x) | _ => NONE fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE fun osequence ys = List.foldr (omap2 op::) (SOME []) ys +fun concatMap f xs = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) + (cartesianProduct xss) + fun indexOf test = let fun f n = @@ -104,10 +111,12 @@ val doBind = val dummyLoc = ErrorMsg.dummySpan (* DEBUG *) -fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp) -fun printExp' msg exp' = printExp msg (exp', dummyLoc) -fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ) -fun printTyp' msg typ' = printTyp msg (typ', dummyLoc) +fun printExp msg exp = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp) +fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp') +fun printTyp msg typ = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ) +fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ') fun obindDebug printer (x, f) = case x of NONE => NONE @@ -204,13 +213,6 @@ datatype 'atom formula' = val flipJt = fn Conj => Disj | Disj => Conj -fun concatMap f xs = List.concat (map f xs) - -val rec cartesianProduct : 'a list list -> 'a list list = - fn [] => [[]] - | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) - (cartesianProduct xss) - (* Pushes all negation to the atoms.*) fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = fn Atom x => Atom' (normalizeAtom (negating, x)) @@ -349,8 +351,12 @@ end structure AtomOptionKey = OptionKeyFn(AtomExpKey) val rec tablesOfQuery = - fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems) | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) +and tableOfFitem = + fn Sql.Table (t, _) => SS.singleton t + | Sql.Nested (q, _) => tablesOfQuery q + | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2) val tableOfDml = fn Sql.Insert (tab, _) => tab @@ -489,43 +495,60 @@ end = struct (* Need lift', etc. because we don't have rank-2 polymorphism. This should probably use a functor (an ML one, not Haskell) but works for now. *) - fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = + fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f = let val rec tr = fn Sql.SqNot se => lift Sql.SqNot (tr se) | Sql.Binop (r, se1, se2) => lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) | Sql.SqKnown se => lift Sql.SqKnown (tr se) - | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e') + | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e') | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) | se => pure se in tr end - fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f = + fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f = + let + val rec tr = + fn Sql.Table t => pure''' (Sql.Table t) + | Sql.Join (jt, fi1, fi2, se) => + lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse)) + (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se) + | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s)) + (traverseQuery ops f q) + in + tr + end + + and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f = let - val rec mp = + val rec seqList = + fn [] => pure'' [] + | (x::xs) => lift2''' op:: (x, seqList xs) + val rec tr = fn Sql.Query1 q => - (case #Where q of - NONE => pure' (Sql.Query1 q) - | SOME se => - lift' (fn mpse => Sql.Query1 {Select = #Select q, - From = #From q, - Where = SOME mpse}) - (traverseSqexp ops f se)) - | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) + (* TODO: make sure we don't need to traverse [#Select q]. *) + lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q, + From = trfrom, + Where = trwher}) + (seqList (map (traverseFitem ops f) (#From q)), + case #Where q of + NONE => pure' NONE + | SOME se => lift'' SOME (traverseSqexp ops f se)) + | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2) in - mp + tr end (* Include unused tuple elements in argument for convenience of using same argument as [traverseQuery]. *) - fun traverseIM (pure, _, _, _, _, lift2, _) f = + fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f = IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) (pure IM.empty) - fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = + fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f = let fun mp ((n, fields), sqlify) = lift (fn ((n', fields'), sqlify') => @@ -546,11 +569,14 @@ end = struct traverseIM ops (fn (_, v) => mp v) end - fun monoidOps plus zero = (fn _ => zero, fn _ => zero, - fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, - fn _ => plus, fn _ => plus) + fun monoidOps plus zero = + (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero, + fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, + fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus) - val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2) + val optionOps = (SOME, SOME, SOME, SOME, + omap, omap, omap, omap, + omap2, omap2, omap2, omap2, omap2, omap2) fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) val omapQuery = traverseQuery optionOps @@ -727,7 +753,7 @@ val rec sqexpToFormula = | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" fun mapSqexpFields f = - fn Sql.Field (t, v) => f (t, v) + fn Sql.Field (t, v) => f (t, v) | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) @@ -744,12 +770,102 @@ fun renameTables tablePairs = mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) end -fun queryToFormula marker = - fn Sql.Query1 {Select = sitems, From = tablePairs, Where = wher} => +structure FlattenQuery = struct + + datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map + + fun applySubst substTable = + let + fun substitute (table, field) = + case SM.find (substTable, table) of + NONE => Sql.Field (table, field) + | SOME (RenameTable realTable) => Sql.Field (realTable, field) + | SOME (SubstituteExp substField) => + case SM.find (substField, field) of + NONE => raise Fail "Sqlcache: applySubst" + | SOME se => se + in + mapSqexpFields substitute + end + + fun addToSubst (substTable, table, substField) = + SM.insert (substTable, + table, + case substField of + RenameTable _ => substField + | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst)) + + fun newSubst (t, s) = addToSubst (SM.empty, t, s) + + datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp + + type queryFlat = {Select : sitem' list, Where : Sql.sqexp} + + val sitemsToSubst = + List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se) + | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst") + SM.empty + + fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2) + + fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2) + + val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list = + fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))] + | Sql.Nested (q, s) => + let + val qfs = flattenQuery q + in + map (fn (qf, subst) => + (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf))))) + qfs + end + | Sql.Join (jt, fi1, fi2, se) => + concatMap (fn ((wher1, subst1)) => + map (fn (wher2, subst2) => + (sqlAnd (wher1, wher2), + (* There should be no name conflicts... Ziv hopes? *) + unionSubst (subst1, subst2))) + (flattenFitem fi2)) + (flattenFitem fi1) + + and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list = + fn Sql.Query1 q => + let + val fifss = cartesianProduct (map flattenFitem (#From q)) + in + map (fn fifs => + let + val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst)) + SM.empty + fifs + val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc)) + (case #Where q of + NONE => Sql.SqTrue + | SOME wher => wher) + fifs + in + (* ASK: do we actually need to pass the substitution through here? *) + (* We use the substitution later, but it's not clear we + need any of its currently present fields again. *) + ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s) + | Sql.SqField tf => + Unnamed (applySubst subst (Sql.Field tf))) + (#Select q), + Where = applySubst subst wher}, + subst) + end) + fifss + end + | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2) + +end + +val flattenQuery = map #1 o FlattenQuery.flattenQuery + +fun queryFlatToFormula marker {Select = sitems, Where = wher} = let - val fWhere = case wher of - NONE => Combo (Conj, []) - | SOME e => sqexpToFormula (renameTables tablePairs e) + val fWhere = sqexpToFormula wher in case marker of NONE => fWhere @@ -757,10 +873,10 @@ fun queryToFormula marker = let val fWhereMarked = mapFormulaExps markFields fWhere val toSqexp = - fn Sql.SqField tf => Sql.Field tf - | Sql.SqExp (se, _) => se + fn FlattenQuery.Named (se, _) => se + | FlattenQuery.Unnamed se => se fun ineq se = Atom (Sql.Ne, se, markFields se) - val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems) + val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems) in (Combo (Conj, [fWhere, @@ -769,7 +885,8 @@ fun queryToFormula marker = Combo (Conj, [fWhereMarked, fIneqs])])])) end end - | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2]) + +fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q)) fun valsToFormula (markLeft, markRight) (table, vals) = Combo (Conj, @@ -828,7 +945,7 @@ structure ConflictMaps = struct (* If we don't know one side of the comparision, not a contradiction. *) | _ => false in - not (List.exists contradiction atoms) <\oguard\> SOME (UF.classes uf) + not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf)) end fun addToEqs (eqs, n, e) = @@ -906,10 +1023,11 @@ structure ConflictMaps = struct mapFormula (toAtomExps DmlRel) (* No eqs should have key conflicts because no variable is in two - equivalence classes, so the [#1] could be [#2]. *) + equivalence classes. *) val mergeEqs : (atomExp IntBinaryMap.map option list -> atomExp IntBinaryMap.map option) = - List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty) + List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs"))) + (SOME IM.empty) val simplify = map TS.listItems @@ -1008,12 +1126,16 @@ fun fileAllMapfoldB doExp file start = fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) (* TODO: make this a bit prettier.... *) +(* TODO: factour out identical subexpressions to the same variable.... *) val simplifySql = let fun factorOutNontrivial text = let val loc = dummyLoc - fun strcat (e1, e2) = (EStrcat (e1, e2), loc) + val strcat = + fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1 + | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2 + | (e1, e2) => (EStrcat (e1, e2), loc) val chunks = Sql.chunkify text val (newText, newVariables) = (* Important that this is foldr (to oppose foldl below). *) @@ -1193,7 +1315,7 @@ fun shouldConsolidate args = end fun cacheExp (env, exp', invalInfo, state : state) = - case worthCaching exp' <\oguard\> typOfExp' env exp' of + case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of NONE => NONE | SOME (TFun _, _) => NONE | SOME typ => @@ -1202,26 +1324,28 @@ fun cacheExp (env, exp', invalInfo, state : state) = in shouldConsolidate args <\oguard\> - List.foldr (fn (arg, acc) => - acc - <\obind\> - (fn args' => - (case arg of - AsIs exp => SOME exp - | Urlify exp => - typOfExp env exp - <\obind\> - (fn typ => (MonoFooify.urlify env (exp, typ)))) - <\obind\> - (fn arg' => SOME (arg' :: args')))) - (SOME []) - args - <\obind\> - (fn args' => - cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + (fn _ => + List.foldr (fn (arg, acc) => + acc + <\obind\> + (fn args' => + (case arg of + AsIs exp => SOME exp + | Urlify exp => + typOfExp env exp + <\obind\> + (fn typ => (MonoFooify.urlify env (exp, typ)))) + <\obind\> + (fn arg' => SOME (arg' :: args')))) + (SOME []) + args <\obind\> - (fn cachedExp => - SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state)))) + (fn args' => + cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + <\obind\> + (fn cachedExp => + SOME (cachedExp, + InvalInfo.updateState (invalInfo, length args', state))))) end fun cacheQuery (effs, env, q) : subexp = @@ -1238,20 +1362,22 @@ fun cacheQuery (effs, env, q) : subexp = val {query = queryText, initial, body, ...} = q val attempt = (* Ziv misses Haskell's do notation.... *) - (safe 0 queryText andalso safe 0 initial andalso safe 2 body) + (safe 0 (printExp "attempt" queryText) andalso safe 0 initial andalso safe 2 body) <\oguard\> - Sql.parse Sql.query queryText - <\obind\> - (fn queryParsed => - let - val invalInfo = InvalInfo.singleton queryParsed - fun mkExp state = - case cacheExp (env, EQuery q, invalInfo, state) of - NONE => ((EQuery q, dummyLoc), state) - | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) - in - SOME (Cachable (invalInfo, mkExp)) - end) + (fn _ => + Sql.parse Sql.query (printExp "safe" queryText) + <\obind\> + (fn queryParsed => + let + val _ = (printExp "parsed" queryText) + val invalInfo = InvalInfo.singleton queryParsed + fun mkExp state = + case cacheExp (env, EQuery q, invalInfo, state) of + NONE => ((EQuery q, dummyLoc), state) + | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) + in + SOME (Cachable (invalInfo, mkExp)) + end)) in case attempt of NONE => Impure (EQuery q, dummyLoc) @@ -1279,16 +1405,16 @@ fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) (subexps, args))) <\obind\> - (fn invalInfo => - SOME (Cachable (invalInfo, - fn state => - case cacheExp (env, - f (map (#2 o #1) args), - invalInfo, - state) of - NONE => mkExp state - | SOME (e', state) => ((e', loc), state)), - state)) + (fn invalInfo => + SOME (Cachable (invalInfo, + fn state => + case cacheExp (env, + f (map (#2 o #1) args), + invalInfo, + state) of + NONE => mkExp state + | SOME (e', state) => ((e', loc), state)), + state)) in case attempt of SOME (subexp, state) => (subexp, state) @@ -1384,7 +1510,7 @@ structure Invalidations = struct DmlRel n => ERel n | Prim p => EPrim p (* TODO: make new type containing only these two. *) - | _ => raise Fail "Sqlcache: optionAtomExpToExp", + | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp", loc)), loc) @@ -1506,8 +1632,8 @@ fun addLocking file = ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls end fun locksOfName n = - lockList {store = IIMM.findSet (#flush lockMap, n), - flush =IIMM.findSet (#store lockMap, n)} + lockList {flush = IIMM.findSet (#flush lockMap, n), + store = IIMM.findSet (#store lockMap, n)} val locksOfExp = lockList o locksNeeded lockMap val expts = exports file fun doVal (v as (x, n, t, exp, s)) = -- cgit v1.2.3