summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/sqlcache.sml343
1 files changed, 159 insertions, 184 deletions
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 1a4d4e97..99c89ff7 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -56,6 +56,19 @@ val doBind =
| (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
| (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
+(***********************)
+(* General Combinators *)
+(***********************)
+
+(* From the MLton wiki. *)
+infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
+infix 3 \> fun f \> y = f y (* Left application *)
+infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *)
+infixr 3 </ fun x </ f = f x (* Right application *)
+
+(* Option monad. *)
+fun obind (x, f) = Option.mapPartial f x
+fun oguard (b, x) = if b then x else NONE
(*******************)
(* Effect Analysis *)
@@ -542,6 +555,49 @@ fun fileAllMapfoldB doExp file start =
fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
+(* Takes a text expression and returns
+ newText: a new expression with any subexpressions that do computation
+ replaced with variables,
+ wrapLets: a function that wraps its argument expression with lets binding
+ those variables to their corresponding computations, and
+ numArgs: the number of such bindings.
+ The De Bruijn indices work out for [wrapLets (incRels numArgs newText)], but
+ the intention is that newText might be augmented. *)
+fun factorOutNontrivial text =
+ let
+ val loc = dummyLoc
+ 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 newVars will have the lowest index. *)
+ case chunk of
+ (* EPrim should always be a string in this case. *)
+ 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 (varName "sqlArg", stringTyp, v, (e', loc)))
+ e'
+ newVariables
+ val numArgs = length newVariables
+ in
+ (newText, wrapLets, numArgs)
+ end
+
(**********************)
(* Mono Type Checking *)
@@ -599,9 +655,9 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
and typOfExp env (e', loc) = typOfExp' env e'
-(*******************************)
-(* Caching Pure Subexpressions *)
-(*******************************)
+(***********)
+(* Caching *)
+(***********)
fun cacheWrap (env, exp, resultTyp, args, i) =
let
@@ -644,57 +700,6 @@ val freeVars =
val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
-structure InvalidationInfo :> sig
- type t
- val empty : t
- val fromList : int list -> t
- val toList : t -> int list
- val union : t * t -> t
- val unbind : t * int -> t option
-end = struct
-
-(* Keep track of the minimum explicitly. NONE is the empty set. *)
-type t = (int * IS.set) option
-
-val fromList =
- List.foldl
- (fn (n, NONE) => SOME (n, IS.singleton n)
- | (n', SOME (n, ns)) => SOME (Int.min (n, n'), IS.add (ns, n')))
- NONE
-
-val empty = fromList []
-
-val toList =
- fn NONE => []
- | SOME (_, ns) => IS.listItems ns
-
-val union =
- fn (SOME (n1, ns1), SOME (n2, ns2)) => SOME (Int.min (n1, n2), IS.union (ns1, ns2))
- | (NONE, info) => info
- | (info, NONE) => info
-
-val unbind =
- fn (SOME (n, ns), unbound) =>
- let
- val n = n - unbound
- in
- if n < 0
- then NONE
- else SOME (SOME (n, IS.map (fn n => n - unbound) ns))
- end
- | _ => SOME NONE
-
-end
-
-val unionUnbind =
- List.foldl
- (fn (_, NONE) => NONE
- | ((info, unbound), SOME infoAcc) =>
- case InvalidationInfo.unbind (info, unbound) of
- NONE => NONE
- | SOME info => SOME (InvalidationInfo.union (info, infoAcc)))
- (SOME InvalidationInfo.empty)
-
datatype subexp = Pure of unit -> exp | Impure of exp
val isImpure =
@@ -708,38 +713,101 @@ val expOfSubexp =
(* TODO: pick a number. *)
val sizeWorthCaching = 5
-fun makeCache (env, exp', index) =
+type state = (SIMM.multimap * (Sql.query * int) IntBinaryMap.map * int)
+
+fun incIndex (x, y, index) = (x, y, index+1)
+
+fun cacheQuery effs env (state as (tableToIndices, indexToQueryNumArgs, index)) =
+ fn q as {query = origQueryText,
+ state = resultTyp,
+ initial, body, tables, exps} =>
+ let
+ val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
+ (* Increment once for each new variable just made. This is where we
+ use the negative De Bruijn indices hack. *)
+ (* TODO: please don't use that hack. As anyone could have predicted, it
+ was incomprehensible a year later.... *)
+ val queryExp = incRels numArgs
+ (EQuery {query = newQueryText,
+ state = resultTyp,
+ initial = initial,
+ body = body,
+ tables = tables,
+ exps = exps},
+ dummyLoc)
+ (* DEBUG *)
+ (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
+ val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
+ (* We use dummyTyp here. I think this is okay because databases don't
+ store (effectful) functions, but perhaps there's some pathalogical
+ corner case missing.... *)
+ fun safe bound =
+ not
+ o effectful effs
+ (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
+ bound
+ env)
+ val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
+ val attempt =
+ (* Ziv misses Haskell's do notation.... *)
+ textOfQuery queryExp
+ <\obind\>
+ (fn queryText =>
+ (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
+ <\oguard\>
+ Sql.parse Sql.query queryText
+ <\obind\>
+ (fn queryParsed =>
+ (cacheWrap (env, queryExp, resultTyp, args, index))
+ <\obind\>
+ (fn cachedExp =>
+ SOME (wrapLets cachedExp,
+ (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
+ tableToIndices
+ (tablesQuery queryParsed),
+ IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
+ index + 1)))))
+ in
+ case attempt of
+ SOME pair => pair
+ (* Even in this case, we have to increment index to avoid some bug,
+ but I forget exactly what it is or why this helps. *)
+ (* TODO: just use a reference for current index.... *)
+ | NONE => (EQuery q, incIndex state)
+ end
+
+fun cachePure (env, exp', (_, _, index)) =
case typOfExp' env exp' of
NONE => NONE
| SOME (TFun _, _) => NONE
| SOME typ =>
- if expSize (exp', dummyLoc) < sizeWorthCaching
- then NONE
- else case List.foldr (fn ((_, _), NONE) => NONE
- | ((n, typ), SOME args) =>
- case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of
- NONE => NONE
- | SOME arg => SOME (arg :: args))
- (SOME [])
- (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
- (freeVars (exp', dummyLoc))) of
- NONE => NONE
- | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index)
-
-fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int =
+ (expSize (exp', dummyLoc) < sizeWorthCaching)
+ </oguard/>
+ (List.foldr (fn (_, NONE) => NONE
+ | ((n, typ), SOME args) =>
+ (MonoFooify.urlify env ((ERel n, dummyLoc), typ))
+ </obind/>
+ (fn arg => SOME (arg :: args)))
+ (SOME [])
+ (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
+ (freeVars (exp', dummyLoc))))
+ </obind/>
+ (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, index))
+
+fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) : subexp * state =
let
fun wrapBindN f (args : (MonoEnv.env * exp) list) =
let
- val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args
+ val (subexps, state) = ListUtil.foldlMap (cache effs) state args
fun mkExp () = (f (map expOfSubexp subexps), loc)
in
if List.exists isImpure subexps
- then (Impure (mkExp ()), index)
- else (Pure (fn () => case makeCache (env, f (map #2 args), index) of
+ then (Impure (mkExp ()), state)
+ else (Pure (fn () => case cachePure (env, f (map #2 args), state) of
NONE => mkExp ()
| SOME e' => (e', loc)),
(* Conservatively increment index. *)
- index + 1)
+ incIndex state)
end
fun wrapBind1 f arg =
wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
@@ -754,7 +822,7 @@ fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int
| ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
| EFfiApp (s1, s2, args) =>
if ffiEffectful (s1, s2)
- then (Impure exp, index)
+ then (Impure exp, state)
else wrapN (fn es =>
EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
(map #1 args)
@@ -784,125 +852,32 @@ fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int
((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
(* ASK: | EClosure (n, es) => ? *)
| EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
+ | EQuery q =>
+ let
+ val (exp', state) = cacheQuery effs env state q
+ in
+ (Impure (exp', loc), state)
+ end
| _ => if effectful effs env exp
- then (Impure exp, index)
- else (Pure (fn () => (case makeCache (env, exp', index) of
+ then (Impure exp, state)
+ else (Pure (fn () => (case cachePure (env, exp', state) of
NONE => exp'
| SOME e' => e',
loc)),
- index + 1)
+ incIndex state)
end
-fun addPure (file, indexStart, effs) =
+fun addCaching file =
let
- fun doTopLevelExp env exp index =
+ val effs = effectfulDecls file
+ fun doTopLevelExp env exp state =
let
- val (subexp, index) = pureCache effs ((env, exp), index)
+ val (subexp, state) = cache effs ((env, exp), state)
in
- (expOfSubexp subexp, index)
+ (expOfSubexp subexp, state)
end
in
- #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart)
- end
-
-
-(***********************)
-(* Caching SQL Queries *)
-(***********************)
-
-fun factorOutNontrivial text =
- let
- val loc = dummyLoc
- 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 (varName "sqlArg", stringTyp, v, (e', loc)))
- e'
- newVariables
- val numArgs = length newVariables
- in
- (newText, wrapLets, numArgs)
- end
-
-fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
- fn e' as EQuery {query = origQueryText,
- 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,
- state = resultTyp,
- initial = initial,
- body = body,
- tables = tables,
- exps = exps},
- dummyLoc)
- (* DEBUG *)
- (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
- 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
- (* We use dummyTyp here. I think this is okay because databases don't
- store (effectful) functions, but perhaps there's some pathalogical
- corner case missing.... *)
- fun safe bound =
- not
- o effectful effs
- (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
- bound
- env)
- val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
- val attempt =
- (* Ziv misses Haskell's do notation.... *)
- bind (textOfQuery queryExp) (fn queryText =>
- guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
- bind (Sql.parse Sql.query queryText) (fn queryParsed =>
- bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
- SOME (wrapLets cachedExp,
- (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
- tableToIndices
- (tablesQuery queryParsed),
- IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
- index + 1))))))
- in
- case attempt of
- SOME pair => pair
- (* We have to increment index conservatively. *)
- (* TODO: just use a reference for current index.... *)
- | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
- end
- | e' => (e', queryInfo)
-
-fun addChecking file =
- let
- val effs = effectfulDecls file
- in
- (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
- file
- (SIMM.empty, IM.empty, 0),
- effs)
+ ((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, 0)), effs)
end
@@ -995,7 +970,7 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
in
(* DEBUG *)
(* gunk := []; *)
- (fileMap doExp file, index, effs)
+ fileMap doExp file
end
@@ -1026,7 +1001,7 @@ fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
(datatypes @ newDecls @ others, sideInfo)
end
-val go' = addPure o addFlushing o addChecking o inlineSql
+val go' = addFlushing o addCaching o inlineSql
fun go file =
let
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-12 16:54:55 +0000