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. --- src/main.mlton.sml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'src/main.mlton.sml') 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 () -- 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/main.mlton.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 94b1dbce1ae20ded6b2e8cc519f56ac9e3b39b24 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 19 Nov 2015 17:29:47 -0500 Subject: Add consolidation heuristic options. --- src/main.mlton.sml | 3 ++ src/settings.sig | 2 ++ src/settings.sml | 4 +++ src/sqlcache.sml | 95 +++++++++++++++++++++++++++++------------------------- 4 files changed, 60 insertions(+), 44 deletions(-) (limited to 'src/main.mlton.sml') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 3ae968b0..d3d88af9 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -162,6 +162,9 @@ fun oneRun args = | "-sqlcache" :: rest => (Settings.setSqlcache true; doArgs rest) + | "-heuristic" :: h :: rest => + (Settings.setSqlcacheHeuristic h; + doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); raise Code OS.Process.success) diff --git a/src/settings.sig b/src/settings.sig index e94832e0..d4bb4b08 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -281,6 +281,8 @@ signature SETTINGS = sig val setSqlcache : bool -> unit val getSqlcache : unit -> bool + val setSqlcacheHeuristic : string -> unit + val getSqlcacheHeuristic : unit -> string 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 f9125c64..073e7883 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -811,6 +811,10 @@ val sqlcache = ref false fun setSqlcache b = sqlcache := b fun getSqlcache () = !sqlcache +val sqlcacheHeuristic = ref "always" +fun setSqlcacheHeuristic h = sqlcacheHeuristic := h +fun getSqlcacheHeuristic () = !sqlcacheHeuristic + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare diff --git a/src/sqlcache.sml b/src/sqlcache.sml index ce5ad5f5..312ee217 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -93,9 +93,17 @@ val cacheRef = ref LruCache.cache fun setCache c = cacheRef := c fun getCache () = !cacheRef -val alwaysConsolidateRef = ref true -fun setAlwaysConsolidate b = alwaysConsolidateRef := b -fun getAlwaysConsolidate () = !alwaysConsolidateRef +datatype heuristic = Always | Never | NoPureAll | NoPureOne | NoCombo + +val heuristicRef = ref Always +fun setHeuristic h = heuristicRef := (case h of + "always" => Always + | "never" => Never + | "nopureall" => NoPureAll + | "nopureone" => NoPureOne + | "nocombo" => NoCombo + | _ => raise Fail "Sqlcache: setHeuristic") +fun getHeuristic () = !heuristicRef (************************) @@ -463,7 +471,7 @@ structure InvalInfo :> sig val empty : t val singleton : Sql.query -> t val query : t -> Sql.query - val orderArgs : t * Mono.exp -> cacheArg list + val orderArgs : t * Mono.exp -> cacheArg list option val unbind : t * unbind -> t option val union : t * t -> t val updateState : t * int * state -> state @@ -635,11 +643,20 @@ end = struct val argsMap = sqlArgsMap qs val args = map (expOfArg o #1) (AM.listItemsi argsMap) val invalPaths = List.foldl PS.union PS.empty (map freePaths args) + (* TODO: make sure these variables are okay to remove from the argument list. *) + val pureArgs = PS.difference (paths, invalPaths) + val shouldCache = + case getHeuristic () of + Always => true + | Never => (case qs of [_] => true | _ => false) + | NoPureAll => (case qs of [] => false | _ => true) + | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0) + | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0 in (* Put arguments we might invalidate by first. *) - map AsIs args - (* TODO: make sure these variables are okay to remove from the argument list. *) - @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths))) + if shouldCache + then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs)) + else NONE end (* As a kludge, we rename the variables in the query to correspond to the @@ -1309,47 +1326,35 @@ val worthCaching = fn EQuery _ => true | exp' => expSize (exp', dummyLoc) > sizeWorthCaching -fun shouldConsolidate args = - let - val isAsIs = fn AsIs _ => true | Urlify _ => false - in - getAlwaysConsolidate () - orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args) - end - fun cacheExp (env, exp', invalInfo, state : state) = case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of NONE => NONE | SOME (TFun _, _) => NONE | SOME typ => - let - val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) - in - shouldConsolidate args - <\oguard\> - (fn _ => - List.foldr (fn (arg, acc) => - acc - <\obind\> - (fn args' => - (case arg of - AsIs exp => SOME exp - | Urlify exp => - typOfExp env exp - <\obind\> - (fn typ => (MonoFooify.urlify env (exp, typ)))) - <\obind\> - (fn arg' => SOME (arg' :: args')))) - (SOME []) - args - <\obind\> - (fn args' => - cacheWrap (env, (exp', dummyLoc), typ, args', #index state) - <\obind\> - (fn cachedExp => - SOME (cachedExp, - InvalInfo.updateState (invalInfo, length args', state))))) - end + InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) + <\obind\> + (fn args => + List.foldr (fn (arg, acc) => + acc + <\obind\> + (fn args' => + (case arg of + AsIs exp => SOME exp + | Urlify exp => + typOfExp env exp + <\obind\> + (fn typ => (MonoFooify.urlify env (exp, typ)))) + <\obind\> + (fn arg' => SOME (arg' :: args')))) + (SOME []) + args + <\obind\> + (fn args' => + cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + <\obind\> + (fn cachedExp => + SOME (cachedExp, + InvalInfo.updateState (invalInfo, length args', state))))) fun cacheQuery (effs, env, q) : subexp = let @@ -1684,7 +1689,9 @@ val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql fun go file = let (* TODO: do something nicer than [Sql] being in one of two modes. *) - val () = (resetFfiInfo (); Sql.sqlcacheMode := true) + val () = (resetFfiInfo (); + Sql.sqlcacheMode := true; + setHeuristic (Settings.getSqlcacheHeuristic ())) val file = go' file (* Important that this happens after [MonoFooify.urlify] calls! *) val fmDecls = MonoFooify.getNewFmDecls () -- cgit v1.2.3 From a0d66adaeceaa07e4006a0570211f7453a5b5738 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 20 Nov 2015 03:26:21 -0500 Subject: Tweak cache consolidation and choose better default. --- src/main.mlton.sml | 2 +- src/settings.sig | 2 -- src/settings.sml | 4 ---- src/sqlcache.sig | 2 ++ src/sqlcache.sml | 40 +++++++++++++++++++++------------------- 5 files changed, 24 insertions(+), 26 deletions(-) (limited to 'src/main.mlton.sml') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index d3d88af9..164ddfbd 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -163,7 +163,7 @@ fun oneRun args = (Settings.setSqlcache true; doArgs rest) | "-heuristic" :: h :: rest => - (Settings.setSqlcacheHeuristic h; + (Sqlcache.setHeuristic h; doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); diff --git a/src/settings.sig b/src/settings.sig index d4bb4b08..e94832e0 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -281,8 +281,6 @@ signature SETTINGS = sig val setSqlcache : bool -> unit val getSqlcache : unit -> bool - val setSqlcacheHeuristic : string -> unit - val getSqlcacheHeuristic : unit -> string 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 073e7883..f9125c64 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -811,10 +811,6 @@ val sqlcache = ref false fun setSqlcache b = sqlcache := b fun getSqlcache () = !sqlcache -val sqlcacheHeuristic = ref "always" -fun setSqlcacheHeuristic h = sqlcacheHeuristic := h -fun getSqlcacheHeuristic () = !sqlcacheHeuristic - structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare diff --git a/src/sqlcache.sig b/src/sqlcache.sig index fabc9ebf..e264c1f0 100644 --- a/src/sqlcache.sig +++ b/src/sqlcache.sig @@ -3,6 +3,8 @@ signature SQLCACHE = sig val setCache : Cache.cache -> unit val getCache : unit -> Cache.cache +val setHeuristic : string -> unit + val getFfiInfo : unit -> {index : int, params : int} list val go : Mono.file -> Mono.file diff --git a/src/sqlcache.sml b/src/sqlcache.sml index b2c8504b..75a17e48 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -93,12 +93,11 @@ val cacheRef = ref LruCache.cache fun setCache c = cacheRef := c fun getCache () = !cacheRef -datatype heuristic = SmartEq (* | SmartSub *) | Always | Never | NoPureAll | NoPureOne | NoCombo +datatype heuristic = Smart | Always | Never | NoPureAll | NoPureOne | NoCombo -val heuristicRef = ref Always +val heuristicRef = ref NoPureOne fun setHeuristic h = heuristicRef := (case h of - "smarteq" => SmartEq - (* | "smartsub" => SmartSub *) + "smart" => Smart | "always" => Always | "never" => Never | "nopureall" => NoPureAll @@ -498,6 +497,7 @@ end = struct structure I = SK structure J = SK structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) + structure AS = BinarySetFn(AK) structure AM = BinaryMapFn(AK) (* Traversal Utilities *) @@ -615,13 +615,16 @@ end = struct val union = op@ - fun addToSqlArgsMap ((q, subst), acc) = - IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst + fun sqlArgsSet (q, subst) = + IM.foldl AS.add' AS.empty subst fun sqlArgsMap (qs : t) = let val args = - List.foldl addToSqlArgsMap AM.empty qs + List.foldl (fn ((q, subst), acc) => + IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst) + AM.empty + qs val countRef = ref (~1) fun count () = (countRef := !countRef + 1; !countRef) in @@ -649,25 +652,26 @@ end = struct val pureArgs = PS.difference (paths, invalPaths) val shouldCache = case getHeuristic () of - SmartEq => + Smart => (case (qs, PS.numItems pureArgs) of ((q::qs), 0) => let - val m = addToSqlArgsMap (q, AM.empty) - val ms = map (fn q => addToSqlArgsMap (q, AM.empty)) qs - fun test (m, acc) = + val args = sqlArgsSet q + val argss = map sqlArgsSet qs + fun test (args, acc) = acc <\obind\> - (fn m' => + (fn args' => let - val mm = AM.unionWith #1 (m, m') + val both = AS.union (args, args') in - AM.numItems m = AM.numItems mm + (AS.numItems args = AS.numItems both + orelse AS.numItems args' = AS.numItems both) <\oguard\> - (fn _ => SOME mm) + (fn _ => SOME both) end) in - case List.foldl test (SOME m) ms of + case List.foldl test (SOME args) argss of NONE => false | SOME _ => true end @@ -1714,9 +1718,7 @@ val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql fun go file = let (* TODO: do something nicer than [Sql] being in one of two modes. *) - val () = (resetFfiInfo (); - Sql.sqlcacheMode := true; - setHeuristic (Settings.getSqlcacheHeuristic ())) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) val file = go' file (* Important that this happens after [MonoFooify.urlify] calls! *) val fmDecls = MonoFooify.getNewFmDecls () -- cgit v1.2.3