summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr_print.sml19
-rw-r--r--src/monoize.sml3
-rw-r--r--src/sqlcache.sml113
3 files changed, 46 insertions, 89 deletions
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 *)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-17 09:19:52 +0000