Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2268:bc1ef958d801

Thread state through addCaching more carefully.

author	Ziv Scully <ziv@mit.edu>
date	Wed, 14 Oct 2015 23:10:10 -0400
parents	e5b7b066bf1b
children	f7bc7c11a656

comparison

equal deleted inserted replaced

-:e5b7b066bf1b
+:bc1ef958d801
 then raise Fail "Can't iterate function negative number of times."
 else if n = 0
 then x
 else iterate f (n-1) (f x)
-(* Filled in by [cacheWrap]. *)
+(* Filled in by [addFlushing]. *)
-val ffiInfo : {index : int, params : int} list ref = ref []
+val ffiInfoRef : {index : int, params : int} list ref = ref []
-fun resetFfiInfo () = ffiInfo := []
+fun resetFfiInfo () = ffiInfoRef := []
-fun getFfiInfo () = !ffiInfo
+fun getFfiInfo () = !ffiInfoRef
 (* Some FFIs have writing as their only effect, which the caching records. *)
 val ffiEffectful =
 (* ASK: how can this be less hard-coded? *)
 let
 (***********************)
 (* 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
+fun mapFst f (x, y) = (f x, y)
 (*******************)
 (* Effect Analysis *)
 (*******************)
 * 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) =
+fun cacheWrap (env, exp, resultTyp, args, state as (_, _, ffiInfo, index)) =
 let
 val loc = dummyLoc
 val rel0 = (ERel 0, loc)
 in
 case MonoFooify.urlify env (rel0, resultTyp) of
 NONE => NONE
 | SOME urlified =>
 let
-val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
 (* We ensure before this step that all arguments aren't effectful.
 by turning them into local variables as needed. *)
 val argsInc = map (incRels 1) args
-val check = (check (i, args), loc)
+val check = (check (index, args), loc)
-val store = (store (i, argsInc, urlified), loc)
+val store = (store (index, argsInc, urlified), loc)
 in
-SOME (ECase
+SOME ((ECase
 (check,
 [((PNone stringTyp, loc),
 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
 (* Boolean is false because we're not unurlifying from a cookie. *)
 (EUnurlify (rel0, resultTyp, false), loc))],
-{disc = (TOption stringTyp, loc), result = resultTyp}))
+{disc = (TOption stringTyp, loc), result = resultTyp})),
+(#1 state,
+#2 state,
+{index = index, params = length args} :: ffiInfo,
+index + 1))
 end
 end
 val maxFreeVar =
 MonoUtil.Exp.foldB
 0
 IS.empty
 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
-datatype subexp = Cachable of unit -> exp | Impure of exp
+type state = (SIMM.multimap
+* (Sql.query * int) IntBinaryMap.map
+* {index : int, params : int} list
+* int)
+datatype subexp = Cachable of state -> (exp * state) | Impure of exp
 val isImpure =
 fn Cachable _ => false
 | Impure _ => true
-val expOfSubexp =
+val runSubexp : subexp * state -> exp * state =
-fn Cachable f => f ()
+fn (Cachable f, state) => f state
-| Impure e => e
+| (Impure e, state) => (e, state)
 (* TODO: pick a number. *)
 val sizeWorthCaching = 5
