From f8d7c70d8f52003e14a66144a48bb4f06a1c185f Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 27 Sep 2015 03:52:14 -0400 Subject: Pure caching sort of works. --- src/sqlcache.sml | 162 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 115 insertions(+), 47 deletions(-) (limited to 'src/sqlcache.sml') diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 6b4216ea..eaa94685 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -493,27 +493,34 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (env, query, i, resultTyp, args) = +fun cacheWrap (env, exp, resultTyp, args, i) = let - val () = ffiInfo := {index = i, params = length args} :: !ffiInfo val loc = dummyLoc val rel0 = (ERel 0, loc) - (* 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), dummyLoc) - val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc) in - ECase (check, - [((PNone stringTyp, loc), - (ELet (varName "q", resultTyp, query, (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 = stringTyp, result = resultTyp}) + 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 store = (store (i, argsInc, urlified), loc) + in + 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})) + end end -fun fileMapfold doExp file start = +fun fileMapfoldB doExp file start = case MonoUtil.File.mapfoldB {typ = Search.return2, exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), @@ -523,7 +530,7 @@ fun fileMapfold doExp file start = Search.Continue x => x | Search.Return _ => raise Match -fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ()) +fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) fun factorOutNontrivial text = let @@ -561,6 +568,7 @@ fun factorOutNontrivial text = fun addChecking file = let + val effs = effectfulDecls file fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = fn e' as EQuery {query = origQueryText, state = resultTyp, @@ -582,7 +590,6 @@ fun addChecking file = 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 - val effs = effectfulDecls file (* 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.... *) @@ -596,12 +603,13 @@ 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 => - SOME (wrapLets (cacheWrap (env, queryExp, index, resultTyp, args)), + 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)))) + index + 1))))) in case attempt of SOME pair => pair @@ -609,9 +617,10 @@ fun addChecking file = end | e' => (e', queryInfo) in - fileMapfold (fn env => fn exp => fn state => doExp env state exp) - file - (SIMM.empty, IM.empty, 0) + (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp) + file + (SIMM.empty, IM.empty, 0), + effs) end structure Invalidations = struct @@ -662,7 +671,7 @@ val invalidations = Invalidations.invalidations (* DEBUG *) val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] -fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = +fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let val flushes = List.concat o map (fn (i, argss) => map (fn args => flush (i, args)) argss) @@ -694,7 +703,7 @@ fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = in (* DEBUG *) gunk := []; - fileMap doExp file + (fileMap doExp file, index, effs) end val inlineSql = @@ -713,25 +722,11 @@ val inlineSql = fileMap doExp end -fun go file = - let - (* TODO: do something nicer than [Sql] being in one of two modes. *) - val () = (resetFfiInfo (); Sql.sqlcacheMode := true) - val file' = addFlushing (addChecking (inlineSql file)) - val () = Sql.sqlcacheMode := false - in - file' - end - (**********************) (* Mono Type Checking *) (**********************) -val typOfPrim = - fn Prim.Int _ => TFfi ("Basis", "int") - | Prim.Float _ => TFfi ("Basis", "int") - fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = fn EPrim p => SOME (TFfi ("Basis", case p of Prim.Int _ => "int" @@ -779,6 +774,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t + | _ => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -797,17 +793,35 @@ val expOfSubexp = fn Pure f => f () | Impure e => e -val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO" - -fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp = +fun makeCache (env, exp', index) = + case typOfExp' env exp' of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + case ListUtil.foldri (fn (_, _, NONE) => NONE + | (n, typ, SOME args) => + case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of + NONE => NONE + | SOME arg => SOME (arg :: args)) + (SOME []) + (MonoEnv.typeContext env) 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 = let fun wrapBindN f (args : (MonoEnv.env * exp) list) = let - val subexps = map (fn (env, exp) => pureCache effs env exp) args + val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args + fun mkExp () = (f (map expOfSubexp subexps), loc) in if List.exists isImpure subexps - then Impure (f (map expOfSubexp subexps), loc) - else Pure (fn () => (makeCache env (f (map #2 args)), loc)) + then (Impure (mkExp ()), index) + else (Pure (fn () => case makeCache (env, f (map #2 args), index) of + NONE => mkExp () + | SOME e' => (e', loc)), + (* Conservatively increment index. *) + index + 1) end fun wrapBind1 f arg = wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] @@ -837,7 +851,8 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp wrapBindN (fn (e::es) => ECase (e, (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), - {disc = disc, result = result})) + {disc = disc, result = result}) + | _ => raise Match) ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases) | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) (* We record page writes, so they're cachable. *) @@ -849,8 +864,61 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp (* ASK: | EClosure (n, es) => ? *) | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e | _ => if effectful effs env exp - then Impure exp - else Pure (fn () => (makeCache env exp', loc)) + then (Impure exp, index) + else (Pure (fn () => (case makeCache (env, exp', index) of + NONE => exp' + | SOME e' => e', + loc)), + index + 1) + end + +fun addPure ((decls, sideInfo), index, effs) = + let + fun doVal ((x, n, t, exp, s), index) = + let + val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index) + in + ((x, n, t, expOfSubexp subexp, s), index) + end + fun doDecl' (decl', index) = + case decl' of + DVal v => + let + val (v, index) = (doVal (v, index)) + in + (DVal v, index) + end + | DValRec vs => + let + val (vs, index) = ListUtil.foldlMap doVal index vs + in + (DValRec vs, index) + end + | _ => (decl', index) + fun doDecl ((decl', loc), index) = + let + val (decl', index) = doDecl' (decl', index) + in + ((decl', loc), index) + end + val decls = #1 (ListUtil.foldlMap doDecl index decls) + (* Important that this happens after the MonoFooify.urlify calls! *) + val fmDecls = MonoFooify.getNewFmDecls () + in + print (Int.toString (length fmDecls)); + (decls @ fmDecls, sideInfo) + end + +val go' = addPure o addFlushing o addChecking o inlineSql + +fun go file = + let + (* TODO: do something nicer than [Sql] being in one of two modes. *) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) + val file' = go' file + val () = Sql.sqlcacheMode := false + in + file' end end -- cgit v1.2.3