aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-10-31 09:25:03 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2014-10-31 09:25:03 -0400
commit7b94f3433f47e4e5010dc2af6010181da49637e8 (patch)
treedf609b60422a34b84de0420720afd59ce30b7989
parent0185025d29459fe681afa1c01faa22a5d8034884 (diff)
Mostly finish effectfulness analysis.
Diffstat
-rw-r--r--caching-tests/test.dbbin5120 -> 5120 bytes
-rw-r--r--caching-tests/test.ur7
-rw-r--r--src/cjr_print.sml29
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/sources16
-rw-r--r--src/sql.sig6
-rw-r--r--src/sql.sml8
-rw-r--r--src/sqlcache.sml225
8 files changed, 242 insertions, 52 deletions
diff --git a/caching-tests/test.db b/caching-tests/test.db
index 944aa851..66b6ad88 100644
--- a/caching-tests/test.db
+++ b/caching-tests/test.db
Binary files 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 () =
</body></xml>
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 => <xml>{[row.Foo10.Bar]}</xml>);
return <xml><body>
Reading 2.
- {case res of
- None => <xml>?</xml>
- | Some row => <xml>{[row.Foo10.Bar]}</xml>}
+ {res}
</body></xml>
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 13:25:40 +0000