-type state = (SIMM.multimap * (Sql.query * int) IntBinaryMap.map * int)
+fun cacheQuery (effs, env, state, q) : (exp' * state) =
+let
-fun incIndex (x, y, index) = (x, y, index+1)
+val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state
+val {query = queryText,
-fun cacheQuery effs env (state as (tableToIndices, indexToQueryNumArgs, index)) =
+state = resultTyp,
-fn q as {query = queryText,
+initial, body, tables, exps} = q
-state = resultTyp,
-initial, body, tables, exps} =>
-let
 val numArgs = maxFreeVar queryText + 1
 val queryExp = (EQuery q, dummyLoc)
 (* DEBUG *)
 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
 bound
 env)
 val attempt =
 (* Ziv misses Haskell's do notation.... *)
 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
-<\oguard\>
+</oguard/>
 Sql.parse Sql.query queryText
-<\obind\>
+</obind/>
 (fn queryParsed =>
-(cacheWrap (env, queryExp, resultTyp, args, index))
+(cacheWrap (env, queryExp, resultTyp, args, state))
-<\obind\>
+</obind/>
-(fn cachedExp =>
+(fn (cachedExp, state) =>
 SOME (cachedExp,
 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
 tableToIndices
 (tablesQuery queryParsed),
 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
-index + 1))))
+#3 state,
+#4 state))))
 in
 case attempt of
 SOME pair => pair
-(* Even in this case, we have to increment index to avoid some bug,
+| NONE => (EQuery q, state)
-but I forget exactly what it is or why this helps. *)
+end
-(* TODO: just use a reference for current index.... *)
-| NONE => (EQuery q, incIndex state)
+fun cachePure (env, exp', state as (_, _, _, index)) =
-end
-fun cachePure (env, exp', (_, _, index)) =
 case (expSize (exp', dummyLoc) > sizeWorthCaching)
 </oguard/>
 typOfExp' env exp' of
 NONE => NONE
 | SOME (TFun _, _) => NONE
 (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))
+(fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state))
-fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) : subexp * state =
+fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) =
 let
-fun wrapBindN f (args : (MonoEnv.env * exp) list) =
+fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) =
 let
 val (subexps, state) = ListUtil.foldlMap (cache effs) state args
-fun mkExp () = (f (map expOfSubexp subexps), loc)
+fun mkExp state = mapFst (fn exps => (f exps, loc))
+(ListUtil.foldlMap runSubexp state subexps)
 in
 if List.exists isImpure subexps
-then (Impure (mkExp ()), state)
+then mapFst Impure (mkExp state)
-else (Cachable (fn () => case cachePure (env, f (map #2 args), state) of
+else (Cachable (fn state =>
-NONE => mkExp ()
+case cachePure (env, f (map #2 args), state) of
-| SOME e' => (e', loc)),
+NONE => mkExp state
-(* Conservatively increment index. *)
+| SOME (e', state) => ((e', loc), state)),
-incIndex state)
+state)
 end
 fun wrapBind1 f arg =
 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
 fun wrapBind2 f (arg1, arg2) =
 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
 ((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
+val (exp', state) = cacheQuery (effs, env, state, q)
 in
 (Impure (exp', loc), state)
 end
 | _ => if effectful effs env exp
 then (Impure exp, state)
-else (Cachable (fn () => (case cachePure (env, exp', state) of
+else (Cachable (fn state =>
-NONE => exp'
+case cachePure (env, exp', state) of
-| SOME e' => e',
+NONE => ((exp', loc), state)
-loc)),
+| SOME (exp', state) => ((exp', loc), state)),
-incIndex state)
+state)
 end
 fun addCaching file =
 let
 val effs = effectfulDecls file
-fun doTopLevelExp env exp state =
+fun doTopLevelExp env exp state = runSubexp (cache effs ((env, exp), state))
-let
+in
-val (subexp, state) = cache effs ((env, exp), state)
+((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, [], 0)), effs)
-in
-(expOfSubexp subexp, state)
-end
-in
-((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, 0)), effs)
 end
 (************)
 (* Flushing *)
 (* DEBUG *)
 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
 (* val gunk' : exp list ref = ref [] *)
-fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
+fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, ffiInfo, index)), effs) =
 let
 val flushes = List.concat
 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
 val doExp =
 fn dmlExp as EDml (dmlText, failureMode) =>
 end
 | e' => e'
 in
 (* DEBUG *)
 (* gunk := []; *)
+ffiInfoRef := ffiInfo;
 fileMap doExp file
 end
-(***************)
+(************************)
-(* Entry point *)
+(* Compiler Entry Point *)
-(***************)
+(************************)
 val inlineSql =
 let
 val doExp =
 (* TODO: EQuery, too? *)

Mercurial > urweb

comparison src/sqlcache.sml @ 2268:bc1ef958d801