# HG changeset patch # User Ziv Scully # Date 1414761903 14400 # Node ID 639e62ca2530088c4d61d7abfd80fde412e8b2aa # Parent edd634b889d0ad44d6646731e57ecdf2f992df7a Mostly finish effectfulness analysis. diff -r edd634b889d0 -r 639e62ca2530 caching-tests/test.db Binary file caching-tests/test.db has changed diff -r edd634b889d0 -r 639e62ca2530 caching-tests/test.ur --- a/caching-tests/test.ur Tue Oct 14 18:07:09 2014 -0400 +++ b/caching-tests/test.ur Fri Oct 31 09:25:03 2014 -0400 @@ -12,12 +12,11 @@ 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 -r edd634b889d0 -r 639e62ca2530 src/cjr_print.sml --- a/src/cjr_print.sml Tue Oct 14 18:07:09 2014 -0400 +++ b/src/cjr_print.sml Fri Oct 31 09:25:03 2014 -0400 @@ -3394,6 +3394,7 @@ 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 @@ 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 @@ 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 @@ 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);", + string " = strdup(s); cacheWrite", + string i, + 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 -r edd634b889d0 -r 639e62ca2530 src/main.mlton.sml --- a/src/main.mlton.sml Tue Oct 14 18:07:09 2014 -0400 +++ b/src/main.mlton.sml Fri Oct 31 09:25:03 2014 -0400 @@ -47,7 +47,6 @@ Elaborate.unifyMore := false; Compiler.dumpSource := false; Compiler.doIflow := false; - Compiler.doSqlcache := false; Demo.noEmacs := false; Settings.setDebug false) @@ -161,7 +160,7 @@ (Compiler.doIflow := true; doArgs rest) | "-sqlcache" :: rest => - (Compiler.doSqlcache := true; + (Settings.setSqlcache true; doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); diff -r edd634b889d0 -r 639e62ca2530 src/sources --- a/src/sources Tue Oct 14 18:07:09 2014 -0400 +++ b/src/sources Fri Oct 31 09:25:03 2014 -0400 @@ -168,6 +168,14 @@ $(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)/fuse.sig $(SRC)/fuse.sml -$(SRC)/sql.sig -$(SRC)/sql.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -207,11 +212,6 @@ $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml -$(SRC)/multimap_fn.sml - -$(SRC)/sqlcache.sig -$(SRC)/sqlcache.sml - $(SRC)/mono_inline.sml $(SRC)/cjr.sml diff -r edd634b889d0 -r 639e62ca2530 src/sql.sig --- a/src/sql.sig Tue Oct 14 18:07:09 2014 -0400 +++ b/src/sql.sig Fri Oct 31 09:25:03 2014 -0400 @@ -4,6 +4,12 @@ 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 -r edd634b889d0 -r 639e62ca2530 src/sql.sml --- a/src/sql.sml Tue Oct 14 18:07:09 2014 -0400 +++ b/src/sql.sml Fri Oct 31 09:25:03 2014 -0400 @@ -272,10 +272,12 @@ 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 -r edd634b889d0 -r 639e62ca2530 src/sqlcache.sml --- a/src/sqlcache.sml Tue Oct 14 18:07:09 2014 -0400 +++ b/src/sqlcache.sml Fri Oct 31 09:25:03 2014 -0400 @@ -15,10 +15,127 @@ 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 @@ (* 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 @@ 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 @@ 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 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 @@ 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 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 @@ | 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 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