From b1516ed386ca303a526959586f0a06564ca77bb0 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 27 May 2014 21:14:13 -0400 Subject: Finishes initial prototype, caching parameterless pages with table-match-based invalidation. Still has problems parsing non-Postgres SQL dialects properly. --- src/cjr_print.sml | 66 +++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 55 insertions(+), 11 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 05dce35e..ecd29f71 100644 --- a/src/cjr_print.sml +++ b/src/cjr_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 @@ -734,7 +734,7 @@ fun unurlify fromClient env (t, loc) = string (Int.toString (size has_arg)), string ", ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + if unboxable then unurlify' "(*request)" (#1 t) else @@ -914,7 +914,7 @@ fun unurlify fromClient env (t, loc) = space, string "4, ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + string "({", newline, p_typ env (t, loc), @@ -1188,7 +1188,7 @@ fun urlify env t = string "(ctx,", space, string "it", - string (Int.toString level), + string (Int.toString level), string ");", newline] else @@ -1388,7 +1388,7 @@ fun urlify env t = string (Int.toString level), string ");", newline]) - + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; space) in @@ -1578,7 +1578,7 @@ and p_exp' par tail env (e, loc) = newline], string "tmp;", newline, - string "})"] + string "})"] end | ENone _ => string "NULL" | ESome (t, e) => @@ -2078,7 +2078,7 @@ and p_exp' par tail env (e, loc) = space, p_exp' false false (E.pushERel (E.pushERel env "r" (TRecord rnum, loc)) - "acc" state) + "acc" state) body, string ";", newline] @@ -2102,7 +2102,7 @@ and p_exp' par tail env (e, loc) = newline, string "uw_ensure_transaction(ctx);", newline, - + case prepared of NONE => box [string "char *query = ", @@ -2187,7 +2187,7 @@ and p_exp' par tail env (e, loc) = string "uw_ensure_transaction(ctx);", newline, newline, - + #dmlPrepared (Settings.currentDbms ()) {loc = loc, id = id, dml = dml', @@ -3378,6 +3378,50 @@ fun p_file env (ds, ps) = newline, newline, + (* For caching. *) + box (List.map + (fn index => + let val i = Int.toString index + 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(\"Checked ", + string i, + string "\"); if (cache", + string i, + string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + string i, + string "); return uw_Basis_True; } };", + newline, + string "static uw_unit uw_Cache_store", + string i, + string "(uw_context ctx) { cache", + string i, + string " = uw_recordingRead(ctx); puts(\"Stored ", + string i, + string "\"); return uw_unit_v; };", + newline, + string "static uw_unit uw_Cache_flush", + string i, + string "(uw_context ctx) { free(cache", + string i, + string "); cache", + string i, + string " = NULL; puts(\"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; };", + newline, + newline] + end) + (!SqlCache.ffiIndices)), + newline, p_list_sep newline (fn x => x) pds, newline, @@ -3433,7 +3477,7 @@ fun p_file env (ds, ps) = makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()), newline, - + string "extern void uw_sign(const char *in, char *out);", newline, string "extern int uw_hash_blocksize;", @@ -3480,7 +3524,7 @@ fun p_file env (ds, ps) = newline, string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_write(ctx, jslib);", newline, -- cgit v1.2.3 From 171e5ecea687a43033e92c98c0661cc161d50e4a Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 31 May 2014 03:08:16 -0400 Subject: Cleans up interface (it's now a command line option) and renames project to "sqlcache" in the all-one-word style. Still has issues to do with concurrency, retrying transactions, and foreign function calls that either rely on state or have side effects. --- caching-tests/test.ur | 1 - src/c/urweb.c | 7 +- src/cjr_print.sml | 14 ++-- src/compiler.sig | 5 +- src/compiler.sml | 9 +-- src/main.mlton.sml | 12 ++-- src/sources | 9 +-- src/sql.sml | 20 +++--- src/sql_cache.sml | 186 -------------------------------------------------- src/sqlcache.sig | 6 ++ src/sqlcache.sml | 182 ++++++++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 227 insertions(+), 224 deletions(-) delete mode 100644 src/sql_cache.sml create mode 100644 src/sqlcache.sig create mode 100644 src/sqlcache.sml (limited to 'src/cjr_print.sml') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index d13379a8..a99a387b 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -2,7 +2,6 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id fun flush01 () : transaction page = - dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); return Flushed 1! diff --git a/src/c/urweb.c b/src/c/urweb.c index 10bbf930..57762da8 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1667,16 +1667,11 @@ void uw_write(uw_context ctx, const char* s) { } void uw_recordingStart(uw_context ctx) { - // TODO: remove following debug statement. - uw_write(ctx, ""); ctx->recording = ctx->page.front; } char *uw_recordingRead(uw_context ctx) { - char *recording = strdup(ctx->recording); - // TODO: remove following debug statement. - uw_write(ctx, ""); - return recording; + return strdup(ctx->recording); } char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { diff --git a/src/cjr_print.sml b/src/cjr_print.sml index ecd29f71..af2340fe 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3388,9 +3388,9 @@ fun p_file env (ds, ps) = newline, string "static uw_Basis_bool uw_Cache_check", string i, - string "(uw_context ctx) { puts(\"Checked ", + string "(uw_context ctx) { puts(\"Checked cache ", string i, - string "\"); if (cache", + string ".\"); if (cache", string i, string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", string i, @@ -3400,9 +3400,9 @@ fun p_file env (ds, ps) = string i, string "(uw_context ctx) { cache", string i, - string " = uw_recordingRead(ctx); puts(\"Stored ", + string " = uw_recordingRead(ctx); puts(\"Stored cache ", string i, - string "\"); return uw_unit_v; };", + string ".\"); return uw_unit_v; };", newline, string "static uw_unit uw_Cache_flush", string i, @@ -3410,9 +3410,9 @@ fun p_file env (ds, ps) = string i, string "); cache", string i, - string " = NULL; puts(\"Flushed ", + string " = NULL; puts(\"Flushed cache ", string i, - string "\"); return uw_unit_v; };", + string ".\"); return uw_unit_v; };", newline, string "static uw_unit uw_Cache_ready", string i, @@ -3420,7 +3420,7 @@ fun p_file env (ds, ps) = newline, newline] end) - (!SqlCache.ffiIndices)), + (!Sqlcache.ffiIndices)), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/compiler.sig b/src/compiler.sig index a0a653a7..81d92694 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -122,7 +122,7 @@ signature COMPILER = sig val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val sigcheck : (Mono.file, Mono.file) phase - val sqlCache : (Mono.file, Mono.file) phase + val sqlcache : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase @@ -187,7 +187,7 @@ signature COMPILER = sig val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toSigcheck : (string, Mono.file) transform - val toSqlCache : (string, Mono.file) transform + val toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform @@ -198,6 +198,7 @@ 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 cbc6478d..26e07e2a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -83,6 +83,7 @@ type ('src, 'dst) transform = { val debug = ref false val dumpSource = ref false val doIflow = ref false +val doSqlcache = ref false val doDumpSource = ref (fn () => ()) @@ -1439,19 +1440,19 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck -val sqlCache = { - func = SqlCache.go, +val sqlcache = { + func = (fn file => (if !doSqlcache then Sqlcache.go file else file)), print = MonoPrint.p_file MonoEnv.empty } -val toSqlCache = transform sqlCache "sqlCache" o toSigcheck +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSqlCache +val toCjrize = transform cjrize "cjrize" o toSqlcache val prepare = { func = Prepare.prepare, diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfc18e59..5ecd7290 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.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 @@ -47,6 +47,7 @@ fun oneRun args = Elaborate.unifyMore := false; Compiler.dumpSource := false; Compiler.doIflow := false; + Compiler.doSqlcache := false; Demo.noEmacs := false; Settings.setDebug false) @@ -64,7 +65,7 @@ fun oneRun args = fun doArgs args = case args of [] => () - | "-version" :: rest => + | "-version" :: rest => printVersion () | "-numeric-version" :: rest => printNumericVersion () @@ -159,6 +160,9 @@ fun oneRun args = | "-iflow" :: rest => (Compiler.doIflow := true; doArgs rest) + | "-sqlcache" :: rest => + (Compiler.doSqlcache := true; + doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); raise Code OS.Process.success) @@ -306,7 +310,7 @@ val () = case CommandLine.arguments () of (* Redirect the daemon's output to the socket. *) redirect Posix.FileSys.stdout; redirect Posix.FileSys.stderr; - + loop' ("", []); Socket.close sock; @@ -325,7 +329,7 @@ val () = case CommandLine.arguments () of loop () end) | ["daemon", "stop"] => - (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success) + (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success) | args => let val sock = UnixSock.Strm.socket () diff --git a/src/sources b/src/sources index b468c9a5..a87678f9 100644 --- a/src/sources +++ b/src/sources @@ -189,10 +189,6 @@ $(SRC)/fuse.sml $(SRC)/sql.sig $(SRC)/sql.sml -$(SRC)/multimap_fn.sml - -$(SRC)/sql_cache.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -211,6 +207,11 @@ $(SRC)/sidecheck.sml $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml +$(SRC)/multimap_fn.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sml b/src/sql.sml index 8642c9d2..11df715c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -177,10 +177,10 @@ val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= else NONE) -val field = wrap (follow t_ident - (follow (const ".") - uw_ident)) - (fn (t, ((), f)) => (t, f)) +val field = wrap (follow (opt (follow t_ident (const "."))) + uw_ident) + (fn (SOME (t, ()), f) => (t, f) + | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *) datatype Rel = Exps of exp * exp -> prop @@ -396,22 +396,22 @@ val insert = log "insert" val delete = log "delete" (wrap (follow (const "DELETE FROM ") (follow uw_ident - (follow (const " AS T_T WHERE ") + (follow (follow (opt (const " AS T_T")) (const " WHERE ")) sqexp))) - (fn ((), (tab, ((), es))) => (tab, es))) + (fn ((), (tab, (_, es))) => (tab, es))) val setting = log "setting" - (wrap (follow uw_ident (follow (const " = ") sqexp)) - (fn (f, ((), e)) => (f, e))) + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) val update = log "update" (wrap (follow (const "UPDATE ") (follow uw_ident - (follow (const " AS T_T SET ") + (follow (follow (opt (const " AS T_T")) (const " SET ")) (follow (list setting) (follow (ws (const "WHERE ")) sqexp))))) - (fn ((), (tab, ((), (fs, ((), e))))) => + (fn ((), (tab, (_, (fs, ((), e))))) => (tab, fs, e))) val dml = log "dml" diff --git a/src/sql_cache.sml b/src/sql_cache.sml deleted file mode 100644 index 7f9d98d0..00000000 --- a/src/sql_cache.sml +++ /dev/null @@ -1,186 +0,0 @@ -structure 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) - -val ffiIndices : int list ref = ref [] -val rs : int list ref = ref [] -val ws : int list ref = ref [] - -val rec tablesRead = - fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) - -val tableWritten = - fn Insert (tab, _) => tab - | Delete (tab, _) => tab - | Update (tab, _, _) => tab - -fun tablesInExp' exp' = - let - val nothing = {read = SS.empty, written = SS.empty} - in - case exp' of - EQuery {query=e, ...} => - (case parse query e of - SOME q => {read = tablesRead q, written = SS.empty} - | NONE => nothing) - | EDml (e, _) => - (case parse dml e of - SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} - | NONE => nothing) - | _ => nothing - end - -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 - in - MonoUtil.Exp.fold {typ = #2, exp = addTables} - {read = SS.empty, written = SS.empty} - end - -fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) -fun intTyp loc = (TFfi ("Basis", "int"), loc) -fun boolPat (b, loc) = (PCon (Enum, - PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, - con = if b then "True" else "False"}, - NONE), - loc) -fun boolTyp loc = (TFfi ("Basis", "int"), loc) - -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) - -fun sequence (befores, center, afters, loc) = - List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) - (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) - center - afters) - befores - -fun antiguardUnit (cond, exp, loc) = - (ECase (cond, - [(boolPat (false, loc), exp), - (boolPat (true, loc), (ERecord [], loc))], - {disc = boolTyp loc, result = (TRecord [], loc)}), - loc) - -fun underAbs f (exp as (exp', loc)) = - case exp' of - EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) - | _ => f exp - -fun addCacheCheck (index, exp) = - let - fun f (body as (_, loc)) = - let - val check = ffiAppExp ("Cache", "check", index, loc) - val store = ffiAppExp ("Cache", "store", index, loc) - in - antiguardUnit (check, sequence ([], body, [store], loc), loc) - end - in - underAbs f exp - end - -fun addCacheFlush (exp, tablesToIndices) = - let - fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) - fun f (body as (_, loc)) = - let - fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) - val flushes = - IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) - - in - sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) - end - in - underAbs f exp - end - -val handlerIndices = - let - val isUnit = - fn (TRecord [], _) => true - | _ => false - fun maybeAdd (d, soFar as {readers, writers}) = - case d of - DExport (Link ReadOnly, _, name, typs, typ, _) => - if List.all isUnit (typ::typs) - then {readers = IS.add (readers, name), writers = writers} - else soFar - | DExport (_, _, name, _, _, _) => (* Not read only. *) - {readers = readers, writers = IS.add (writers, name)} - | _ => soFar - in - MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} - {readers = IS.empty, writers = IS.empty} - end - -fun fileFoldMapiSelected f init (file, indices) = - let - fun doExp (original as ((a, index, b, exp, c), state)) = - if IS.member (indices, index) - then let val (newExp, newState) = f (index, exp, state) - in ((a, index, b, newExp, c), newState) end - else original - fun doDecl decl state = - let - val result = - case decl of - DVal x => - let val (y, newState) = doExp (x, state) - in (DVal y, newState) end - | DValRec xs => - let val (ys, newState) = ListUtil.foldlMap doExp state xs - in (DValRec ys, newState) end - | _ => (decl, state) - in - Search.Continue result - end - fun nada x y = Search.Continue (x, y) - in - case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of - Search.Continue x => x - | _ => (file, init) (* Should never happen. *) - end - -fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () - -val addCacheChecking = - let - fun f (index, exp, tablesToIndices) = - (addCacheCheck (index, exp), - SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) - tablesToIndices - (#read (tablesInExp exp))) - in - fileFoldMapiSelected f (SM.empty) - end - -fun addCacheFlushing (file, tablesToIndices, writers) = - fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) - -fun go file = - let - val {readers, writers} = handlerIndices file - val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) - in - rs := IS.listItems readers; - ws := IS.listItems writers; - ffiIndices := IS.listItems readers; - addCacheFlushing (fileWithChecks, tablesToIndices, writers) - end - -end diff --git a/src/sqlcache.sig b/src/sqlcache.sig new file mode 100644 index 00000000..ccc1741a --- /dev/null +++ b/src/sqlcache.sig @@ -0,0 +1,6 @@ +signature SQLCACHE = sig + +val ffiIndices : int list ref +val go : Mono.file -> Mono.file + +end diff --git a/src/sqlcache.sml b/src/sqlcache.sml new file mode 100644 index 00000000..2e7f6e42 --- /dev/null +++ b/src/sqlcache.sml @@ -0,0 +1,182 @@ +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) + +val ffiIndices : int list ref = ref [] + +val rec tablesRead = + fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + +val tableWritten = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + +fun tablesInExp' exp' = + let + val nothing = {read = SS.empty, written = SS.empty} + in + case exp' of + EQuery {query=e, ...} => + (case parse query e of + SOME q => {read = tablesRead q, written = SS.empty} + | NONE => nothing) + | EDml (e, _) => + (case parse dml e of + SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} + | NONE => nothing) + | _ => nothing + end + +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 + in + MonoUtil.Exp.fold {typ = #2, exp = addTables} + {read = SS.empty, written = SS.empty} + end + +fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) +fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun boolPat (b, loc) = (PCon (Enum, + PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, + con = if b then "True" else "False"}, + NONE), + loc) +fun boolTyp loc = (TFfi ("Basis", "int"), loc) + +fun ffiAppExp (module, func, index, loc) = + (EFfiApp (module, func ^ Int.toString index, []), loc) + +fun sequence (befores, center, afters, loc) = + List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) + (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) + center + afters) + befores + +fun antiguardUnit (cond, exp, loc) = + (ECase (cond, + [(boolPat (false, loc), exp), + (boolPat (true, loc), (ERecord [], loc))], + {disc = boolTyp loc, result = (TRecord [], loc)}), + loc) + +fun underAbs f (exp as (exp', loc)) = + case exp' of + EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) + | _ => f exp + +fun addCacheCheck (index, exp) = + let + fun f (body as (_, loc)) = + let + val check = ffiAppExp ("Cache", "check", index, loc) + val store = ffiAppExp ("Cache", "store", index, loc) + in + antiguardUnit (check, sequence ([], body, [store], loc), loc) + end + in + underAbs f exp + end + +fun addCacheFlush (exp, tablesToIndices) = + let + fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) + fun f (body as (_, loc)) = + let + fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) + val flushes = + IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) + + in + sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) + end + in + underAbs f exp + end + +val handlerIndices = + let + val isUnit = + fn (TRecord [], _) => true + | _ => false + fun maybeAdd (d, soFar as {readers, writers}) = + case d of + DExport (Link ReadOnly, _, name, typs, typ, _) => + if List.all isUnit (typ::typs) + then {readers = IS.add (readers, name), writers = writers} + else soFar + | DExport (_, _, name, _, _, _) => (* Not read only. *) + {readers = readers, writers = IS.add (writers, name)} + | _ => soFar + in + MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} + {readers = IS.empty, writers = IS.empty} + end + +fun fileFoldMapiSelected f init (file, indices) = + let + fun doExp (original as ((a, index, b, exp, c), state)) = + if IS.member (indices, index) + then let val (newExp, newState) = f (index, exp, state) + in ((a, index, b, newExp, c), newState) end + else original + fun doDecl decl state = + let + val result = + case decl of + DVal x => + let val (y, newState) = doExp (x, state) + in (DVal y, newState) end + | DValRec xs => + let val (ys, newState) = ListUtil.foldlMap doExp state xs + in (DValRec ys, newState) end + | _ => (decl, state) + in + Search.Continue result + end + fun nada x y = Search.Continue (x, y) + in + case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of + Search.Continue x => x + | _ => (file, init) (* Should never happen. *) + end + +fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () + +val addCacheChecking = + let + fun f (index, exp, tablesToIndices) = + (addCacheCheck (index, exp), + SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) + tablesToIndices + (#read (tablesInExp exp))) + in + fileFoldMapiSelected f (SM.empty) + end + +fun addCacheFlushing (file, tablesToIndices, writers) = + fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) + +fun go file = + let + val {readers, writers} = handlerIndices file + val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) + in + ffiIndices := IS.listItems readers; + addCacheFlushing (fileWithChecks, tablesToIndices, writers) + end + +end -- cgit v1.2.3 From 8cf3a275f25ffcbb97d623c4e988fdcc81ef5978 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 15 Sep 2014 20:01:16 -0400 Subject: Small cleanup. --- caching-tests/test.db | Bin 3072 -> 3072 bytes src/cjr_print.sml | 14 ++++++----- src/sql.sig | 6 +---- src/sqlcache.sml | 67 +++++++++++++++++++++++++------------------------- 4 files changed, 42 insertions(+), 45 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db index 190d2868..a5c91e8f 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b2e8d2a7..8ca35234 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3393,7 +3393,7 @@ fun p_file env (ds, ps) = newline, newline, - (* For caching. *) + (* For sqlcache. *) box (List.map (fn index => let val i = Int.toString index @@ -3403,19 +3403,21 @@ fun p_file env (ds, ps) = newline, string "static uw_Basis_bool uw_Cache_check", string i, - string "(uw_context ctx) { puts(\"Checked cache ", + string "(uw_context ctx) { puts(\"SQLCACHE: checked ", string i, string ".\"); if (cache", string i, string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", string i, - string "); return uw_Basis_True; } };", + string "); puts(\"SQLCACHE: used ", + string i, + string ".\"); return uw_Basis_True; } };", newline, string "static uw_unit uw_Cache_store", string i, string "(uw_context ctx) { cache", string i, - string " = uw_recordingRead(ctx); puts(\"Stored cache ", + string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", string i, string ".\"); return uw_unit_v; };", newline, @@ -3425,7 +3427,7 @@ fun p_file env (ds, ps) = string i, string "); cache", string i, - string " = NULL; puts(\"Flushed cache ", + string " = NULL; puts(\"SQLCACHE: flushed ", string i, string ".\"); return uw_unit_v; };", newline, @@ -3564,7 +3566,7 @@ fun p_file env (ds, ps) = newline, string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_replace_page(ctx, \"", string (hexify (#Bytes r)), diff --git a/src/sql.sig b/src/sql.sig index 573a8baf..2623f5e7 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -39,11 +39,7 @@ datatype prop = | Reln of reln * exp list | Cond of exp * prop -datatype chunk = - String of string - | Exp of Mono.exp - -type 'a parser = chunk list -> ('a * chunk list) option +type 'a parser val parse : 'a parser -> Mono.exp -> 'a option diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 2e7f6e42..b01de4c9 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -12,6 +12,37 @@ structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) val ffiIndices : int list ref = ref [] +(* Expression construction utilities. *) + +fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) +fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun boolPat (b, loc) = (PCon (Enum, + PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, + con = if b then "True" else "False"}, + NONE), + loc) +fun boolTyp loc = (TFfi ("Basis", "int"), loc) + +fun ffiAppExp (module, func, index, loc) = + (EFfiApp (module, func ^ Int.toString index, []), loc) + +fun sequence ((exp :: exps), loc) = + List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps + +fun antiguardUnit (cond, exp, loc) = + (ECase (cond, + [(boolPat (false, loc), exp), + (boolPat (true, loc), (ERecord [], loc))], + {disc = boolTyp loc, result = (TRecord [], loc)}), + loc) + +fun underAbs f (exp as (exp', loc)) = + case exp' of + 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) @@ -47,37 +78,6 @@ val tablesInExp = {read = SS.empty, written = SS.empty} end -fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) -fun intTyp loc = (TFfi ("Basis", "int"), loc) -fun boolPat (b, loc) = (PCon (Enum, - PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, - con = if b then "True" else "False"}, - NONE), - loc) -fun boolTyp loc = (TFfi ("Basis", "int"), loc) - -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) - -fun sequence (befores, center, afters, loc) = - List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) - (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) - center - afters) - befores - -fun antiguardUnit (cond, exp, loc) = - (ECase (cond, - [(boolPat (false, loc), exp), - (boolPat (true, loc), (ERecord [], loc))], - {disc = boolTyp loc, result = (TRecord [], loc)}), - loc) - -fun underAbs f (exp as (exp', loc)) = - case exp' of - EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) - | _ => f exp - fun addCacheCheck (index, exp) = let fun f (body as (_, loc)) = @@ -85,7 +85,7 @@ fun addCacheCheck (index, exp) = val check = ffiAppExp ("Cache", "check", index, loc) val store = ffiAppExp ("Cache", "store", index, loc) in - antiguardUnit (check, sequence ([], body, [store], loc), loc) + antiguardUnit (check, sequence ([body, store], loc), loc) end in underAbs f exp @@ -99,9 +99,8 @@ fun addCacheFlush (exp, tablesToIndices) = fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) val flushes = IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) - in - sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) + sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc) end in underAbs f exp -- 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 'src/cjr_print.sml') 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 7b94f3433f47e4e5010dc2af6010181da49637e8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 31 Oct 2014 09:25:03 -0400 Subject: Mostly finish effectfulness analysis. --- caching-tests/test.db | Bin 5120 -> 5120 bytes caching-tests/test.ur | 7 +- src/cjr_print.sml | 29 +++++-- src/main.mlton.sml | 3 +- src/sources | 16 ++-- src/sql.sig | 6 ++ src/sql.sml | 8 +- src/sqlcache.sml | 225 ++++++++++++++++++++++++++++++++++++++++++++------ 8 files changed, 242 insertions(+), 52 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db index 944aa851..66b6ad88 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/caching-tests/test.ur b/caching-tests/test.ur index cb391da7..06ed456c 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -12,12 +12,11 @@ fun cache01 () = fun cache10 () = - res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); + res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) + (fn row => {[row.Foo10.Bar]}); return Reading 2. - {case res of - None => ? - | Some row => {[row.Foo10.Bar]}} + {res} fun cache11 () = diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 6427cf3d..c150631c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3394,6 +3394,7 @@ fun p_file env (ds, ps) = newline, (* For sqlcache. *) + (* TODO: also record between Cache.check and Cache.store. *) box (List.map (fn {index, params} => let val i = Int.toString index @@ -3412,7 +3413,11 @@ fun p_file env (ds, ps) = 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", + in box [string "static char *cacheQuery", + string i, + string " = NULL;", + newline, + string "static char *cacheWrite", string i, string " = NULL;", newline, @@ -3424,12 +3429,14 @@ fun p_file env (ds, ps) = string args, string ") {\n puts(\"SQLCACHE: checked ", string i, - string ".\");\n if (cache", + string ".\");\n if (cacheQuery", string i, (* 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 ") {\n puts(\"miss D:\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"hit :D\");\n uw_write(ctx, cacheWrite", + string i, + string ");\n return cacheQuery", string i, string ";\n } };", newline, @@ -3437,27 +3444,31 @@ fun p_file env (ds, ps) = string i, string "(uw_context ctx, uw_Basis_string s, ", string args, - string ") {\n free(cache", + string ") {\n free(cacheQuery", + string i, + string "); free(cacheWrite", string i, string ");", newline, string frees, newline, - string "cache", + string "cacheQuery", + string i, + string " = strdup(s); cacheWrite", string i, - string " = strdup(s);", + string " = uw_recordingRead(ctx);", newline, string sets, newline, string "puts(\"SQLCACHE: stored ", string i, - string ".\"); puts(p0);\n return uw_unit_v;\n };", + string ".\");\n return uw_unit_v;\n };", newline, string "static uw_unit uw_Sqlcache_flush", string i, - string "(uw_context ctx) {\n free(cache", + string "(uw_context ctx) {\n free(cacheQuery", string i, - string ");\n cache", + string ");\n cacheQuery", string i, string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 5ecd7290..3ae968b0 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -47,7 +47,6 @@ fun oneRun args = Elaborate.unifyMore := false; Compiler.dumpSource := false; Compiler.doIflow := false; - Compiler.doSqlcache := false; Demo.noEmacs := false; Settings.setDebug false) @@ -161,7 +160,7 @@ fun oneRun args = (Compiler.doIflow := true; doArgs rest) | "-sqlcache" :: rest => - (Compiler.doSqlcache := true; + (Settings.setSqlcache true; doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); diff --git a/src/sources b/src/sources index 518b7484..7ad60517 100644 --- a/src/sources +++ b/src/sources @@ -168,6 +168,14 @@ $(SRC)/mono_env.sml $(SRC)/mono_print.sig $(SRC)/mono_print.sml +$(SRC)/sql.sig +$(SRC)/sql.sml + +$(SRC)/multimap_fn.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/monoize.sig $(SRC)/monoize.sml @@ -186,9 +194,6 @@ $(SRC)/mono_shake.sml $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/sql.sig -$(SRC)/sql.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -207,11 +212,6 @@ $(SRC)/sidecheck.sml $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml -$(SRC)/multimap_fn.sml - -$(SRC)/sqlcache.sig -$(SRC)/sqlcache.sml - $(SRC)/mono_inline.sml $(SRC)/cjr.sml diff --git a/src/sql.sig b/src/sql.sig index 2aba8383..cf2ae14a 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -4,6 +4,12 @@ val debug : bool ref val sqlcacheMode : bool ref +datatype chunk = + String of string + | Exp of Mono.exp + +val chunkify : Mono.exp -> chunk list + type lvar = int datatype func = diff --git a/src/sql.sml b/src/sql.sml index d38de055..7cfed022 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -272,10 +272,12 @@ fun sqlify chs = fun sqlifySqlcache chs = case chs of - (* Match entire FFI application, not just its argument. *) - Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs => + (* Could have variables as well as FFIs. *) + Exp (e as (ERel _, _)) :: chs => SOME (e, chs) + (* If it is an FFI, match the entire expression. *) + | Exp (e as (EFfiApp ("Basis", f, [(_, _)]), _)) :: chs => if String.isPrefix "sqlify" f then - SOME ((e', ErrorMsg.dummySpan), chs) + SOME (e, chs) else NONE | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 563b2162..d3c21371 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -15,10 +15,127 @@ val ffiInfo : {index : int, params : int} list ref = ref [] fun getFfiInfo () = !ffiInfo -(* Program analysis. *) +(* Some FFIs have writing as their only effect, which the caching records. *) +val ffiEffectful = + let + val fs = SS.fromList ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "urlifyChannel_w"] + in + fn (m, f) => Settings.isEffectful (m, f) + andalso not (m = "Basis" andalso SS.member (fs, f)) + end + + +(* Effect analysis. *) + +(* Makes an exception for EWrite (which is recorded when caching). *) +fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = + (* If result is true, expression is definitely effectful. If result is + false, then expression is definitely not effectful if effs is fully + populated. The intended pattern is to use this a number of times equal + to the number of declarations in a file, Bellman-Ford style. *) + (* TODO: make incrementing of bound less janky, probably by using MonoUtil + instead of all this. *) + let + (* DEBUG: remove printing when done. *) + fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true + val rec eff' = + (* ASK: is there a better way? *) + fn EPrim _ => false + (* We don't know if local functions have effects when applied. *) + | ERel idx => if inFunction andalso idx >= bound + then tru ("rel" ^ Int.toString idx) else false + | ENamed name => if IS.member (effs, name) then tru "named" else false + | ECon (_, _, NONE) => false + | ECon (_, _, SOME e) => eff e + | ENone _ => false + | ESome (_, e) => eff e + (* TODO: use FFI whitelist. *) + | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false + | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false + (* ASK: we're calling functions effectful if they have effects when + applied or if the function expressions themselves have effects. + Is that okay? *) + (* This is okay because the values we ultimately care about aren't + functions, and this is a conservative approximation, anyway. *) + | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg + | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e + | EUnop (_, e) => eff e + | EBinop (_, _, e1, e2) => eff e1 orelse eff e2 + | ERecord xs => List.exists (fn (_, e, _) => eff e) xs + | EField (e, _) => eff e + (* If any case could be effectful, consider it effectful. *) + | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs + | EStrcat (e1, e2) => eff e1 orelse eff e2 + (* ASK: how should we treat these three? *) + | EError _ => tru "error" + | EReturnBlob _ => tru "blob" + | ERedirect _ => tru "redirect" + (* EWrite is a special exception because we record writes when caching. *) + | EWrite _ => false + | ESeq (e1, e2) => eff e1 orelse eff e2 + (* TODO: keep context of which local variables aren't effectful? Only + makes a difference for function expressions, though. *) + | ELet (_, _, eBind, eBody) => eff eBind orelse + effectful doPrint effs inFunction (bound+1) eBody + | EClosure (_, es) => List.exists eff es + (* TODO: deal with EQuery. *) + | EQuery _ => tru "query" + | EDml _ => tru "dml" + | ENextval _ => tru "nextval" + | ESetval _ => tru "setval" + | EUnurlify (e, _, _) => eff e + (* ASK: how should we treat this? *) + | EJavaScript _ => tru "javascript" + (* ASK: these are all effectful, right? *) + | ESignalReturn _ => tru "signalreturn" + | ESignalBind _ => tru "signalbind" + | ESignalSource _ => tru "signalsource" + | EServerCall _ => tru "servercall" + | ERecv _ => tru "recv" + | ESleep _ => tru "sleep" + | ESpawn _ => tru "spawn" + and eff = fn (e', _) => eff' e' + in + eff + end + +(* TODO: test this. *) +val effectfulMap = + let + fun doVal ((_, name, _, e, _), effMap) = + if effectful false effMap false 0 e + then IS.add (effMap, name) + else effMap + val doDecl = + fn (DVal v, effMap) => doVal (v, effMap) + (* Repeat the list of declarations a number of times equal to its size. *) + | (DValRec vs, effMap) => + List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs)) + (* ASK: any other cases? *) + | (_, effMap) => effMap + in + MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty + end + + +(* SQL analysis. *) val useInjIfPossible = - fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan) + fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), + ErrorMsg.dummySpan) | sqexp => sqexp fun equalities (canonicalTable : string -> string) : @@ -89,6 +206,7 @@ val tableDml = (* Program instrumentation. *) +fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan) val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) val sequence = @@ -103,7 +221,7 @@ val sequence = fun ffiAppCache' (func, index, args) : Mono.exp' = EFfiApp ("Sqlcache", func ^ Int.toString index, args) -fun ffiAppCache (func, index, args) : Mono. exp = +fun ffiAppCache (func, index, args) : Mono.exp = (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) val varPrefix = "queryResult" @@ -113,7 +231,17 @@ fun indexOfName 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} +(* Always increments negative indices because that's what we need later. *) +fun incRelsBound bound inc = + MonoUtil.Exp.mapB + {typ = fn x => x, + exp = fn level => + (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n) + | x => x), + bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level} + bound + +val incRels = incRelsBound 0 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty @@ -129,12 +257,11 @@ val instrumentQuery = 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? *) + (* TODO: thread a Monoize.Fm.t through this module. *) (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), (ERel 0, loc)), loc)), @@ -145,28 +272,26 @@ val instrumentQuery = 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 () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo 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 + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val args = map (fn (_, e) => (e, stringTyp)) eqs + val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args + val check = ffiAppCache ("check", i, args) + val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc) + val rel0 = (ERel 0, loc) in - (ECase (ffiAppCache ("check", i, args), + (ECase (check, [((PNone stringTyp, loc), - (ELet ("q", typ, query, - (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc), - (ERel 0, loc)), - loc)), - loc)), + (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)), ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), - (* ASK: what does this bool do? *) - (EUnurlify ((ERel 0, loc), typ, false), loc))], + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, typ, false), loc))], {disc = stringTyp, result = typ}), loc) end @@ -181,20 +306,66 @@ fun fileMapfold doExp file start = fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) -val addChecking = +fun addChecking file = let fun doExp queryInfo = - fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) => + fn e' as ELet (v, t, + queryExp' as (EQuery {query = origQueryText, + initial, body, state, tables, exps}, queryLoc), + letBody) => let + val loc = ErrorMsg.dummySpan + val chunks = 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)) => + case chunk of + Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars) + | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars) + (* Head of newVars has lowest index. *) + | 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 + | 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 + (* Increment once for each new variable just made. *) + val queryExp = incRels (length newVariables) + (EQuery {query = newQueryText, + initial = initial, + body = body, + state = state, + tables = tables, + exps = exps}, + queryLoc) + val (EQuery {query = queryText, ...}, _) = queryExp + (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *) 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. *) + fun safe bound = not o effectful true (effectfulMap file) false bound val attempt = (* Ziv misses Haskell's do notation.... *) + guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( 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), + SOME (wrapLets (ELet (v, t, + cacheWrap (queryExp, i, urlifiedRel0, eqs), + incRelsBound 1 (length newVariables) letBody)), SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) queryInfo (tablesQuery queryParsed))))))) @@ -206,7 +377,7 @@ val addChecking = | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) | e' => (e', queryInfo) in - fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty + fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty end fun addFlushing (file, queryInfo) = @@ -231,8 +402,10 @@ fun addFlushing (file, queryInfo) = fun go file = let val () = Sql.sqlcacheMode := true + val file' = addFlushing (addChecking file) + val () = Sql.sqlcacheMode := false in - addFlushing (addChecking file) before Sql.sqlcacheMode := false + file' end -- cgit v1.2.3 From dc5e7102563b9c0714391f86b6dcf852445ee192 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 10 Nov 2014 22:04:40 -0500 Subject: Progress towards invalidation based on equalities of fields. --- caching-tests/test.db | Bin 5120 -> 5120 bytes src/cjr_print.sml | 23 ++- src/iflow.sml | 116 ++++++------ src/sources | 2 + src/sql.sig | 26 +-- src/sql.sml | 32 ++-- src/sqlcache.sml | 474 ++++++++++++++++++++++---------------------------- src/union_find_fn.sml | 47 +++++ 8 files changed, 368 insertions(+), 352 deletions(-) create mode 100644 src/union_find_fn.sml (limited to 'src/cjr_print.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db index 66b6ad88..a4661341 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c150631c..56310b81 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3400,19 +3400,24 @@ fun p_file env (ds, ps) = 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) + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else f (n-1) ^ sep ^ itemi (Int.toString n) in f (params - 1) end - val args = paramRepeat (fn p => "uw_Basis_string p" ^ p) ", " + 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 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 ^ ")") " || " + (* Starting || makes logic easier when there are no parameters. *) + val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") + " || " in box [string "static char *cacheQuery", string i, string " = NULL;", @@ -3425,14 +3430,14 @@ fun p_file env (ds, ps) = newline, string "static uw_Basis_string uw_Sqlcache_check", string i, - string "(uw_context ctx, ", + string "(uw_context ctx", string args, string ") {\n puts(\"SQLCACHE: checked ", string i, string ".\");\n if (cacheQuery", string i, (* ASK: is returning the pointer okay? Should we duplicate? *) - string " == NULL || ", + string " == NULL", string eqs, string ") {\n puts(\"miss D:\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"hit :D\");\n uw_write(ctx, cacheWrite", string i, @@ -3442,7 +3447,7 @@ fun p_file env (ds, ps) = newline, string "static uw_unit uw_Sqlcache_store", string i, - string "(uw_context ctx, uw_Basis_string s, ", + string "(uw_context ctx, uw_Basis_string s", string args, string ") {\n free(cacheQuery", string i, diff --git a/src/iflow.sml b/src/iflow.sml index 40cf8993..f68d8f72 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -115,36 +115,36 @@ fun p_reln r es = | PCon1 s => box [string (s ^ "("), p_list p_exp es, string ")"] - | Eq => p_bop "=" es - | Ne => p_bop "<>" es - | Lt => p_bop "<" es - | Le => p_bop "<=" es - | Gt => p_bop ">" es - | Ge => p_bop ">=" es + | Cmp Eq => p_bop "=" es + | Cmp Ne => p_bop "<>" es + | Cmp Lt => p_bop "<" es + | Cmp Le => p_bop "<=" es + | Cmp Gt => p_bop ">" es + | Cmp Ge => p_bop ">=" es fun p_prop p = case p of True => string "True" | False => string "False" | Unknown => string "??" - | And (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "&&", - space, - string "(", - p_prop p2, - string ")"] - | Or (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "||", - space, - string "(", - p_prop p2, - string ")"] + | Lop (And, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Lop (Or, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] | Reln (r, es) => p_reln r es | Cond (e, p) => box [string "(", p_exp e, @@ -518,7 +518,7 @@ fun representative (db : database, e) = Variety = Nothing, Known = ref (!(#Known (unNode r))), Ge = ref NONE}) - + val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), @@ -529,7 +529,7 @@ fun representative (db : database, e) = #Rep (unNode r) := SOME r''; r' end - | _ => raise Contradiction + | _ => raise Contradiction end in rep e @@ -687,9 +687,9 @@ fun assert (db, a) = end | _ => raise Contradiction end - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -734,14 +734,14 @@ fun check (db, a) = (case #Variety (unNode (representative (db, e))) of Dt1 (f', _) => f' = f | _ => false) - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) in repOf r1 = repOf r2 end - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -848,7 +848,7 @@ fun setHyps (n', hs) = (hyps := (n', hs, ref false); Cc.clear db; app (fn a => Cc.assert (db, a)) hs) - end + end fun useKeys () = let @@ -872,7 +872,7 @@ fun useKeys () = let val r = Cc.check (db, - AReln (Eq, [Proj (r1, f), + AReln (Cmp Eq, [Proj (r1, f), Proj (r2, f)])) in (*Print.prefaces "Fs" @@ -888,7 +888,7 @@ fun useKeys () = r end)) ks then (changed := true; - Cc.assert (db, AReln (Eq, [r1, r2])); + Cc.assert (db, AReln (Cmp Eq, [r1, r2])); finder (hyps, acc)) else finder (hyps, a :: acc) @@ -1115,7 +1115,7 @@ fun havocCookie cname = val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) end fun check a = Cc.check (db, a) @@ -1138,7 +1138,7 @@ fun removeDups (ls : (string * string) list) = val ls = removeDups ls in if List.exists (fn x' => x' = x) ls then - ls + ls else x :: ls end @@ -1171,7 +1171,7 @@ fun expIn rv env rvOf = | Null => inl (Func (DtCon0 "None", [])) | SqNot e => inr (case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) | inr _ => Unknown) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () @@ -1181,15 +1181,15 @@ fun expIn rv env rvOf = val e2 = expIn e2 in inr (case (bo, e1, e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, v1, v2) => + (RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2]) + | (RLop l, v1, v2) => let fun pin v = case v of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p in - f (pin v1, pin v2) + Lop (l, pin v1, pin v2) end | _ => Unknown) end @@ -1205,7 +1205,7 @@ fun expIn rv env rvOf = (case expIn e of inl e => inl (Func (Other f, [e])) | _ => default ()) - + | Unmodeled => inl (Func (Other "allow", [rv ()])) end in @@ -1219,8 +1219,8 @@ fun decomp {Save = save, Restore = restore, Add = add} = True => (k () handle Cc.Contradiction => ()) | False => () | Unknown => () - | And (p1, p2) => go p1 (fn () => go p2 k) - | Or (p1, p2) => + | Lop (And, p1, p2) => go p1 (fn () => go p2 k) + | Lop (Or, p1, p2) => let val saved = save () in @@ -1351,7 +1351,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = | SOME e => let val p = case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p val saved = #Save arg () @@ -1365,9 +1365,9 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun normal () = doWhere normal' in (case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + [SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo of + Gt => (case #Cont arg of SomeCol _ => () | AllCols k => @@ -1469,7 +1469,7 @@ fun evalExp env (e as (_, loc)) k = evalExp env e (fn e => doArgs (es, e :: acc)) in doArgs (es, []) - end + end in case #1 e of EPrim p => k (Const p) @@ -1519,7 +1519,7 @@ fun evalExp env (e as (_, loc)) k = ([], []) => (evalExp env' (#body rf) (fn _ => ()); St.reinstate saved; default ()) - + | (arg :: args, mode :: modes) => evalExp env arg (fn arg => let @@ -1663,7 +1663,7 @@ fun evalExp env (e as (_, loc)) k = Save = St.stash, Restore = St.reinstate, Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; + (St.assert [AReln (Cmp Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q end) | EDml (e, _) => @@ -1697,15 +1697,15 @@ fun evalExp env (e as (_, loc)) k = | Delete (tab, e) => let val old = St.nextVar () - + val expIn = expIn (Var o St.nextVar) env (fn "T" => Var old | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" | inr p => p - + val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), @@ -1748,7 +1748,7 @@ fun evalExp env (e as (_, loc)) k = (f, Proj (Var old, f)) :: fs) fs fs' val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" | inr p => p val saved = St.stash () in @@ -1764,7 +1764,7 @@ fun evalExp env (e as (_, loc)) k = k (Recd [])) handle Cc.Contradiction => ()) end) - + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () @@ -1780,7 +1780,7 @@ fun evalExp env (e as (_, loc)) k = val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) in - St.assert [AReln (Known, [e]), AReln (Eq, [e, e'])]; + St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])]; k e end @@ -2159,7 +2159,7 @@ fun check (file : file) = end | _ => ()) end - + | _ => () in app decl (#1 file) diff --git a/src/sources b/src/sources index 7ad60517..33c01f94 100644 --- a/src/sources +++ b/src/sources @@ -171,6 +171,8 @@ $(SRC)/mono_print.sml $(SRC)/sql.sig $(SRC)/sql.sml +$(SRC)/union_find_fn.sml + $(SRC)/multimap_fn.sml $(SRC)/sqlcache.sig diff --git a/src/sql.sig b/src/sql.sig index cf2ae14a..5f5d1b23 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -26,24 +26,30 @@ datatype exp = | Recd of (string * exp) list | Proj of exp * string -datatype reln = - Known - | Sql of string - | PCon0 of string - | PCon1 of string - | Eq +datatype cmp = + Eq | Ne | Lt | Le | Gt | Ge +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + datatype prop = True | False | Unknown - | And of prop * prop - | Or of prop * prop + | Lop of lop * prop * prop | Reln of reln * exp list | Cond of exp * prop @@ -52,8 +58,8 @@ type 'a parser val parse : 'a parser -> Mono.exp -> 'a option datatype Rel = - Exps of exp * exp -> prop - | Props of prop * prop -> prop + RCmp of cmp + | RLop of lop datatype sqexp = SqConst of Prim.t diff --git a/src/sql.sml b/src/sql.sml index 7cfed022..59b4eac6 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -20,24 +20,30 @@ datatype exp = | Recd of (string * exp) list | Proj of exp * string -datatype reln = - Known - | Sql of string - | PCon0 of string - | PCon1 of string - | Eq +datatype cmp = + Eq | Ne | Lt | Le | Gt | Ge +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + datatype prop = True | False | Unknown - | And of prop * prop - | Or of prop * prop + | Lop of lop * prop * prop | Reln of reln * exp list | Cond of exp * prop @@ -183,8 +189,8 @@ val field = wrap (follow (opt (follow t_ident (const "."))) | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *) datatype Rel = - Exps of exp * exp -> prop - | Props of prop * prop -> prop + RCmp of cmp + | RLop of lop datatype sqexp = SqConst of Prim.t @@ -200,7 +206,7 @@ datatype sqexp = | Unmodeled | Null -fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) +fun cmp s r = wrap (const s) (fn () => RCmp r) val sqbrel = altL [cmp "=" Eq, cmp "<>" Ne, @@ -208,8 +214,8 @@ val sqbrel = altL [cmp "=" Eq, cmp "<" Lt, cmp ">=" Ge, cmp ">" Gt, - wrap (const "AND") (fn () => Props And), - wrap (const "OR") (fn () => Props Or)] + wrap (const "AND") (fn () => RLop Or), + wrap (const "OR") (fn () => RLop And)] datatype ('a, 'b) sum = inl of 'a | inr of 'b diff --git a/src/sqlcache.sml b/src/sqlcache.sml index d3c21371..59800ca3 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,6 +1,5 @@ structure Sqlcache (* :> SQLCACHE *) = struct -open Sql open Mono structure IS = IntBinarySet @@ -10,13 +9,14 @@ structure SS = BinarySetFn(SK) structure SM = BinaryMapFn(SK) structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) -(* Filled in by cacheWrap during Sqlcache. *) +(* Filled in by [cacheWrap] during [Sqlcache]. *) val ffiInfo : {index : int, params : int} list ref = ref [] fun getFfiInfo () = !ffiInfo (* Some FFIs have writing as their only effect, which the caching records. *) val ffiEffectful = + (* TODO: have this less hard-coded. *) let val fs = SS.fromList ["htmlifyInt_w", "htmlifyFloat_w", @@ -40,7 +40,7 @@ val ffiEffectful = (* Effect analysis. *) -(* Makes an exception for EWrite (which is recorded when caching). *) +(* Makes an exception for [EWrite] (which is recorded when caching). *) fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = (* If result is true, expression is definitely effectful. If result is false, then expression is definitely not effectful if effs is fully @@ -62,7 +62,6 @@ fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.e | ECon (_, _, SOME e) => eff e | ENone _ => false | ESome (_, e) => eff e - (* TODO: use FFI whitelist. *) | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false (* ASK: we're calling functions effectful if they have effects when @@ -131,82 +130,188 @@ val effectfulMap = end +(* Boolean formula normalization. *) + +datatype normalForm = Cnf | Dnf + +datatype 'atom formula = + Atom of 'atom + | Negate of 'atom formula + | Combo of normalForm * 'atom formula list + +val flipNf = fn Cnf => Dnf | Dnf => Cnf + +fun bind xs f = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => bind (cartesianProduct xss) + (fn ys => bind xs (fn x => [x :: ys])) + +fun normalize (negate : 'atom -> 'atom) (norm : normalForm) = + fn Atom x => [[x]] + | Negate f => map (map negate) (normalize negate (flipNf norm) f) + | Combo (n, fs) => + let + val fss = bind fs (normalize negate n) + in + if n = norm then fss else cartesianProduct fss + end + +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. *) -val useInjIfPossible = - fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), - ErrorMsg.dummySpan) - | sqexp => sqexp +val rec chooseTwos : 'a list -> ('a * 'a) list = + fn [] => [] + | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys + +datatype atomExp = + QueryArg of int + | DmlRel of int + | Prim of Prim.t + | Field of string * string -fun equalities (canonicalTable : string -> string) : - sqexp -> ((string * string) * Mono.exp) list option = +structure AtomExpKey : ORD_KEY = struct + +type ord_key = atomExp + +val compare = + fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) + | (QueryArg _, _) => LESS + | (_, QueryArg _) => GREATER + | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) + | (DmlRel _, _) => LESS + | (_, DmlRel _) => GREATER + | (Prim p1, Prim p2) => Prim.compare (p1, p2) + | (Prim _, _) => LESS + | (_, Prim _) => GREATER + | (Field (t1, f1), Field (t2, f2)) => String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2) + +end + +structure UF = UnionFindFn(AtomExpKey) + +fun conflictMaps (fQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula, + fDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula) = 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) + 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 + okay in disjunctive normal form. *) + fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2) | _ => NONE + val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list = + UF.classes + o List.foldl UF.union' UF.empty + o List.mapPartial toKnownEquality + fun addToEqs (eqs, n, e) = + case IM.find (eqs, n) of + (* Comparing to a constant seems better? *) + SOME (EPrim _) => eqs + | _ => IM.insert (eqs, n, e) + val accumulateEqs = + (* [NONE] means we have a contradiction. *) + fn (_, NONE) => NONE + | ((Prim p1, Prim p2), eqso) => + (case Prim.compare (p1, p2) of + EQUAL => eqso + | _ => NONE) + | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, EPrim p)) + | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, ERel r)) + | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, EPrim p)) + | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, ERel r)) + (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. *) + | (_, eqso) => eqso + val eqsOfClass : atomExp list -> Mono.exp' IM.map option = + List.foldl accumulateEqs (SOME IM.empty) + o chooseTwos + fun toAtomExps rel (cmp, e1, e2) = + let + val qa = + (* Here [NONE] means unkown. *) + fn Sql.SqConst p => SOME (Prim p) + | Sql.Field tf => SOME (Field tf) + | Sql.Inj (EPrim p, _) => SOME (Prim p) + | Sql.Inj (ERel n, _) => SOME (rel n) + (* We can't deal with anything else. *) + | _ => NONE + in + (cmp, qa e1, qa e2) + end + fun negateCmp (cmp, e1, e2) = + (case cmp of + Sql.Eq => Sql.Ne + | Sql.Ne => Sql.Eq + | Sql.Lt => Sql.Ge + | Sql.Le => Sql.Gt + | Sql.Gt => Sql.Le + | Sql.Ge => Sql.Lt, + e1, e2) + val markQuery = mapFormula (toAtomExps QueryArg) + val markDml = mapFormula (toAtomExps DmlRel) + val dnf = normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml])) + (* If one of the terms in a conjunction leads to a contradiction, which + is represented by [NONE], drop the entire conjunction. *) + val sequenceOption = List.foldr (fn (SOME x, SOME xs) => SOME (x :: xs) | _ => NONE) + (SOME []) in - eqs + List.mapPartial (sequenceOption o map eqsOfClass o equivClasses) dnf 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 sqexpToFormula = + fn Sql.SqTrue => Combo (Cnf, []) + | Sql.SqFalse => Combo (Dnf, []) + | Sql.SqNot e => Negate (sqexpToFormula e) + | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) + | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Cnf | Sql.Or => Dnf, + [sqexpToFormula p1, sqexpToFormula p2]) + (* ASK: any other sqexps that can be props? *) + | _ => raise Match + +val rec queryToFormula = + fn Sql.Query1 {From = tablePairs, Where = NONE, ...} => Combo (Cnf, []) + | Sql.Query1 {From = tablePairs, Where = SOME e, ...} => + let + fun renameString 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 + mapFormula renameAtom (sqexpToFormula e) + end + | Sql.Union (q1, q2) => Combo (Dnf, [queryToFormula q1, queryToFormula q2]) + +val rec dmlToFormula = + fn Sql.Insert (table, vals) => + Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) + | Sql.Delete (_, wher) => sqexpToFormula wher + (* TODO: refine formula for the vals part, which could take into account the wher part. *) + | Sql.Update (table, vals, wher) => Combo (Dnf, [dmlToFormula (Sql.Insert (table, vals)), + dmlToFormula (Sql.Delete (table, wher))]) val rec tablesQuery = - fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) + fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) val tableDml = - fn Insert (tab, _) => tab - | Delete (tab, _) => tab - | Update (tab, _, _) => tab + fn Sql.Insert (tab, _) => tab + | Sql.Delete (tab, _) => tab + | Sql.Update (tab, _, _) => tab (* Program instrumentation. *) fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan) + val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) val sequence = @@ -243,10 +348,10 @@ fun incRelsBound bound inc = val incRels = incRelsBound 0 -(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) +(* Filled in by instrumentQuery during [Monoize], used during [Sqlcache]. *) val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty -(* Used by Monoize. *) +(* Used by [Monoize]. *) val instrumentQuery = let val nextQuery = ref 0 @@ -260,9 +365,12 @@ val instrumentQuery = (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. *) - (* TODO: thread a Monoize.Fm.t through this module. *) - (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), + [MonoShake]. The dummy call is removed during [Sqlcache]. *) + (* TODO: thread a [Monoize.Fm.t] through this module. *) + (ESeq ((EFfiApp ("Sqlcache", + "dummy", + [(urlifiedRel0, stringTyp)]), + loc), (ERel 0, loc)), loc)), loc) @@ -272,18 +380,18 @@ val instrumentQuery = iq end -fun cacheWrap (query, i, urlifiedRel0, eqs) = +fun cacheWrap (query, i, urlifiedRel0, args) = case query of (EQuery {state = typ, ...}, _) => let - val () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo + val () = ffiInfo := {index = i, params = length args} :: !ffiInfo val loc = ErrorMsg.dummySpan (* We ensure before this step that all arguments aren't effectful. by turning them into local variables as needed. *) - val args = map (fn (_, e) => (e, stringTyp)) eqs - val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args - val check = ffiAppCache ("check", i, args) - val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc) + val argTyps = map (fn e => (e, stringTyp)) args + val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps + val check = ffiAppCache ("check", i, argTyps) + val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) val rel0 = (ERel 0, loc) in (ECase (check, @@ -315,18 +423,16 @@ fun addChecking file = letBody) => let val loc = ErrorMsg.dummySpan - val chunks = chunkify origQueryText + 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 - Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) - | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars) - | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars) - (* Head of newVars has lowest index. *) - | Exp e => + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => let val n = length newVars in @@ -335,12 +441,15 @@ fun addChecking file = so we increment indices by n. *) (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) end - | String s => (strcat (stringExp s, qText), newVars)) + | 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 + List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables (* Increment once for each new variable just made. *) val queryExp = incRels (length newVariables) (EQuery {query = newQueryText, @@ -352,6 +461,7 @@ fun addChecking file = 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)) 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. *) @@ -359,16 +469,15 @@ fun addChecking file = val attempt = (* Ziv misses Haskell's do notation.... *) guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( - bind (parse query queryText) (fn queryParsed => + bind (Sql.parse Sql.query queryText) (fn queryParsed => bind (indexOfName v) (fn i => - bind (equalitiesQuery queryParsed) (fn eqs => bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 => SOME (wrapLets (ELet (v, t, - cacheWrap (queryExp, i, urlifiedRel0, eqs), + cacheWrap (queryExp, i, urlifiedRel0, args), incRelsBound 1 (length newVariables) letBody)), SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) queryInfo - (tablesQuery queryParsed))))))) + (tablesQuery queryParsed)))))) in case attempt of SOME pair => pair @@ -380,6 +489,22 @@ fun addChecking file = fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty end +fun invalidations (nQueryArgs, query, dml) = + let + val loc = ErrorMsg.dummySpan + val optionToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, (e, loc)), loc) + fun eqsToInvalidation eqs = + let + fun inv n = if n < 0 then [] else optionToExp (IM.find (eqs, n)) :: inv (n - 1) + in + inv (nQueryArgs - 1) + end + in + map (map eqsToInvalidation) (conflictMaps (queryToFormula query, dmlToFormula dml)) + end + fun addFlushing (file, queryInfo) = let val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo @@ -388,7 +513,7 @@ fun addFlushing (file, queryInfo) = fn dmlExp as EDml (dmlText, _) => let val indices = - case parse dml dmlText of + case Sql.parse Sql.dml dmlText of SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed) | NONE => allIndices in @@ -408,179 +533,4 @@ fun go file = file' 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"}, - NONE), - loc) -fun boolTyp loc = (TFfi ("Basis", "int"), loc) - -fun ffiAppExp (module, func, index, args, loc) = - (EFfiApp (module, func ^ Int.toString index, args), 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, - [(boolPat (false, loc), exp), - (boolPat (true, loc), (ERecord [], loc))], - {disc = boolTyp loc, result = (TRecord [], loc)}), - loc) - -fun underAbs f (exp as (exp', loc)) = - case exp' of - EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) - | _ => f exp - - -val rec tablesRead = - fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2) - -val tableWritten = - fn Insert (tab, _) => tab - | Delete (tab, _) => tab - | Update (tab, _, _) => tab - -fun tablesInExp' exp' = - let - val nothing = {read = SS.empty, written = SS.empty} - in - case exp' of - EQuery {query = e, ...} => - (case parse query e of - SOME q => {read = tablesRead q, written = SS.empty} - | NONE => nothing) - | EDml (e, _) => - (case parse dml e of - SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} - | NONE => nothing) - | _ => nothing - end - -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 - in - MonoUtil.Exp.fold {typ = #2, exp = addTables} - {read = SS.empty, written = SS.empty} - end - -fun addCacheCheck (index, exp) = - let - fun f (body as (_, loc)) = - let - val check = ffiAppExp ("Cache", "check", index, loc) - val store = ffiAppExp ("Cache", "store", index, loc) - in - antiguardUnit (check, sequence ([body, store], loc), loc) - end - in - underAbs f exp - end - -fun addCacheFlush (exp, tablesToIndices) = - let - fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) - fun f (body as (_, loc)) = - let - fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) - val flushes = - IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) - in - sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc) - end - in - underAbs f exp - end - -val handlerIndices = - let - val isUnit = - fn (TRecord [], _) => true - | _ => false - fun maybeAdd (d, soFar as {readers, writers}) = - case d of - DExport (Link ReadOnly, _, name, typs, typ, _) => - if List.all isUnit (typ::typs) - then {readers = IS.add (readers, name), writers = writers} - else soFar - | DExport (_, _, name, _, _, _) => (* Not read only. *) - {readers = readers, writers = IS.add (writers, name)} - | _ => soFar - in - MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} - {readers = IS.empty, writers = IS.empty} - end - -fun fileFoldMapiSelected f init (file, indices) = - let - fun doExp (original as ((a, index, b, exp, c), state)) = - if IS.member (indices, index) - then let val (newExp, newState) = f (index, exp, state) - in ((a, index, b, newExp, c), newState) end - else original - fun doDecl decl state = - let - val result = - case decl of - DVal x => - let val (y, newState) = doExp (x, state) - in (DVal y, newState) end - | DValRec xs => - let val (ys, newState) = ListUtil.foldlMap doExp state xs - in (DValRec ys, newState) end - | _ => (decl, state) - in - Search.Continue result - end - fun nada x y = Search.Continue (x, y) - in - case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of - Search.Continue x => x - | _ => raise Match (* Should never happen. *) - end - -fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () - -val addCacheChecking = - let - fun f (index, exp, tablesToIndices) = - (addCacheCheck (index, exp), - SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) - tablesToIndices - (#read (tablesInExp exp))) - in - fileFoldMapiSelected f (SM.empty) - end - -fun addCacheFlushing (file, tablesToIndices, writers) = - fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) - -fun go file = - let - val {readers, writers} = handlerIndices file - val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) - in - ffiIndices := IS.listItems readers; - addCacheFlushing (fileWithChecks, tablesToIndices, writers) - end - -END OLD *) - end diff --git a/src/union_find_fn.sml b/src/union_find_fn.sml new file mode 100644 index 00000000..42b2d4d7 --- /dev/null +++ b/src/union_find_fn.sml @@ -0,0 +1,47 @@ +functor UnionFindFn(K : ORD_KEY) = struct + +structure M = BinaryMapFn(K) +structure S = BinarySetFn(K) + +datatype entry = + Set of S.set + | Pointer of K.ord_key + +(* First map is the union-find tree, second stores equivalence classes. *) +type unionFind = entry M.map ref * S.set M.map + +val empty : unionFind = (ref M.empty, M.empty) + +fun findPair (uf, x) = + case M.find (!uf, x) of + NONE => (S.singleton x, x) + | SOME (Set set) => (set, x) + | SOME (Pointer parent) => + let + val (set, rep) = findPair (uf, parent) + in + uf := M.insert (!uf, x, Pointer rep); + (set, rep) + end + +fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x) + +fun classes (_, cs) = (map S.listItems o M.listItems) cs + +fun union ((uf, cs), x, y) = + let + val (xSet, xRep) = findPair (uf, x) + val (ySet, yRep) = findPair (uf, y) + val xySet = S.union (xSet, ySet) + in + (ref (M.insert (M.insert (!uf, yRep, Pointer xRep), + xRep, Set xySet)), + M.insert (case M.find (cs, yRep) of + NONE => cs + | SOME _ => #1 (M.remove (cs, yRep)), + xRep, xySet)) + end + +fun union' ((x, y), uf) = union (uf, x, y) + +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 'src/cjr_print.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db deleted file mode 100644 index a4661341..00000000 Binary files a/caching-tests/test.db and /dev/null differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql deleted file mode 100644 index 7ade7278..00000000 --- a/caching-tests/test.sql +++ /dev/null @@ -1,16 +0,0 @@ -CREATE TABLE uw_Test_foo01(uw_id int8 NOT NULL, uw_bar text NOT NULL, - PRIMARY KEY (uw_id) - - ); - - CREATE TABLE uw_Test_foo10(uw_id int8 NOT NULL, uw_bar text NOT NULL, - PRIMARY KEY (uw_id) - - ); - - CREATE TABLE uw_Test_tab(uw_id int8 NOT NULL, uw_val int8 NOT NULL, - PRIMARY KEY (uw_id) - - ); - - \ No newline at end of file diff --git a/caching-tests/test.ur b/caching-tests/test.ur index 931612bc..2722bcdc 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -11,26 +11,26 @@ fun cache01 () = | Some row => {[row.Foo01.Bar]}} -fun cache10 () = - res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) - (fn row => {[row.Foo10.Bar]}); - return - Reading 2. - {res} - +(* fun cache10 () = *) +(* res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) *) +(* (fn row => {[row.Foo10.Bar]}); *) +(* return *) +(* Reading 2. *) +(* {res} *) +(* *) -fun cache11 () = - res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); - bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); - return - Reading 1 and 2. - {case res of - None => ? - | Some row => {[row.Foo01.Bar]}} - {case bla of - None => ? - | Some row => {[row.Foo10.Bar]}} - +(* fun cache11 () = *) +(* res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); *) +(* bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); *) +(* return *) +(* Reading 1 and 2. *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Foo01.Bar]}} *) +(* {case bla of *) +(* None => ? *) +(* | Some row => {[row.Foo10.Bar]}} *) +(* *) fun flush01 () = dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); @@ -39,18 +39,18 @@ fun flush01 () = Flushed 1! -fun flush10 () = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return - Flushed 2! - +(* fun flush10 () = *) +(* dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); *) +(* return *) +(* Flushed 2! *) +(* *) -fun flush11 () = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return - Flushed 1 and 2! - +(* fun flush11 () = *) +(* dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); *) +(* dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); *) +(* return *) +(* Flushed 1 and 2! *) +(* *) fun cache id = res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); @@ -63,9 +63,9 @@ fun cache id = fun flush id = res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); - dml (case res of - None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0)) - | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]})); + (case res of + None => dml (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0)) + | Some row => dml (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]})); return (* Flushed {[id]}! *) {case res of diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ace4ba28..30bff733 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,8 +1,8 @@ val cache01 : unit -> transaction page -val cache10 : unit -> transaction page -val cache11 : unit -> transaction page +(* val cache10 : unit -> transaction page *) +(* val cache11 : unit -> transaction page *) val flush01 : unit -> transaction page -val flush10 : unit -> transaction page -val flush11 : unit -> transaction page +(* val flush10 : unit -> transaction page *) +(* val flush11 : unit -> transaction page *) val cache : int -> transaction page val flush : int -> transaction page diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 56310b81..81dfefaa 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3410,14 +3410,22 @@ fun p_file env (ds, ps) = fun paramRepeatInit itemi sep = if params = 0 then "" else sep ^ paramRepeat itemi sep val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " - val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n" + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" + ^ p ^ " = NULL;") + "\n" val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p - ^ " = strdup(p" ^ p ^ ");") "\n" - val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n" - (* Starting || makes logic easier when there are no parameters. *) + ^ " = strdup(p" ^ p ^ ");") + "\n" + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") + "\n" val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p ^ ", p" ^ p ^ ")") " || " + (* Using [!=] instead of [==] to mimic [strcmp]. *) + val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || " + ^ "!strcmp(param" ^ i ^ "_" + ^ p ^ ", p" ^ p ^ "))") + " && " in box [string "static char *cacheQuery", string i, string " = NULL;", @@ -3471,13 +3479,21 @@ fun p_file env (ds, ps) = newline, string "static uw_unit uw_Sqlcache_flush", string i, - string "(uw_context ctx) {\n free(cacheQuery", + string "(uw_context ctx", + string args, + string ") {\n if (cacheQuery", + string i, + string " != NULL", + string eqsNull, + string ") {\n free(cacheQuery", string i, string ");\n cacheQuery", string i, string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string ".\");\n return uw_unit_v;\n };", + string ".\");}\n else { puts(\"SQLCACHE: keeping ", + string i, + string "\"); } return uw_unit_v;\n };", newline, newline] end) diff --git a/src/cjrize.sml b/src/cjrize.sml index 11174162..b20d6d22 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -431,7 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; (dummye, sm)) - | L.EQuery {exps, tables, state, query, body, initial} => + | L.EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => let val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => let @@ -586,7 +586,7 @@ fun cifyDecl ((d, loc), sm) = let val (vis, sm) = ListUtil.foldlMap (fn ((x, n, t, e, _), sm) => - let + let val (t, sm) = cifyTyp (t, sm) fun unravel (tAll as (t, _), eAll as (e, _)) = @@ -601,7 +601,7 @@ fun cifyDecl ((d, loc), sm) = (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; ([], tAll, eAll)) | _ => ([], tAll, eAll) - + val (args, ran, e) = unravel (t, e) val (e, sm) = cifyExp (e, sm) in @@ -610,7 +610,7 @@ fun cifyDecl ((d, loc), sm) = sm vis in (SOME (L'.DFunRec vis, loc), NONE, sm) - end + end | L.DExport (ek, s, n, ts, t, b) => let diff --git a/src/iflow.sml b/src/iflow.sml index f68d8f72..b8346baa 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1870,14 +1870,15 @@ val namer = MonoUtil.File.map {typ = fn t => t, case e of EDml (e, fm) => nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => nameSubexps (fn (liftBy, e') => (EQuery {exps = exps, tables = tables, state = state, query = e', body = mliftExpInExp liftBy 2 body, - initial = mliftExpInExp liftBy 0 initial}, + initial = mliftExpInExp liftBy 0 initial, + sqlcacheInfo = sqlcacheInfo}, #2 query)) query | _ => e, decl = fn d => d} @@ -2070,11 +2071,12 @@ fun check (file : file) = | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) | ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc) | EClosure (n, es) => (EClosure (n, map (doExp env) es), loc) - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => (EQuery {exps = exps, tables = tables, state = state, query = doExp env query, body = doExp (Unknown :: Unknown :: env) body, - initial = doExp env initial}, loc) + initial = doExp env initial, + sqlcacheInfo = sqlcacheInfo}, loc) | EDml (e1, mode) => (case parse dml e1 of NONE => () diff --git a/src/jscomp.sml b/src/jscomp.sml index 1a476739..a4ee95f0 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -195,7 +195,7 @@ fun process (file : file) = str loc "}"])], {disc = t, result = s}), loc) val body = (EAbs ("x", t, s, body), loc) - + val st = {decls = ("jsify", n', (TFun (t, s), loc), body, "jsify") :: #decls st, script = #script st, @@ -575,7 +575,7 @@ fun process (file : file) = val e = String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" | ch => String.str ch) e - + val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'" ^ e ^ "'};\n" in @@ -799,7 +799,7 @@ fun process (file : file) = | _ => default () in seek (e', [x]) - end + end | ECase (e', pes, _) => let @@ -1030,7 +1030,7 @@ fun process (file : file) = | ERel _ => (e, st) | ENamed _ => (e, st) | ECon (_, _, NONE) => (e, st) - | ECon (dk, pc, SOME e) => + | ECon (dk, pc, SOME e) => let val (e, st) = exp outer (e, st) in @@ -1082,7 +1082,7 @@ fun process (file : file) = in ((EBinop (bi, s, e1, e2), loc), st) end - + | ERecord xets => let val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => @@ -1176,7 +1176,7 @@ fun process (file : file) = ((EClosure (n, es), loc), st) end - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => let val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row @@ -1187,7 +1187,8 @@ fun process (file : file) = val (initial, st) = exp outer (initial, st) in ((EQuery {exps = exps, tables = tables, state = state, - query = query, body = body, initial = initial}, loc), st) + query = query, body = body, initial = initial, + sqlcacheInfo = sqlcacheInfo}, loc), st) end | EDml (e, mode) => let @@ -1257,7 +1258,7 @@ fun process (file : file) = in ((ESignalSource e, loc), st) end - + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st) diff --git a/src/mono.sml b/src/mono.sml index 1e402e57..5185e48c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -107,7 +107,8 @@ datatype exp' = state : typ, query : exp, (* exp of string type containing sql query *) body : exp, - initial : exp } + initial : exp, + sqlcacheInfo : exp } | EDml of exp * failure_mode | ENextval of exp | ESetval of exp * exp @@ -119,7 +120,7 @@ datatype exp' = | ESignalReturn of exp | ESignalBind of exp * exp | ESignalSource of exp - + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index d1e5ce55..97f78d3d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -166,7 +166,7 @@ fun exp e = e | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) - + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => let val s = @@ -179,7 +179,7 @@ fun exp e = in EPrim (Prim.String (Prim.Html, s)) end - + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => EPrim (Prim.String (Prim.Normal, s1 ^ s2)) @@ -397,18 +397,20 @@ fun exp e = initial = (EPrim (Prim.String (k, "")), _), body = (EStrcat ((EPrim (Prim.String (_, s)), _), (EStrcat ((ERel 0, _), - e'), _)), _)}, loc) => + e'), _)), _), + sqlcacheInfo}, loc) => if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = (optExp (EWrite e', loc), loc)} + body = (optExp (EWrite e', loc), loc), + sqlcacheInfo = Monoize.urlifiedUnit} else e | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String (_, "")), _), - body}, loc) => + body, sqlcacheInfo}, loc) => let fun passLets (depth, (e', _), lets) = case e' of @@ -423,7 +425,8 @@ fun exp e = EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = body} + body = body, + sqlcacheInfo = Monoize.urlifiedUnit} end else e @@ -532,7 +535,7 @@ fun exp e = else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -560,7 +563,7 @@ fun exp e = EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -585,7 +588,7 @@ fun exp e = EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => EPrim (Prim.String (Prim.Normal, unAs s)) | EFfiApp ("Basis", "unAs", [(e', _)]) => let @@ -620,7 +623,7 @@ fun exp e = EFfiApp ("Basis", "attrifyChar_w", [e]) | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) - + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index c81b362a..0ff51f37 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -310,7 +310,7 @@ fun p_exp' par env (e, _) = p_exp env e]) es, string ")"] - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => box [string "query[", p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, string "] [", @@ -391,7 +391,7 @@ fun p_vali env (x, n, t, e, s) = string "__", string (Int.toString n)] else - string x + string x in box [xp, space, @@ -541,7 +541,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_policy env p] | DOnError _ => string "ONERROR" - + fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => diff --git a/src/mono_util.sml b/src/mono_util.sml index fd80c64f..ba10ad32 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -314,7 +314,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fn es' => (EClosure (n, es'), loc)) - | EQuery {exps, tables, state, query, body, initial} => + | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} => S.bind2 (ListUtil.mapfold (fn (x, t) => S.map2 (mft t, fn t' => (x, t'))) exps, @@ -334,15 +334,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} = RelE ("acc", dummyt))) body, fn body' => - S.map2 (mfe ctx initial, + (* ASK: is this the right thing to do? *) + S.bind2 (mfe ctx initial, fn initial' => - (EQuery {exps = exps', - tables = tables', - state = state', - query = query', - body = body', - initial = initial'}, - loc))))))) + S.map2 (mfe (bind (ctx, RelE ("queryResult", dummyt))) + sqlcacheInfo, + fn sqlcacheInfo' => + (EQuery {exps = exps', + tables = tables', + state = state', + query = query', + body = body', + initial = initial', + sqlcacheInfo = sqlcacheInfo}, + loc)))))))) | EDml (e, fm) => S.map2 (mfe ctx e, diff --git a/src/monoize.sig b/src/monoize.sig index 951db01b..549bf6ee 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -31,4 +31,6 @@ signature MONOIZE = sig val liftExpInExp : int -> Mono.exp -> Mono.exp + val urlifiedUnit : Mono.exp + end diff --git a/src/monoize.sml b/src/monoize.sml index 2d225813..5c314c54 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -681,6 +681,16 @@ fun fooifyExp fk env = val attrifyExp = fooifyExp Attr val urlifyExp = fooifyExp Url +val urlifiedUnit = + let + val loc = ErrorMsg.dummySpan + (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *) + val (urlified, _) = urlifyExp CoreEnv.empty (Fm.empty 0) + ((L'.ERel 0, loc), (L'.TRecord [], loc)) + in + urlified + end + datatype 'a failable_search = Found of 'a | NotFound @@ -1957,26 +1967,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun (un, state), loc)), loc)), loc) - val body'' = (L'.EApp ( + val body' = (L'.EApp ( (L'.EApp ( (L'.EApp ((L'.ERel 4, loc), (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - val body' = (L'.EQuery {exps = exps, - tables = tables, - state = state, - query = (L'.ERel 3, loc), - body = body'', - initial = (L'.ERel 1, loc)}, - loc) - val (body, fm) = if Settings.getSqlcache () then - let - val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) - in - (Sqlcache.instrumentQuery (body', urlifiedRel0), fm) - end - else (body', fm) + val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) + val body = (L'.EQuery {exps = exps, + tables = tables, + state = state, + query = (L'.ERel 3, loc), + body = body', + initial = (L'.ERel 1, loc), + sqlcacheInfo = urlifiedRel0}, + loc) + val body = if Settings.getSqlcache () + then Sqlcache.instrumentQuery (body, urlifiedRel0) + else body in ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index d8169926..b555ca7a 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -176,12 +176,10 @@ fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) = fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false -fun mapFormulaSigned positive mf = - fn Atom x => Atom (mf (positive, x)) - | Negate f => Negate (mapFormulaSigned (not positive) mf f) - | Combo (n, fs) => Combo (n, map (mapFormulaSigned positive mf) fs) - -fun mapFormula mf = mapFormulaSigned true (fn (_, x) => mf x) +fun mapFormula mf = + fn Atom x => Atom (mf x) + | Negate f => Negate (mapFormula mf f) + | Combo (n, fs) => Combo (n, map (mapFormula mf) fs) (* SQL analysis. *) @@ -225,11 +223,10 @@ val compare = end structure UF = UnionFindFn(AtomExpKey) - -(* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) -(* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) -(* -> Mono.exp' IM.map list = *) -(* let *) +val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula + * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula + -> atomExp IM.map list = + let val toKnownEquality = (* [NONE] here means unkown. Anything that isn't a comparison between two knowns shouldn't be used, and simply dropping unused terms is @@ -297,12 +294,12 @@ structure UF = UnionFindFn(AtomExpKey) (SOME IM.empty) fun dnf (fQuery, fDml) = normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml])) - (* in *) - val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula - * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula - -> atomExp IM.map list = - List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf - (* end *) + in + (* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) + (* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) + (* -> atomExp IM.map list = *) + List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf + end val rec sqexpToFormula = fn Sql.SqTrue => Combo (Cnf, []) @@ -338,32 +335,21 @@ fun valsToFormula (table, vals) = Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) val rec dmlToFormula = - fn Sql.Insert tableVals => valsToFormula tableVals + fn Sql.Insert (table, vals) => valsToFormula (table, vals) | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher) - (* TODO: refine formula for the vals part, which could take into account the wher part. *) - (* TODO: use pushNegate instead of mapFormulaSigned? *) | Sql.Update (table, vals, wher) => let - val f = sqexpToFormula wher - fun update (positive, a) = - let - fun updateIfNecessary field = - case List.find (fn (f, _) => field = f) vals of - SOME (_, v) => (if positive then Sql.Eq else Sql.Ne, - Sql.Field (table, field), - v) - | NONE => a - in - case a of - (_, Sql.Field (_, field), _) => updateIfNecessary field - | (_, _, Sql.Field (_, field)) => updateIfNecessary field - | _ => a - end + val fWhere = sqexpToFormula wher + val fVals = valsToFormula (table, vals) + (* TODO: don't use field name hack. *) + val markField = + fn Sql.Field (t, v) => Sql.Field (t, v ^ "*") + | e => e + val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) in renameTables [(table, "T")] - (Combo (Dnf, [f, - Combo (Cnf, [valsToFormula (table, vals), - mapFormulaSigned true update f])])) + (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]), + Combo (Cnf, [mark fVals, fWhere])])) end val rec tablesQuery = @@ -482,54 +468,62 @@ fun fileMapfold doExp file start = fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) +fun factorOutNontrivial text = + let + val loc = ErrorMsg.dummySpan + fun strcat (e1, e2) = (EStrcat (e1, e2), loc) + val chunks = Sql.chunkify text + val (newText, newVariables) = + (* Important that this is foldr (to oppose foldl below). *) + List.foldr + (fn (chunk, (qText, newVars)) => + (* Variable bound to the head of newBs will have the lowest index. *) + case chunk of + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => + let + val n = length newVars + in + (* This is the (n + 1)th new variable, so there are + already n new variables bound, so we increment + indices by n. *) + (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) + end + | Sql.String s => (strcat (stringExp s, qText), newVars)) + (stringExp "", []) + chunks + fun wrapLets e' = + (* Important that this is foldl (to oppose foldr above). *) + List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables + in + (newText, wrapLets, numArgs) + end + fun addChecking file = let - fun doExp (queryInfo as (tableToIndices, indexToQuery)) = + fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) = fn e' as ELet (v, t, - queryExp' as (EQuery {query = origQueryText, - initial, body, state, tables, exps}, queryLoc), + (EQuery {query = origQueryText, + initial, body, state, tables, exps, sqlcacheInfo}, queryLoc), letBody) => let - val loc = ErrorMsg.dummySpan - val chunks = Sql.chunkify origQueryText - fun strcat (e1, e2) = (EStrcat (e1, e2), loc) - val (newQueryText, newVariables) = - (* Important that this is foldr (to oppose foldl below). *) - List.foldr - (fn (chunk, (qText, newVars)) => - (* Variable bound to the head of newBs will have the lowest index. *) - case chunk of - Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) - | Sql.Exp e => - let - val n = length newVars - in - (* This is the (n + 1)th new variable, so - there are already n new variables bound, - so we increment indices by n. *) - (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) - end - | Sql.String s => (strcat (stringExp s, qText), newVars)) - (stringExp "", []) - chunks - fun wrapLets e' = - (* Important that this is foldl (to oppose foldr above). *) - List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) - e' - newVariables - val numArgs = length newVariables + val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText (* Increment once for each new variable just made. *) - val queryExp = incRels (length newVariables) + val queryExp = incRels numArgs (EQuery {query = newQueryText, initial = initial, body = body, state = state, tables = tables, - exps = exps}, + exps = exps, + sqlcacheInfo = sqlcacheInfo}, queryLoc) val (EQuery {query = queryText, ...}, _) = queryExp - val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); - val args = List.tabulate (numArgs, fn n => (ERel n, loc)) + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) + val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) fun bind x f = Option.mapPartial f x fun guard b x = if b then x else NONE (* DEBUG: set first boolean argument to true to turn on printing. *) @@ -542,11 +536,11 @@ fun addChecking file = bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 => SOME (wrapLets (ELet (v, t, cacheWrap (queryExp, index, urlifiedRel0, args), - incRelsBound 1 (length newVariables) letBody)), + incRelsBound 1 numArgs letBody)), (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), - IM.insert (indexToQuery, index, (queryParsed, numArgs)))))))) + IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)))))))) in case attempt of SOME pair => pair @@ -558,10 +552,12 @@ fun addChecking file = fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty) end +val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] + val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) * ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref [] -fun invalidations (nQueryArgs, query, dml) = +fun invalidations ((query, numArgs), dml) = let val loc = ErrorMsg.dummySpan val optionAtomExpToExp = @@ -578,9 +574,10 @@ fun invalidations (nQueryArgs, query, dml) = let fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) in - inv (nQueryArgs - 1) + inv (numArgs - 1) end - (* *) + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = fn ([], []) => true | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys) @@ -601,39 +598,67 @@ fun invalidations (nQueryArgs, query, dml) = (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss end -val gunk : Mono.exp list list list ref = ref [] -fun addFlushing (file, queryInfo as (tableToIndices, indexToQuery)) = +(* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) + +fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) = let - val allIndices = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices - val flushes = map (fn i => ffiAppCache' ("flush", i, [])) + (* TODO: write this. *) + val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) + val flushes = List.concat o + map (fn (i, argss) => + map (fn args => + ffiAppCache' ("flush", i, + map (fn arg => (arg, stringTyp)) args)) argss) val doExp = - fn dmlExp as EDml (dmlText, _) => + fn EDml (origDmlText, failureMode) => let - val indices = + val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText + val dmlText = incRels numArgs newDmlText + val dmlExp = EDml (dmlText, failureMode) + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) + val invs = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - map (fn i => ((case IM.find (indexToQuery, i) of - NONE => () - | SOME (queryParsed, numArgs) => - gunk := invalidations (numArgs, queryParsed, dmlParsed) :: !gunk); - i)) (SIMM.findList (tableToIndices, tableDml dmlParsed)) - | NONE => allIndices + map (fn i => (case IM.find (indexToQueryNumArgs, i) of + SOME queryNumArgs => + (i, invalidations (queryNumArgs, dmlParsed)) + (* TODO: fail more gracefully. *) + | NONE => raise Match)) + (SIMM.findList (tableToIndices, tableDml dmlParsed)) + (* TODO: fail more gracefully. *) + | NONE => raise Match in - sequence (flushes indices @ [dmlExp]) + wrapLets (sequence (flushes invs @ [dmlExp])) end | e' => e' in fileMap doExp file end +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + fun go file = let val () = Sql.sqlcacheMode := true - val file' = addFlushing (addChecking file) + val file' = addFlushing (addChecking (inlineSql file)) val () = Sql.sqlcacheMode := false in - file' + file' end end diff --git a/src/urweb.lex b/src/urweb.lex index 0d316ed2..785f7a81 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -18,7 +18,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -50,7 +50,7 @@ in else (); commentLevel := !commentLevel + 1) - + fun exitComment () = (ignore (commentLevel := !commentLevel - 1); if !commentLevel = 0 then @@ -58,15 +58,15 @@ in else ()) - fun eof () = - let + fun eof () = + let val pos = ErrorMsg.lastLineStart () in if !commentLevel > 0 then ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" else (); - Tokens.EOF (pos, pos) + Tokens.EOF (pos, pos) end end @@ -177,7 +177,7 @@ fun unescape loc s = %s COMMENT STRING CHAR XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; -xmlid = [A-Za-z][A-Za-z0-9-_]*; +xmlid = [A-Za-z][A-Za-z0-9_-]*; cid = [A-Z][A-Za-z0-9_]*; ws = [\ \t\012\r]; intconst = [0-9]+; @@ -300,7 +300,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; Tokens.XML_END (yypos, yypos + size yytext)) else Tokens.END_TAG (id, yypos, yypos + size yytext) - | _ => + | _ => Tokens.END_TAG (id, yypos, yypos + size yytext) end); -- cgit v1.2.3 From 219524359a25417b9e140130ab77a9a330c41012 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 29 Nov 2014 04:34:41 -0500 Subject: Remove Sqlcache urlification hack. --- src/cjr_print.sml | 19 ++++----- src/monoize.sml | 3 -- src/sqlcache.sml | 113 +++++++++++++++++------------------------------------- 3 files changed, 46 insertions(+), 89 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 81dfefaa..73e0316d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3394,7 +3394,6 @@ fun p_file env (ds, ps) = newline, (* For sqlcache. *) - (* TODO: also record between Cache.check and Cache.store. *) box (List.map (fn {index, params} => let val i = Int.toString index @@ -3440,14 +3439,16 @@ fun p_file env (ds, ps) = string i, string "(uw_context ctx", string args, - string ") {\n puts(\"SQLCACHE: checked ", - string i, - string ".\");\n if (cacheQuery", + string ") {\n if (cacheQuery", string i, (* ASK: is returning the pointer okay? Should we duplicate? *) string " == NULL", string eqs, - string ") {\n puts(\"miss D:\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"hit :D\");\n uw_write(ctx, cacheWrite", + string ") {\n puts(\"SQLCACHE: miss ", + string i, + string ".\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"SQLCACHE: hit ", + string i, + string ".\");\n uw_write(ctx, cacheWrite", string i, string ");\n return cacheQuery", string i, @@ -3473,7 +3474,7 @@ fun p_file env (ds, ps) = newline, string sets, newline, - string "puts(\"SQLCACHE: stored ", + string "puts(\"SQLCACHE: store ", string i, string ".\");\n return uw_unit_v;\n };", newline, @@ -3489,11 +3490,11 @@ fun p_file env (ds, ps) = string i, string ");\n cacheQuery", string i, - string " = NULL;\n puts(\"SQLCACHE: flushed ", + string " = NULL;\n puts(\"SQLCACHE: flush ", string i, - string ".\");}\n else { puts(\"SQLCACHE: keeping ", + string ".\");}\n else { puts(\"SQLCACHE: keep ", string i, - string "\"); } return uw_unit_v;\n };", + string ".\"); } return uw_unit_v;\n };", newline, newline] end) diff --git a/src/monoize.sml b/src/monoize.sml index 5c314c54..fa69b3af 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1982,9 +1982,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 b555ca7a..13a47c9d 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -16,7 +16,7 @@ fun getFfiInfo () = !ffiInfo (* Some FFIs have writing as their only effect, which the caching records. *) val ffiEffectful = - (* TODO: have this less hard-coded. *) + (* ASK: how can this be less hard-coded? *) let val fs = SS.fromList ["htmlifyInt_w", "htmlifyFloat_w", @@ -46,7 +46,7 @@ fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.e false, then expression is definitely not effectful if effs is fully populated. The intended pattern is to use this a number of times equal to the number of declarations in a file, Bellman-Ford style. *) - (* TODO: make incrementing of bound less janky, probably by using MonoUtil + (* TODO: make incrementing of bound less janky, probably by using [MonoUtil] instead of all this. *) let (* DEBUG: remove printing when done. *) @@ -253,7 +253,9 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) - (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. *) + (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. + This would involve guarding the invalidation with a check for the + relevant comparisons. *) | (_, eqso) => eqso val eqsOfClass : atomExp list -> atomExp IM.map option = List.foldl accumulateEqs (SOME IM.empty) @@ -295,9 +297,6 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula 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 @@ -402,63 +401,27 @@ fun incRelsBound bound inc = val incRels = incRelsBound 0 -(* Filled in by instrumentQuery during [Monoize], used during [Sqlcache]. *) -val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty - -(* Used by [Monoize]. *) -val instrumentQuery = +fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = 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); - (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]. *) - (* TODO: thread a [Monoize.Fm.t] through this module. *) - (ESeq ((EFfiApp ("Sqlcache", - "dummy", - [(urlifiedRel0, stringTyp)]), - loc), - (ERel 0, loc)), - loc)), - loc) - end - | _ => raise Match + val () = ffiInfo := {index = i, params = length args} :: !ffiInfo + val loc = ErrorMsg.dummySpan + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val argTyps = map (fn e => (e, stringTyp)) args + val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps + val check = ffiAppCache ("check", i, argTyps) + val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) + val rel0 = (ERel 0, loc) in - iq + ECase (check, + [((PNone stringTyp, loc), + (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, resultTyp, false), loc))], + {disc = stringTyp, result = resultTyp}) end -fun cacheWrap (query, i, urlifiedRel0, args) = - case query of - (EQuery {state = typ, ...}, _) => - let - val () = ffiInfo := {index = i, params = length args} :: !ffiInfo - val loc = ErrorMsg.dummySpan - (* We ensure before this step that all arguments aren't effectful. - by turning them into local variables as needed. *) - val argTyps = map (fn e => (e, stringTyp)) args - val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps - val check = ffiAppCache ("check", i, argTyps) - val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) - val rel0 = (ERel 0, loc) - in - (ECase (check, - [((PNone stringTyp, loc), - (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)), - ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), - (* Boolean is false because we're not unurlifying from a cookie. *) - (EUnurlify (rel0, 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)), @@ -504,23 +467,23 @@ fun factorOutNontrivial text = fun addChecking file = let - fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) = - fn e' as ELet (v, t, - (EQuery {query = origQueryText, - initial, body, state, tables, exps, sqlcacheInfo}, queryLoc), - letBody) => + fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = + fn e' as EQuery {query = origQueryText, + sqlcacheInfo = urlifiedRel0, + state = resultTyp, + initial, body, tables, exps} => let val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText (* Increment once for each new variable just made. *) val queryExp = incRels numArgs (EQuery {query = newQueryText, + sqlcacheInfo = urlifiedRel0, + state = resultTyp, initial = initial, body = body, - state = state, tables = tables, - exps = exps, - sqlcacheInfo = sqlcacheInfo}, - queryLoc) + exps = exps}, + ErrorMsg.dummySpan) val (EQuery {query = queryText, ...}, _) = queryExp val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) @@ -532,24 +495,20 @@ fun addChecking file = (* Ziv misses Haskell's do notation.... *) guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( bind (Sql.parse Sql.query queryText) (fn queryParsed => - bind (indexOfName v) (fn index => - bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 => - SOME (wrapLets (ELet (v, t, - cacheWrap (queryExp, index, urlifiedRel0, args), - incRelsBound 1 numArgs letBody)), + SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), - IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)))))))) + IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), + index + 1)))) in case attempt of SOME pair => pair | NONE => (e', queryInfo) end - | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) | e' => (e', queryInfo) in - fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty) + fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) end val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] @@ -601,7 +560,7 @@ fun invalidations ((query, numArgs), dml) = (* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) -fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) = +fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = let (* TODO: write this. *) val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) -- cgit v1.2.3 From f242d9d14317ee01328b8a071502133696f78aa8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 6 May 2015 14:50:29 -0400 Subject: Factor out cache implementation from Sqlcache. --- src/cjr_print.sml | 106 +----------------------------------------------------- src/sources | 2 ++ src/sqlcache.sml | 52 +++++++++------------------ 3 files changed, 19 insertions(+), 141 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 1b1d656d..12ad309a 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3404,111 +3404,7 @@ fun p_file env (ds, ps) = newline, (* For sqlcache. *) - box (List.map - (fn {index, params} => - let val i = Int.toString index - fun paramRepeat itemi sep = - let - fun f n = - if n < 0 then "" - else if n = 0 then itemi (Int.toString 0) - else f (n-1) ^ sep ^ itemi (Int.toString n) - in - f (params - 1) - end - 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 sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p - ^ " = 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;", - newline, - string "static char *cacheWrite", - string i, - string " = NULL;", - newline, - string decls, - newline, - string "static uw_Basis_string uw_Sqlcache_check", - string i, - string "(uw_context ctx", - string args, - string ") {\n if (cacheQuery", - string i, - (* ASK: is returning the pointer okay? Should we duplicate? *) - string " == NULL", - string eqs, - string ") {\n puts(\"SQLCACHE: miss ", - string i, - string ".\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"SQLCACHE: hit ", - string i, - string ".\");\n uw_write(ctx, cacheWrite", - string i, - string ");\n return cacheQuery", - string i, - string ";\n } };", - newline, - string "static uw_unit uw_Sqlcache_store", - string i, - string "(uw_context ctx, uw_Basis_string s", - string args, - string ") {\n free(cacheQuery", - string i, - string "); free(cacheWrite", - string i, - string ");", - newline, - string frees, - newline, - string "cacheQuery", - string i, - string " = strdup(s); cacheWrite", - string i, - string " = uw_recordingRead(ctx);", - newline, - string sets, - newline, - string "puts(\"SQLCACHE: store ", - string i, - string ".\");\n return uw_unit_v;\n };", - newline, - string "static uw_unit uw_Sqlcache_flush", - string i, - 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: flush ", - string i, - string ".\");}\n else { puts(\"SQLCACHE: keep ", - string i, - string ".\"); } return uw_unit_v;\n };", - newline, - newline] - end) - (Sqlcache.getFfiInfo ())), + box (List.map ToyCache.setupQuery (Sqlcache.getFfiInfo ())), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/sources b/src/sources index 33c01f94..05897cd4 100644 --- a/src/sources +++ b/src/sources @@ -175,6 +175,8 @@ $(SRC)/union_find_fn.sml $(SRC)/multimap_fn.sml +$(SRC)/toy_cache.sml + $(SRC)/sqlcache.sig $(SRC)/sqlcache.sml diff --git a/src/sqlcache.sml b/src/sqlcache.sml index f60555e8..931c6737 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -43,7 +43,7 @@ val ffiEffectful = (* Effect analysis. *) (* Makes an exception for [EWrite] (which is recorded when caching). *) -fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = +fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool = (* If result is true, expression is definitely effectful. If result is false, then expression is definitely not effectful if effs is fully populated. The intended pattern is to use this a number of times equal @@ -183,6 +183,7 @@ fun mapFormula mf = | Negate f => Negate (mapFormula mf f) | Combo (n, fs) => Combo (n, map (mapFormula mf) fs) + (* SQL analysis. *) val rec chooseTwos : 'a list -> ('a * 'a) list = @@ -365,33 +366,21 @@ val tableDml = (* Program instrumentation. *) -fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan) +val dummyLoc = ErrorMsg.dummySpan + +fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) -val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) val sequence = fn (exp :: exps) => let - val loc = ErrorMsg.dummySpan + val loc = dummyLoc in List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps end | _ => raise Match -(* TODO: factor out. *) -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 - (* Always increments negative indices because that's what we need later. *) fun incRelsBound bound inc = MonoUtil.Exp.mapB @@ -407,13 +396,12 @@ val incRels = incRelsBound 0 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = let val () = ffiInfo := {index = i, params = length args} :: !ffiInfo - val loc = ErrorMsg.dummySpan + val loc = dummyLoc (* We ensure before this step that all arguments aren't effectful. by turning them into local variables as needed. *) - val argTyps = map (fn e => (e, stringTyp)) args - val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps - val check = ffiAppCache ("check", i, argTyps) - val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) + val argsInc = map (incRels 1) args + val check = (ToyCache.check (i, args), dummyLoc) + val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc) val rel0 = (ERel 0, loc) in ECase (check, @@ -436,7 +424,7 @@ fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file () fun factorOutNontrivial text = let - val loc = ErrorMsg.dummySpan + val loc = dummyLoc fun strcat (e1, e2) = (EStrcat (e1, e2), loc) val chunks = Sql.chunkify text val (newText, newVariables) = @@ -486,10 +474,10 @@ fun addChecking file = body = body, tables = tables, exps = exps}, - ErrorMsg.dummySpan) + dummyLoc) val (EQuery {query = queryText, ...}, _) = queryExp val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) - val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) + val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) 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. *) @@ -516,7 +504,7 @@ fun addChecking file = fun invalidations ((query, numArgs), dml) = let - val loc = ErrorMsg.dummySpan + val loc = dummyLoc val optionAtomExpToExp = fn NONE => (ENone stringTyp, loc) | SOME e => (ESome (stringTyp, @@ -556,16 +544,8 @@ fun invalidations ((query, numArgs), dml) = fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = let - (* ASK: does this type actually matter? It was wrong before, but things - still seemed to work. *) - val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan) val flushes = List.concat o - map (fn (i, argss) => - map (fn args => - ffiAppCache' ("flush", i, - map (fn arg => (arg, optionStringTyp)) - args)) - argss) + map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss) val doExp = fn EDml (origDmlText, failureMode) => let -- cgit v1.2.3 From ca3efa1458583772a9826198ed4b99eec381f2de Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 6 May 2015 23:11:30 -0400 Subject: More work factoring out Sqlcache back end. --- src/cache.sml | 16 ++++++++++++++++ src/cjr_print.sml | 6 +++++- src/sources | 1 + src/sqlcache.sig | 5 ++++- src/sqlcache.sml | 14 ++++++++++---- src/toy_cache.sml | 11 ++++++++++- 6 files changed, 46 insertions(+), 7 deletions(-) create mode 100644 src/cache.sml (limited to 'src/cjr_print.sml') diff --git a/src/cache.sml b/src/cache.sml new file mode 100644 index 00000000..8de22e0d --- /dev/null +++ b/src/cache.sml @@ -0,0 +1,16 @@ +structure Cache = struct + +type cache = + {(* Takes a query ID and parameters (and, for store, the value to + store) and gives an FFI call that checks, stores, or flushes the + relevant entry. The parameters are strings for check and store and + optional strings for flush because some parameters might not be + fixed. *) + check : int * Mono.exp list -> Mono.exp', + store : int * Mono.exp list * Mono.exp -> Mono.exp', + flush : int * Mono.exp list -> Mono.exp', + (* Generates C needed for FFI calls in check, store, and flush. *) + setupGlobal : Print.PD.pp_desc, + setupQuery : {index : int, params : int} -> Print.PD.pp_desc} + +end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 12ad309a..e6ecedde 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3404,7 +3404,11 @@ fun p_file env (ds, ps) = newline, (* For sqlcache. *) - box (List.map ToyCache.setupQuery (Sqlcache.getFfiInfo ())), + let + val {setupGlobal, setupQuery, ...} = Sqlcache.getCache () + in + box (setupGlobal :: newline :: List.map setupQuery (Sqlcache.getFfiInfo ())) + end, newline, p_list_sep newline (fn x => x) pds, diff --git a/src/sources b/src/sources index 05897cd4..aaf640ca 100644 --- a/src/sources +++ b/src/sources @@ -175,6 +175,7 @@ $(SRC)/union_find_fn.sml $(SRC)/multimap_fn.sml +$(SRC)/cache.sml $(SRC)/toy_cache.sml $(SRC)/sqlcache.sig diff --git a/src/sqlcache.sig b/src/sqlcache.sig index ccc1741a..fabc9ebf 100644 --- a/src/sqlcache.sig +++ b/src/sqlcache.sig @@ -1,6 +1,9 @@ signature SQLCACHE = sig -val ffiIndices : int list ref +val setCache : Cache.cache -> unit +val getCache : unit -> Cache.cache + +val getFfiInfo : unit -> {index : int, params : int} list val go : Mono.file -> Mono.file end diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 931c6737..3082904c 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,4 +1,4 @@ -structure Sqlcache (* :> SQLCACHE *) = struct +structure Sqlcache :> SQLCACHE = struct open Mono @@ -39,6 +39,10 @@ val ffiEffectful = andalso not (m = "Basis" andalso SS.member (fs, f)) end +val cache = ref ToyCache.cache +fun setCache c = cache := c +fun getCache () = !cache + (* Effect analysis. *) @@ -366,6 +370,8 @@ val tableDml = (* Program instrumentation. *) +val {check, store, flush, ...} = getCache () + val dummyLoc = ErrorMsg.dummySpan fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) @@ -400,8 +406,8 @@ fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = (* We ensure before this step that all arguments aren't effectful. by turning them into local variables as needed. *) val argsInc = map (incRels 1) args - val check = (ToyCache.check (i, args), dummyLoc) - val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc) + val check = (check (i, args), dummyLoc) + val store = (store (i, argsInc, urlifiedRel0), dummyLoc) val rel0 = (ERel 0, loc) in ECase (check, @@ -545,7 +551,7 @@ fun invalidations ((query, numArgs), dml) = fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = let val flushes = List.concat o - map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss) + map (fn (i, argss) => map (fn args => flush (i, args)) argss) val doExp = fn EDml (origDmlText, failureMode) => let diff --git a/src/toy_cache.sml b/src/toy_cache.sml index 23dfe4fe..126768b6 100644 --- a/src/toy_cache.sml +++ b/src/toy_cache.sml @@ -1,4 +1,7 @@ -structure ToyCache = struct +structure ToyCache : sig + val cache : Cache.cache +end = struct + (* Mono *) @@ -182,4 +185,10 @@ fun setupQuery {index, params} = val setupGlobal = string "/* No global setup for toy cache. */" + +(* Bundled up. *) + +val cache = {check = check, store = store, flush = flush, + setupQuery = setupQuery, setupGlobal = setupGlobal} + end -- cgit v1.2.3