Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2267:e5b7b066bf1b

Factor out SQL simplification.

author	Ziv Scully <ziv@mit.edu>
date	Wed, 14 Oct 2015 20:40:57 -0400
parents	afd12c75e0d6
children	bc1ef958d801

comparison

equal deleted inserted replaced

-:afd12c75e0d6
+:e5b7b066bf1b
 Search.Continue x => x
 | Search.Return _ => raise Match
 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
-(* Takes a text expression and returns
+(* TODO: make this a bit prettier.... *)
-newText: a new expression with any subexpressions that do computation
+val simplifySql =
-replaced with variables,
+let
-wrapLets: a function that wraps its argument expression with lets binding
+fun factorOutNontrivial text =
-those variables to their corresponding computations, and
+let
-numArgs: the number of such bindings.
+val loc = dummyLoc
-The De Bruijn indices work out for [wrapLets (incRels numArgs newText)], but
+fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
-the intention is that newText might be augmented. *)
+val chunks = Sql.chunkify text
-fun factorOutNontrivial text =
+val (newText, newVariables) =
-let
+(* Important that this is foldr (to oppose foldl below). *)
-val loc = dummyLoc
+List.foldr
-fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+(fn (chunk, (qText, newVars)) =>
-val chunks = Sql.chunkify text
+(* Variable bound to the head of newVars will have the lowest index. *)
-val (newText, newVariables) =
+case chunk of
-(* Important that this is foldr (to oppose foldl below). *)
+(* EPrim should always be a string in this case. *)
-List.foldr
+Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
-(fn (chunk, (qText, newVars)) =>
+| Sql.Exp e =>
-(* Variable bound to the head of newVars will have the lowest index. *)
+let
-case chunk of
+val n = length newVars
-(* EPrim should always be a string in this case. *)
+in
-Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+(* This is the (n+1)th new variable, so there are
-| Sql.Exp e =>
+already n new variables bound, so we increment
-let
+indices by n. *)
-val n = length newVars
+(strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
-in
+end
-(* This is the (n+1)th new variable, so there are
+| Sql.String s => (strcat (stringExp s, qText), newVars))
-already n new variables bound, so we increment
+(stringExp "", [])
-indices by n. *)
+chunks
-(strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+fun wrapLets e' =
-end
+(* Important that this is foldl (to oppose foldr above). *)
-| Sql.String s => (strcat (stringExp s, qText), newVars))
+List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
-(stringExp "", [])
+e'
-chunks
+newVariables
-fun wrapLets e' =
+val numArgs = length newVariables
-(* Important that this is foldl (to oppose foldr above). *)
+in
-List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
+(newText, wrapLets, numArgs)
-e'
+end
-newVariables
+fun doExp exp' =
-val numArgs = length newVariables
+let
-in
+val text = case exp' of
-(newText, wrapLets, numArgs)
+EQuery {query = text, ...} => text
+| EDml (text, _) => text
+| _ => raise Match
+val (newText, wrapLets, numArgs) = factorOutNontrivial text
+val newExp' = case exp' of
+EQuery q => EQuery {query = newText,
+exps = #exps q,
+tables = #tables q,
+state = #state q,
+body = #body q,
+initial = #initial q}
+| EDml (_, failureMode) => EDml (newText, failureMode)
+| _ => raise Match
+in
+(* 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.... *)
+wrapLets (#1 (incRels numArgs (newExp', dummyLoc)))
+end
+in
+fileMap (fn exp' => case exp' of
+EQuery _ => doExp exp'
+| EDml _ => doExp exp'
+| _ => exp')
 end
 (**********************)
 (* Mono Type Checking *)
 (***********)
 (* Caching *)
 (***********)
+(*
+To get the invalidations for a dml, we need (each <- is list-monad-y):
+* table <- dml
+* cache <- table
+* query <- cache
+* inval <- (query, dml),
+where inval is a list of query argument indices, so
+* way to change query args in inval to cache args.
+For now, the last one is just
+* a map from query arg number to the corresponding free variable (per query)
+* a map from free variable to cache arg number (per cache).
+Both queries and caches should have IDs.
+*)
 fun cacheWrap (env, exp, resultTyp, args, i) =
 let
 val loc = dummyLoc
 val rel0 = (ERel 0, loc)
 in
 (EUnurlify (rel0, resultTyp, false), loc))],
 {disc = (TOption stringTyp, loc), result = resultTyp}))
 end
 end
+val maxFreeVar =
+MonoUtil.Exp.foldB
+{typ = #2,
+exp = fn (bound, ERel n, v) => Int.max (v, n - bound) | (_, _, v) => v,
+bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
+0
+~1
 val freeVars =
 IS.listItems
 o MonoUtil.Exp.foldB
 {typ = #2,
 exp = fn (bound, ERel n, vars) => if n < bound
 0
 IS.empty
 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
-datatype subexp = Pure of unit -> exp | Impure of exp
+datatype subexp = Cachable of unit -> exp | Impure of exp
 val isImpure =
-fn Pure _ => false
+fn Cachable _ => false
 | Impure _ => true
 val expOfSubexp =
-fn Pure f => f ()
+fn Cachable f => f ()
 | Impure e => e
 (* TODO: pick a number. *)
 val sizeWorthCaching = 5
 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,
+fn q as {query = queryText,
 state = resultTyp,
 initial, body, tables, exps} =>
 let
-val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
+val numArgs = maxFreeVar queryText + 1
-(* Increment once for each new variable just made. This is where we
+val queryExp = (EQuery q, dummyLoc)
-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
 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
+(safe 0 queryText andalso safe 0 initial andalso safe 2 body)
+<\oguard\>
+Sql.parse Sql.query queryText
 <\obind\>
-(fn queryText =>
+(fn queryParsed =>
-(safe 0 queryText andalso safe 0 initial andalso safe 2 body)
+(cacheWrap (env, queryExp, resultTyp, args, index))
-<\oguard\>
-Sql.parse Sql.query queryText
 <\obind\>
-(fn queryParsed =>
+(fn cachedExp =>
-(cacheWrap (env, queryExp, resultTyp, args, index))
+SOME (cachedExp,
-<\obind\>
+(SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
-(fn cachedExp =>
+tableToIndices
-SOME (wrapLets cachedExp,
+(tablesQuery queryParsed),
-(SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
+IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
-tableToIndices
+index + 1))))
-(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
+case (expSize (exp', dummyLoc) > sizeWorthCaching)
+</oguard/>
+typOfExp' env exp' of
 NONE => NONE
 | SOME (TFun _, _) => NONE
 | SOME typ =>
-(expSize (exp', dummyLoc) < sizeWorthCaching)
+(List.foldr (fn (_, NONE) => NONE
-</oguard/>
+| ((n, typ), SOME args) =>
-(List.foldr (fn (_, NONE) => NONE
+(MonoFooify.urlify env ((ERel n, dummyLoc), typ))
-| ((n, typ), SOME args) =>
+</obind/>
-(MonoFooify.urlify env ((ERel n, dummyLoc), typ))
+(fn arg => SOME (arg :: args)))
-</obind/>
+(SOME [])
-(fn arg => SOME (arg :: args)))
+(map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
-(SOME [])
+(freeVars (exp', dummyLoc))))
-(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
 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 ()), state)
-else (Pure (fn () => case cachePure (env, f (map #2 args), state) of
+else (Cachable (fn () => case cachePure (env, f (map #2 args), state) of
 NONE => mkExp ()
 | SOME e' => (e', loc)),
 (* Conservatively increment index. *)
 incIndex state)
 end
 fun wrapBind1 f arg =
 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
 in
 (Impure (exp', loc), state)
 end
 | _ => if effectful effs env exp
 then (Impure exp, state)
-else (Pure (fn () => (case cachePure (env, exp', state) of
+else (Cachable (fn () => (case cachePure (env, exp', state) of
 NONE => exp'
 | SOME e' => e',
 loc)),
 incIndex state)
 end
 fun addCaching file =
 let
 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
 let
 val flushes = List.concat
 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
 val doExp =
-fn EDml (origDmlText, failureMode) =>
+fn dmlExp as EDml (dmlText, failureMode) =>
 let
 (* DEBUG *)
 (* val () = gunk' := origDmlText :: !gunk' *)
-val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
-val dmlText = incRels numArgs newDmlText
-val dmlExp = EDml (dmlText, failureMode)
-(* DEBUG *)
 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
 val inval =
 case Sql.parse Sql.dml dmlText of
 SOME dmlParsed =>
 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
 | NONE => NONE
 in
 case inval of
 (* TODO: fail more gracefully. *)
 NONE => raise Match
-| SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
+| SOME invs => sequence (flushes invs @ [dmlExp])
 end
 | e' => e'
 in
 (* DEBUG *)
 (* gunk := []; *)
 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
 in
 (datatypes @ newDecls @ others, sideInfo)
 end
-val go' = addFlushing o addCaching o inlineSql
+val go' = 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)

Mercurial > urweb

comparison src/sqlcache.sml @ 2267:e5b7b066bf1b