Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2256:6f2ea4ed573a

Pure caching sort of works.

author	Ziv Scully <ziv@mit.edu>
date	Sun, 27 Sep 2015 03:52:14 -0400
parents	8428c534913a
children	28a541bd2d23

comparison

equal deleted inserted replaced

-:8428c534913a
+:6f2ea4ed573a
 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
 | e' => e'),
 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.
+in
-by turning them into local variables as needed. *)
+case MonoFooify.urlify env (rel0, resultTyp) of
-val argsInc = map (incRels 1) args
+NONE => NONE
-val check = (check (i, args), dummyLoc)
+| SOME urlified =>
-val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc)
+let
-in
+val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
-ECase (check,
+(* We ensure before this step that all arguments aren't effectful.
-[((PNone stringTyp, loc),
+by turning them into local variables as needed. *)
-(ELet (varName "q", resultTyp, query, (ESeq (store, rel0), loc)), loc)),
+val argsInc = map (incRels 1) args
-((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
+val check = (check (i, args), loc)
-(* Boolean is false because we're not unurlifying from a cookie. *)
+val store = (store (i, argsInc, urlified), loc)
-(EUnurlify (rel0, resultTyp, false), loc))],
+in
-{disc = stringTyp, result = resultTyp})
+SOME (ECase
-end
+(check,
+[((PNone stringTyp, loc),
-fun fileMapfold doExp file start =
+(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 fileMapfoldB doExp file start =
 case MonoUtil.File.mapfoldB
 {typ = Search.return2,
 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
 decl = fn _ => Search.return2,
 bind = doBind}
 MonoEnv.empty file start of
 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
 val loc = dummyLoc
 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
 (newText, wrapLets, numArgs)
 end
 fun addChecking file =
 let
+val effs = effectfulDecls file
 fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
 fn e' as EQuery {query = origQueryText,
 state = resultTyp,
 initial, body, tables, exps} =>
 let
 (* 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
-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.... *)
 fun safe bound =
 not
 env)
 val attempt =
 (* 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
 | NONE => (e', queryInfo)
 end
 | e' => (e', queryInfo)
 in
-fileMapfold (fn env => fn exp => fn state => doExp env state exp)
+(fileMapfoldB (fn env => fn exp => fn state => doExp env state exp)
 file
-(SIMM.empty, IM.empty, 0)
+(SIMM.empty, IM.empty, 0),
+effs)
 end
 structure Invalidations = struct
 val loc = dummyLoc
 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)
 val doExp =
 fn EDml (origDmlText, failureMode) =>
 end
 | e' => e'
 in
 (* DEBUG *)
 gunk := [];
-fileMap doExp file
+(fileMap doExp file, index, effs)
 end
 val inlineSql =
 let
 val doExp =
 | e => e
 in
 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"
 | Prim.Float _ => "double"
 | EWrite _ => SOME (TRecord [], dummyLoc)
 | ESeq (_, e) => typOfExp env e
 | 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'
 (*******************************)
 val expOfSubexp =
 fn Pure f => f ()
 | Impure e => e
-val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO"
+fun makeCache (env, exp', index) =
+case typOfExp' env exp' of
-fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp =
+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)
+then (Impure (mkExp ()), index)
-else Pure (fn () => (makeCache env (f (map #2 args)), loc))
+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]
 fun wrapBind2 f (arg1, arg2) =
 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
 | ECase (e, cases, {disc, result}) =>
 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. *)
 | EWrite e => wrap1 EWrite e
 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
 ((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
 | _ => if effectful effs env exp
-then Impure exp
+then (Impure exp, index)
-else Pure (fn () => (makeCache env exp', loc))
+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

Mercurial > urweb

comparison src/sqlcache.sml @ 2256:6f2ea4ed573a