Mercurial > urweb
changeset 2213:365727ff68f4
Complete overhaul: cache queries based on immediate query result, not eventual HTML output.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Tue, 14 Oct 2014 18:05:09 -0400 |
| parents | 388ba4dc7c96 |
| children | edd634b889d0 |
| files | caching-tests/test.db caching-tests/test.sql caching-tests/test.ur caching-tests/test.urp caching-tests/test.urs src/cjr_print.sml src/compiler.sig src/compiler.sml src/monoize.sig src/monoize.sml src/multimap_fn.sml src/settings.sig src/settings.sml src/sources src/sql.sig src/sql.sml src/sqlcache.sml |
| diffstat | 17 files changed, 413 insertions(+), 85 deletions(-) [+] |
line wrap: on
line diff
--- a/caching-tests/test.sql Mon Sep 15 20:01:16 2014 -0400 +++ b/caching-tests/test.sql Tue Oct 14 18:05:09 2014 -0400 @@ -8,4 +8,9 @@ ); - \ 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
--- a/caching-tests/test.ur Mon Sep 15 20:01:16 2014 -0400 +++ b/caching-tests/test.ur Tue Oct 14 18:05:09 2014 -0400 @@ -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 = +fun cache01 () = + res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); + return <xml><body> + Reading 1. + {case res of + None => <xml>?</xml> + | Some row => <xml>{[row.Foo01.Bar]}</xml>} + </body></xml> + +fun cache10 () = + res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); + return <xml><body> + Reading 2. + {case res of + None => <xml>?</xml> + | Some row => <xml>{[row.Foo10.Bar]}</xml>} + </body></xml> + +fun cache11 () = + res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); + bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); + return <xml><body> + Reading 1 and 2. + {case res of + None => <xml>?</xml> + | Some row => <xml>{[row.Foo01.Bar]}</xml>} + {case bla of + None => <xml>?</xml> + | Some row => <xml>{[row.Foo10.Bar]}</xml>} + </body></xml> + +fun flush01 () = dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); return <xml><body> Flushed 1! </body></xml> -fun flush10 () : transaction page = +fun flush10 () = dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); return <xml><body> Flushed 2! </body></xml> -fun flush11 () : transaction page = +fun flush11 () = dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); return <xml><body> Flushed 1 and 2! </body></xml> -fun cache01 () : transaction page = - res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); +fun cache id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); return <xml><body> - Reading 1. + Reading {[id]}. {case res of - None => <xml></xml> - | Some row => <xml>{[row.Foo01.Bar]}</xml>} + None => <xml>?</xml> + | Some row => <xml>{[row.Tab.Val]}</xml>} </body></xml> -fun cache10 () : transaction page = - res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); +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 <xml><body> - Reading 2. + (* Flushed {[id]}! *) {case res of - None => <xml></xml> - | Some row => <xml>{[row.Foo10.Bar]}</xml>} + None => <xml>Initialized {[id]}!</xml> + | Some row => <xml>Incremented {[id]}!</xml>} </body></xml> - -fun cache11 () : transaction page = - res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); - bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); - return <xml><body> - Reading 1 and 2. - {case res of - None => <xml></xml> - | Some row => <xml>{[row.Foo01.Bar]}</xml>} - {case bla of - None => <xml></xml> - | Some row => <xml>{[row.Foo10.Bar]}</xml>} - </body></xml>
--- a/caching-tests/test.urp Mon Sep 15 20:01:16 2014 -0400 +++ b/caching-tests/test.urp Tue Oct 14 18:05:09 2014 -0400 @@ -3,5 +3,6 @@ safeGet Test/flush01 safeGet Test/flush10 safeGet Test/flush11 +safeGet Test/flush test
--- a/caching-tests/test.urs Mon Sep 15 20:01:16 2014 -0400 +++ b/caching-tests/test.urs Tue Oct 14 18:05:09 2014 -0400 @@ -4,3 +4,5 @@ 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
--- a/src/cjr_print.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/cjr_print.sml Tue Oct 14 18:05:09 2014 -0400 @@ -3395,49 +3395,77 @@ (* 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 decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", string i, - string "(uw_context ctx) { puts(\"SQLCACHE: checked ", + string "(uw_context ctx, ", + string args, + string ") {\n puts(\"SQLCACHE: checked ", string i, - string ".\"); if (cache", + string ".\");\n if (cache", string i, - string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + (* 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 "); puts(\"SQLCACHE: used ", + string ";\n } };", + newline, + string "static uw_unit uw_Sqlcache_store", string i, - string ".\"); return uw_Basis_True; } };", + string "(uw_context ctx, uw_Basis_string s, ", + string args, + string ") {\n free(cache", + string i, + string ");", newline, - string "static uw_unit uw_Cache_store", + string frees, + newline, + string "cache", string i, - string "(uw_context ctx) { cache", + string " = strdup(s);", + newline, + string sets, + newline, + string "puts(\"SQLCACHE: stored ", string i, - string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", + string ".\"); puts(p0);\n return uw_unit_v;\n };", + newline, + string "static uw_unit uw_Sqlcache_flush", string i, - string ".\"); return uw_unit_v; };", - newline, - string "static uw_unit uw_Cache_flush", + string "(uw_context ctx) {\n free(cache", string i, - string "(uw_context ctx) { free(cache", + string ");\n cache", string i, - string "); cache", + string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string " = NULL; puts(\"SQLCACHE: flushed ", - string i, - string ".\"); return uw_unit_v; };", - newline, - string "static uw_unit uw_Cache_ready", - 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,
--- a/src/compiler.sig Mon Sep 15 20:01:16 2014 -0400 +++ b/src/compiler.sig Tue Oct 14 18:05:09 2014 -0400 @@ -199,7 +199,6 @@ val enableBoot : unit -> unit val doIflow : bool ref - val doSqlcache : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit
--- a/src/compiler.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/compiler.sml Tue Oct 14 18:05:09 2014 -0400 @@ -83,7 +83,6 @@ 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 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 }
--- a/src/monoize.sig Mon Sep 15 20:01:16 2014 -0400 +++ b/src/monoize.sig Tue Oct 14 18:05:09 2014 -0400 @@ -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
--- a/src/monoize.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/monoize.sml Tue Oct 14 18:05:09 2014 -0400 @@ -1957,20 +1957,26 @@ (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),
--- a/src/multimap_fn.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/multimap_fn.sml Tue Oct 14 18:05:09 2014 -0400 @@ -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
--- a/src/settings.sig Mon Sep 15 20:01:16 2014 -0400 +++ b/src/settings.sig Tue Oct 14 18:05:09 2014 -0400 @@ -279,6 +279,9 @@ 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. *)
--- a/src/settings.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/settings.sml Tue Oct 14 18:05:09 2014 -0400 @@ -744,6 +744,10 @@ 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
--- a/src/sources Mon Sep 15 20:01:16 2014 -0400 +++ b/src/sources Tue Oct 14 18:05:09 2014 -0400 @@ -212,6 +212,8 @@ $(SRC)/sqlcache.sig $(SRC)/sqlcache.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig
--- a/src/sql.sig Mon Sep 15 20:01:16 2014 -0400 +++ b/src/sql.sig Tue Oct 14 18:05:09 2014 -0400 @@ -2,6 +2,8 @@ val debug : bool ref +val sqlcacheMode : bool ref + type lvar = int datatype func =
--- a/src/sql.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/sql.sml Tue Oct 14 18:05:09 2014 -0400 @@ -270,6 +270,22 @@ | _ => 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 unmodeled = altL [const "COUNT(*)", const "CURRENT_TIMESTAMP"] +val sqlcacheMode = ref false; + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, @@ -292,7 +310,7 @@ 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),
--- a/src/sqlcache.sml Mon Sep 15 20:01:16 2014 -0400 +++ b/src/sqlcache.sml Tue Oct 14 18:05:09 2014 -0400 @@ -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ addCacheFlushing (fileWithChecks, tablesToIndices, writers) end +END OLD *) + end