From 59c69b0cebc215599acc25906bd0366af03abf0c Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 21 Sep 2015 16:07:35 -0400 Subject: Factor out urlification. --- src/mono_fooify.sml | 317 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 317 insertions(+) create mode 100644 src/mono_fooify.sml (limited to 'src/mono_fooify.sml') diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml new file mode 100644 index 00000000..d7cb9f59 --- /dev/null +++ b/src/mono_fooify.sml @@ -0,0 +1,317 @@ +structure MonoFooify :> MONO_FOOIFY = struct + +open Mono + +datatype foo_kind = + Attr + | Url + +val nextPvar = ref 0 +val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list) + +structure Fm = struct + +type vr = string * int * typ * exp * string + +structure IM = IntBinaryMap + +structure M = BinaryMapFn(struct + type ord_key = foo_kind + fun compare x = + case x of + (Attr, Attr) => EQUAL + | (Attr, _) => LESS + | (_, Attr) => GREATER + + | (Url, Url) => EQUAL + end) + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + map : int IM.map M.map, + listMap : int TM.map M.map, + decls : vr list +} + +fun empty count = { + count = count, + map = M.empty, + listMap = M.empty, + decls = [] +} + +fun chooseNext count = + let + val n = !nextPvar + in + if count < n then + (count, count+1) + else + (nextPvar := n + 1; + (n, n+1)) + end + +fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} +fun freshName {count, map, listMap, decls} = + let + val (next, count) = chooseNext count + in + (next, {count = count , map = map, listMap = listMap, decls = decls}) + end +fun decls ({decls, ...} : t) = + case decls of + [] => [] + | _ => [(DValRec decls, ErrorMsg.dummySpan)] + +fun lookup (t as {count, map, listMap, decls}) k n thunk = + let + val im = Option.getOpt (M.find (map, k), IM.empty) + in + case IM.find (im, n) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + listMap = listMap, + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +fun lookupList (t as {count, map, listMap, decls}) k tp thunk = + let + val tm = Option.getOpt (M.find (listMap, k), TM.empty) + in + case TM.find (tm, tp) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = map, + listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +(* Has to be set at the end of [Monoize]. *) +val canonical = ref (empty 0 : t) + +end + +fun fk2s fk = + case fk of + Attr => "attr" + | Url => "url" + +fun capitalize s = + if s = "" then + s + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +structure E = ErrorMsg + +val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) + +fun fooifyExp fk lookupENamed lookupDatatype = + let + fun fooify fm (e, tAll as (t, loc)) = + case #1 e of + EClosure (fnam, [(ERecord [], _)]) => + let + val (_, s) = lookupENamed fnam + in + ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | EClosure (fnam, args) => + let + val (ft, s) = lookupENamed fnam + fun attrify (args, ft, e, fm) = + case (args, ft) of + ([], _) => (e, fm) + | (arg :: args, (TFun (t, ft), _)) => + let + val (arg', fm) = fooify fm (arg, t) + in + attrify (args, ft, + (EStrcat (e, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + arg'), loc)), loc), + fm) + end + | _ => (E.errorAt loc "Type mismatch encoding attribute"; + (e, fm)) + in + attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | _ => + case t of + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord ((x, t) :: xts) => + let + val (se, fm) = fooify fm ((EField (e, x), loc), t) + in + foldl (fn ((x, t), (se, fm)) => + let + val (se', fm) = fooify fm ((EField (e, x), loc), t) + in + ((EStrcat (se, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + se'), loc)), loc), + fm) + end) (se, fm) xts + end + + | TDatatype (i, ref (dk, _)) => + let + fun makeDecl n fm = + let + val (x, xncs) = + case ListUtil.search (fn (x, i', xncs) => + if i' = i then + SOME (x, xncs) + else + NONE) (!pvarDefs) of + NONE => lookupDatatype i + | SOME v => v + + val (branches, fm) = + ListUtil.foldlMap + (fn ((x, n, to), fm) => + case to of + NONE => + (((PCon (dk, PConVar n, NONE), loc), + (EPrim (Prim.String (Prim.Normal, x)), loc)), + fm) + | SOME t => + let + val (arg, fm) = fooify fm ((ERel 0, loc), t) + in + (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), + arg), loc)), + fm) + end) + fm xncs + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_" ^ x, + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookup fm fk i makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | TOption t => + let + val (body, fm) = fooify fm ((ERel 0, loc), t) + in + ((ECase (e, + [((PNone t, loc), + (EPrim (Prim.String (Prim.Normal, "None")), loc)), + + ((PSome (t, (PVar ("x", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc), + body), loc))], + {disc = tAll, + result = (TFfi ("Basis", "string"), loc)}), loc), + fm) + end + + | TList t => + let + fun makeDecl n fm = + let + val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc) + val (arg, fm) = fooify fm ((ERel 0, loc), rt) + + val branches = [((PNone rt, loc), + (EPrim (Prim.String (Prim.Normal, "Nil")), loc)), + ((PSome (rt, (PVar ("a", rt), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc), + arg), loc))] + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_list", + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookupList fm fk t makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; + (dummyExp, fm)) + in + fooify + end + +fun urlify env expTyp = + let + val (exp, fm) = + fooifyExp + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!Fm.canonical) + expTyp + in + Fm.canonical := fm; + exp + end +end -- cgit v1.2.3 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/mono_env.sig | 4 +- src/mono_env.sml | 4 +- src/mono_fooify.sig | 9 ++- src/mono_fooify.sml | 56 ++++++++++++------ src/monoize.sml | 7 ++- src/sqlcache.sml | 162 +++++++++++++++++++++++++++++++++++++--------------- 6 files changed, 166 insertions(+), 76 deletions(-) (limited to 'src/mono_fooify.sml') diff --git a/src/mono_env.sig b/src/mono_env.sig index 97d7d9ea..9805c0d1 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -42,6 +42,8 @@ signature MONO_ENV = sig val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env val lookupERel : env -> int -> string * Mono.typ * Mono.exp option + val typeContext : env -> Mono.typ list + val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string diff --git a/src/mono_env.sml b/src/mono_env.sml index 7f9a6e62..8617425e 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -108,6 +108,8 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n +fun typeContext (env : env) = map #2 (#relE env) + fun pushENamed (env : env) x n t eo s = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig index 9eb8038b..ef8f09c2 100644 --- a/src/mono_fooify.sig +++ b/src/mono_fooify.sig @@ -19,9 +19,6 @@ structure Fm : sig val decls : t -> Mono.decl list val freshName : t -> int * t - - (* Set at the end of [Monoize]. *) - val canonical : t ref end (* General form used in [Monoize]. *) @@ -32,7 +29,9 @@ val fooifyExp : foo_kind -> Mono.exp * Mono.typ -> Mono.exp * Fm.t -(* Easy-to-use special case used in [Sqlcache]. *) -val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp +(* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) +val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) +val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +val getNewFmDecls : unit -> Mono.decl list end diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index d7cb9f59..2e32b248 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -1,4 +1,4 @@ -structure MonoFooify :> MONO_FOOIFY = struct +structure MonoFooify (* :> MONO_FOOIFY *) = struct open Mono @@ -112,9 +112,6 @@ fun lookupList (t as {count, map, listMap, decls}) k tp thunk = | SOME n' => (t, n') end -(* Has to be set at the end of [Monoize]. *) -val canonical = ref (empty 0 : t) - end fun fk2s fk = @@ -166,7 +163,12 @@ fun fooifyExp fk lookupENamed lookupDatatype = | _ => case t of TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + | TFfi (m, x) => (if Settings.mayClientToServer (m, x) + (* TODO: better error message. (Then again, user should never see this.) *) + then () + else (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); + ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TRecord ((x, t) :: xts) => @@ -296,22 +298,38 @@ fun fooifyExp fk lookupENamed lookupDatatype = fooify end +(* Has to be set at the end of [Monoize]. *) +val canonicalFm = ref (Fm.empty 0 : Fm.t) + fun urlify env expTyp = + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "already error"; NONE) + else + let + val (exp, fm) = + fooifyExp + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) + else (canonicalFm := fm; SOME exp) + end + +fun getNewFmDecls () = let - val (exp, fm) = - fooifyExp - Url - (fn n => - let - val (_, t, _, s) = MonoEnv.lookupENamed env n - in - (t, s) - end) - (fn n => MonoEnv.lookupDatatype env n) - (!Fm.canonical) - expTyp + val fm = !canonicalFm in - Fm.canonical := fm; - exp + (* canonicalFm := Fm.enter fm; *) + Fm.decls fm end + end diff --git a/src/monoize.sml b/src/monoize.sml index 8f6b298d..4208f594 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4484,13 +4484,14 @@ fun monoize env file = (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) - (env, Fm.empty mname, []) file + (env, Fm.empty mname, []) file + val monoFile = (rev ds, []) in pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - Fm.canonical := fm; - (rev ds, []) + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile); + monoFile end end 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 From 3c2143723af4a52064386104d2105137a77bd761 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 28 Sep 2015 22:16:51 -0400 Subject: Begin work on cache merging. --- src/mono_fooify.sml | 2 +- src/sqlcache.sml | 39 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) (limited to 'src/mono_fooify.sml') diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index 2e32b248..9bf357fb 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -1,4 +1,4 @@ -structure MonoFooify (* :> MONO_FOOIFY *) = struct +structure MonoFooify :> MONO_FOOIFY = struct open Mono diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 1518e994..09feeb36 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -799,6 +799,45 @@ val freeVars = val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 +structure InvalidationInfo :> sig + type 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 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, x) => x + | (x, NONE) => x + +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 + datatype subexp = Pure of unit -> exp | Impure of exp val isImpure = -- cgit v1.2.3 From 36cb6a55281f753774e491cce3178eb8c927983e Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 30 Sep 2015 00:33:52 -0400 Subject: Fix SQL-parsing and declaration-ordering bugs. --- src/mono_fooify.sig | 2 ++ src/mono_fooify.sml | 2 +- src/monoize.sml | 16 +++++----- src/sql.sml | 10 ++++--- src/sqlcache.sml | 84 +++++++++++++++++++++++++++++++++-------------------- 5 files changed, 70 insertions(+), 44 deletions(-) (limited to 'src/mono_fooify.sml') diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig index ef8f09c2..0cc72342 100644 --- a/src/mono_fooify.sig +++ b/src/mono_fooify.sig @@ -16,6 +16,7 @@ structure Fm : sig val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int val enter : t -> t + (* This list should be reversed before adding to list of file declarations. *) val decls : t -> Mono.decl list val freshName : t -> int * t @@ -32,6 +33,7 @@ val fooifyExp : foo_kind (* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +(* This list should be reversed before adding to list of file declarations. *) val getNewFmDecls : unit -> Mono.decl list end diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index 9bf357fb..b7d0b6c6 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -328,7 +328,7 @@ fun getNewFmDecls () = let val fm = !canonicalFm in - (* canonicalFm := Fm.enter fm; *) + canonicalFm := Fm.enter fm; Fm.decls fm end diff --git a/src/monoize.sml b/src/monoize.sml index 4208f594..2e87a70b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4344,12 +4344,14 @@ fun monoize env file = val (nullable, notNullable) = calcClientish xts fun cond (x, v) = - (L'.EStrcat (str (Settings.mangleSql x - ^ (case v of - Client => "" - | Channel => " >> 32") - ^ " = "), - target), loc) + (L'.EStrcat ((L'.EStrcat (str ("((" + ^ Settings.mangleSql x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ ") = "), + target), loc), + str ")"), loc) val e = foldl (fn ((x, v), e) => @@ -4490,7 +4492,7 @@ fun monoize env file = pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile); + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile + 1); monoFile end diff --git a/src/sql.sml b/src/sql.sml index da0143b7..08315a16 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -321,7 +321,7 @@ val funcName = altL [constK "COUNT", fun arithmetic pExp = follow (const "(") (follow pExp - (follow (altL (map const [" + ", " - ", " * ", " / "])) + (follow (altL (map const [" + ", " - ", " * ", " / ", " >> ", " << "])) (follow pExp (const ")")))) val unmodeled = altL [const "COUNT(*)", @@ -445,9 +445,11 @@ val insert = log "insert" val delete = log "delete" (wrap (follow (const "DELETE FROM ") (follow uw_ident - (follow (follow (opt (const " AS T_T")) (const " WHERE ")) - sqexp))) - (fn ((), (tab, (_, es))) => (tab, es))) + (follow (opt (const " AS T_T")) + (opt (follow (const " WHERE ") sqexp))))) + (fn ((), (tab, (_, wher))) => (tab, case wher of + SOME (_, es) => es + | NONE => SqTrue))) val setting = log "setting" (wrap (follow uw_ident (follow (const " = ") sqexp)) diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 09feeb36..4d4c7d36 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -499,6 +499,8 @@ fun cacheWrap (env, exp, resultTyp, args, i) = let val loc = dummyLoc val rel0 = (ERel 0, loc) + (* DEBUG *) + val () = print (Int.toString i ^ "\n") in case MonoFooify.urlify env (rel0, resultTyp) of NONE => NONE @@ -506,7 +508,7 @@ fun cacheWrap (env, exp, resultTyp, args, i) = 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. *) + 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) @@ -615,7 +617,9 @@ fun addChecking file = in case attempt of SOME pair => pair - | NONE => (e', queryInfo) + (* We have to increment index conservatively. *) + (* TODO: just use a reference for current index.... *) + | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) end | e' => (e', queryInfo) in @@ -672,6 +676,7 @@ val invalidations = Invalidations.invalidations (* DEBUG *) val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] +val gunk' : exp list ref = ref [] fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let @@ -680,26 +685,30 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = val doExp = fn EDml (origDmlText, 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 dmlText)) *) - val invs = + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) + val inval = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - map (fn i => (case IM.find (indexToQueryNumArgs, i) of - SOME queryNumArgs => - (* DEBUG *) - (gunk := (queryNumArgs, dmlParsed) :: !gunk; - (i, invalidations (queryNumArgs, dmlParsed))) - (* TODO: fail more gracefully. *) - | NONE => raise Match)) - (SIMM.findList (tableToIndices, tableDml dmlParsed)) - (* TODO: fail more gracefully. *) - | NONE => raise Match + SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of + SOME queryNumArgs => + (* DEBUG *) + (gunk := (queryNumArgs, dmlParsed) :: !gunk; + (i, invalidations (queryNumArgs, dmlParsed))) + (* TODO: fail more gracefully. *) + | NONE => raise Match)) + (SIMM.findList (tableToIndices, tableDml dmlParsed))) + | NONE => NONE in - wrapLets (sequence (flushes invs @ [dmlExp])) + case inval of + (* TODO: fail more gracefully. *) + NONE => raise Match + | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) end | e' => e' in @@ -801,6 +810,7 @@ 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 @@ -816,14 +826,16 @@ val fromList = | (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, x) => x - | (x, NONE) => x + | (NONE, info) => info + | (info, NONE) => info val unbind = fn (SOME (n, ns), unbound) => @@ -838,6 +850,15 @@ val unbind = 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 = @@ -936,44 +957,43 @@ fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int index + 1) end -fun addPure ((decls, sideInfo), index, effs) = +fun addPure ((decls, sideInfo), indexStart, effs) = let - fun doVal ((x, n, t, exp, s), index) = + fun doVal env ((x, n, t, exp, s), index) = let - val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index) + val (subexp, index) = pureCache effs ((env, exp), index) in ((x, n, t, expOfSubexp subexp, s), index) end - fun doDecl' (decl', index) = + fun doDecl' env (decl', index) = case decl' of DVal v => let - val (v, index) = (doVal (v, index)) + val (v, index) = doVal env (v, index) in (DVal v, index) end | DValRec vs => let - val (vs, index) = ListUtil.foldlMap doVal index vs + val (vs, index) = ListUtil.foldlMap (doVal env) index vs in (DValRec vs, index) end | _ => (decl', index) - fun doDecl ((decl', loc), index) = + fun doDecl (decl as (decl', loc), (revDecls, env, index)) = let - val (decl', index) = doDecl' (decl', index) + val env = MonoEnv.declBinds env decl + val (decl', index) = doDecl' env (decl', index) + (* Important that this happens after [MonoFooify.urlify] calls! *) + val fmDecls = MonoFooify.getNewFmDecls () in - ((decl', loc), index) + ((decl', loc) :: (fmDecls @ revDecls), env, index) end - val decls = #1 (ListUtil.foldlMap doDecl index decls) - (* Important that this happens after the MonoFooify.urlify calls! *) - val fmDecls = MonoFooify.getNewFmDecls () in - (* ASK: fmDecls before or after? *) - (fmDecls @ decls, sideInfo) + (rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo) end -val go' = addPure o addFlushing o addChecking o inlineSql +val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *) fun go file = let -- cgit v1.2.3 From 013ea39e9f187efbb0e3a613264a1c7adfebe692 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 7 Oct 2015 08:58:08 -0400 Subject: Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors. --- src/c/urweb.c | 26 +++++++++---- src/lru_cache.sml | 3 +- src/mono_fooify.sml | 75 +++++++++++++++++++++--------------- src/sqlcache.sml | 107 +++++++++++++++++++++++++++++++--------------------- src/toy_cache.sml | 16 ++++++-- 5 files changed, 141 insertions(+), 86 deletions(-) (limited to 'src/mono_fooify.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 61742693..957f158c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -72,6 +72,9 @@ void uw_buffer_free(uw_buffer *b) { void uw_buffer_reset(uw_buffer *b) { b->front = b->start; + if (b->front != b->back) { + *b->front = 0; + } } int uw_buffer_check(uw_buffer *b, size_t extra) { @@ -486,7 +489,8 @@ struct uw_context { size_t output_buffer_size; // For caching. - char *recording; + int numRecording; + int recordingOffset; int remoteSock; }; @@ -572,7 +576,8 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->output_buffer = malloc(1); ctx->output_buffer_size = 1; - ctx->recording = 0; + ctx->numRecording = 0; + ctx->recordingOffset = 0; ctx->remoteSock = -1; @@ -1689,11 +1694,18 @@ void uw_write(uw_context ctx, const char* s) { } void uw_recordingStart(uw_context ctx) { - ctx->recording = ctx->page.front; + if (ctx->numRecording++ == 0) { + ctx->recordingOffset = ctx->page.front - ctx->page.start; + } } char *uw_recordingRead(uw_context ctx) { - return strdup(ctx->recording); + // Only the outermost recorder can read unless the recording is empty. + char *recording = ctx->page.start + ctx->recordingOffset; + if (--ctx->numRecording > 0 && recording != ctx->page.front) { + return NULL; + } + return strdup(recording); } char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { @@ -4543,7 +4555,7 @@ time_t uw_Sqlcache_timeMax(time_t x, time_t y) { return difftime(x, y) > 0 ? x : y; } -void uw_Sqlcache_freeuw_Sqlcache_CacheValue(uw_Sqlcache_CacheValue *value) { +void uw_Sqlcache_free(uw_Sqlcache_CacheValue *value) { if (value) { free(value->result); free(value->output); @@ -4554,7 +4566,7 @@ void uw_Sqlcache_freeuw_Sqlcache_CacheValue(uw_Sqlcache_CacheValue *value) { void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_CacheEntry* entry) { //uw_Sqlcache_listUw_Sqlcache_Delete(cache->lru, entry); HASH_DELETE(hh, cache->table, entry); - uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value); + uw_Sqlcache_free(entry->value); free(entry->key); free(entry); } @@ -4595,7 +4607,7 @@ void uw_Sqlcache_storeHelper(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_ entry->timeValid = timeNow; if (cache->height == 0) { //uw_Sqlcache_listAdd(cache->lru, entry); - uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value); + uw_Sqlcache_free(entry->value); entry->value = value; //if (cache->lru->size > MAX_SIZE) { //uw_Sqlcache_delete(cache, cache->lru->first); diff --git a/src/lru_cache.sml b/src/lru_cache.sml index b8dfde5e..275c3061 100644 --- a/src/lru_cache.sml +++ b/src/lru_cache.sml @@ -91,7 +91,8 @@ fun setupQuery {index, params} = newline, string (" uw_Sqlcache_CacheValue *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"), newline, - string " if (v) {", + (* If the output is null, it means we had too much recursion, so it's a miss. *) + string " if (v && v->output != NULL) {", newline, string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), newline, diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index b7d0b6c6..bbd34b15 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -127,9 +127,13 @@ fun capitalize s = structure E = ErrorMsg +exception TypeMismatch of Fm.t * E.span +exception CantPass of Fm.t * typ +exception DontKnow of Fm.t * typ + val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) -fun fooifyExp fk lookupENamed lookupDatatype = +fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = let fun fooify fm (e, tAll as (t, loc)) = case #1 e of @@ -155,8 +159,7 @@ fun fooifyExp fk lookupENamed lookupDatatype = arg'), loc)), loc), fm) end - | _ => (E.errorAt loc "Type mismatch encoding attribute"; - (e, fm)) + | _ => raise TypeMismatch (fm, loc) in attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end @@ -165,10 +168,8 @@ fun fooifyExp fk lookupENamed lookupDatatype = TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) (* TODO: better error message. (Then again, user should never see this.) *) - then () - else (E.errorAt loc "MonoFooify: can't pass type from client to server"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); - ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) + then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + else raise CantPass (fm, tAll)) | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TRecord ((x, t) :: xts) => @@ -291,38 +292,50 @@ fun fooifyExp fk lookupENamed lookupDatatype = ((EApp ((ENamed n, loc), e), loc), fm) end - | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - (dummyExp, fm)) + | _ => raise DontKnow (fm, tAll) in fooify end +fun fooifyExp fk lookupENamed lookupDatatype fm exp = + fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp + handle TypeMismatch (fm, loc) => + (E.errorAt loc "Type mismatch encoding attribute"; + (dummyExp, fm)) + | CantPass (fm, typ as (_, loc)) => + (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + | DontKnow (fm, typ as (_, loc)) => + (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + + (* Has to be set at the end of [Monoize]. *) val canonicalFm = ref (Fm.empty 0 : Fm.t) fun urlify env expTyp = - if ErrorMsg.anyErrors () - then ((* DEBUG *) print "already error"; NONE) - else - let - val (exp, fm) = - fooifyExp - Url - (fn n => - let - val (_, t, _, s) = MonoEnv.lookupENamed env n - in - (t, s) - end) - (fn n => MonoEnv.lookupDatatype env n) - (!canonicalFm) - expTyp - in - if ErrorMsg.anyErrors () - then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) - else (canonicalFm := fm; SOME exp) - end + let + val (exp, fm) = + fooifyExpWithExceptions + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + canonicalFm := fm; + SOME exp + end + handle TypeMismatch _ => NONE + | CantPass _ => NONE + | DontKnow _ => NONE fun getNewFmDecls () = let diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 4d4c7d36..dd851787 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -53,8 +53,9 @@ fun getCache () = !cache (* Used to have type context for local variables in MonoUtil functions. *) val doBind = - fn (env, MonoUtil.Exp.RelE (s, t)) => MonoEnv.pushERel env s t NONE - | (env, _) => env + fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE + | (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 (*******************) @@ -499,8 +500,6 @@ fun cacheWrap (env, exp, resultTyp, args, i) = let val loc = dummyLoc val rel0 = (ERel 0, loc) - (* DEBUG *) - val () = print (Int.toString i ^ "\n") in case MonoFooify.urlify env (rel0, resultTyp) of NONE => NONE @@ -524,7 +523,42 @@ fun cacheWrap (env, exp, resultTyp, args, i) = end end -fun fileMapfoldB doExp file start = +fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = + let + fun doVal env ((x, n, t, exp, s), state) = + let + val (exp, state) = doTopLevelExp env exp state + in + ((x, n, t, exp, s), state) + end + fun doDecl' env (decl', state) = + case decl' of + DVal v => + let + val (v, state) = doVal env (v, state) + in + (DVal v, state) + end + | DValRec vs => + let + val (vs, state) = ListUtil.foldlMap (doVal env) state vs + in + (DValRec vs, state) + end + | _ => (decl', state) + fun doDecl (decl as (decl', loc), (env, state)) = + let + val env = MonoEnv.declBinds env decl + val (decl', state) = doDecl' env (decl', state) + in + ((decl', loc), (env, state)) + end + val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls) + in + ((decls, sideInfo), state) + end + +fun fileAllMapfoldB doExp file start = case MonoUtil.File.mapfoldB {typ = Search.return2, exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), @@ -534,7 +568,7 @@ fun fileMapfoldB doExp file start = Search.Continue x => x | Search.Return _ => raise Match -fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) +fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) fun factorOutNontrivial text = let @@ -623,7 +657,7 @@ fun addChecking file = end | e' => (e', queryInfo) in - (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp) + (fileAllMapfoldB (fn env => fn exp => fn state => doExp env state exp) file (SIMM.empty, IM.empty, 0), effs) @@ -675,8 +709,8 @@ end val invalidations = Invalidations.invalidations (* DEBUG *) -val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] -val gunk' : exp list ref = ref [] +(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) +(* val gunk' : exp list ref = ref [] *) fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let @@ -686,19 +720,19 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = fn EDml (origDmlText, failureMode) => let (* DEBUG *) - val () = gunk' := origDmlText :: !gunk' + (* 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 () = 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 SOME queryNumArgs => (* DEBUG *) - (gunk := (queryNumArgs, dmlParsed) :: !gunk; + ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) (i, invalidations (queryNumArgs, dmlParsed))) (* TODO: fail more gracefully. *) | NONE => raise Match)) @@ -713,7 +747,7 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = | e' => e' in (* DEBUG *) - gunk := []; + (* gunk := []; *) (fileMap doExp file, index, effs) end @@ -957,52 +991,37 @@ fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int index + 1) end -fun addPure ((decls, sideInfo), indexStart, effs) = +fun addPure (file, indexStart, effs) = let - fun doVal env ((x, n, t, exp, s), index) = + fun doTopLevelExp env exp index = let val (subexp, index) = pureCache effs ((env, exp), index) in - ((x, n, t, expOfSubexp subexp, s), index) - end - fun doDecl' env (decl', index) = - case decl' of - DVal v => - let - val (v, index) = doVal env (v, index) - in - (DVal v, index) - end - | DValRec vs => - let - val (vs, index) = ListUtil.foldlMap (doVal env) index vs - in - (DValRec vs, index) - end - | _ => (decl', index) - fun doDecl (decl as (decl', loc), (revDecls, env, index)) = - let - val env = MonoEnv.declBinds env decl - val (decl', index) = doDecl' env (decl', index) - (* Important that this happens after [MonoFooify.urlify] calls! *) - val fmDecls = MonoFooify.getNewFmDecls () - in - ((decl', loc) :: (fmDecls @ revDecls), env, index) + (expOfSubexp subexp, index) end in - (rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo) + #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) + end + +fun insertAfterDatatypes ((decls, sideInfo), newDecls) = + let + val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls + in + (datatypes @ newDecls @ others, sideInfo) end -val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *) +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 file = go' file + (* Important that this happens after [MonoFooify.urlify] calls! *) + val fmDecls = MonoFooify.getNewFmDecls () val () = Sql.sqlcacheMode := false in - file' + insertAfterDatatypes (file, rev fmDecls) end end diff --git a/src/toy_cache.sml b/src/toy_cache.sml index 34a7a26f..cfde027b 100644 --- a/src/toy_cache.sml +++ b/src/toy_cache.sml @@ -95,7 +95,7 @@ fun setupQuery {index, params} = string args, string ") {", newline, - string "if (cacheQuery", + string "if (cacheWrite", string i, (* ASK: is returning the pointer okay? Should we duplicate? *) string " == NULL", @@ -116,9 +116,11 @@ fun setupQuery {index, params} = string i, string ".\");", newline, - string "uw_write(ctx, cacheWrite", + string " if (cacheWrite", string i, - string ");", + string " != NULL) { uw_write(ctx, cacheWrite", + string i, + string "); }", newline, string "return cacheQuery", string i, @@ -176,6 +178,14 @@ fun setupQuery {index, params} = string i, string " = NULL;", newline, + string "free(cacheWrite", + string i, + string ");", + newline, + string "cacheWrite", + string i, + string " = NULL;", + newline, string "puts(\"SQLCACHE: flush ", string i, string ".\");}", -- cgit v1.2.3 From e86ed0717e35bea1ad6127d193e5979aec4841b9 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 14 Oct 2015 00:07:00 -0400 Subject: Hard-code Sqlcache module (in Ur/Web) as effectful and reorder sqlcache.sml. --- src/lru_cache.sml | 8 +- src/mono_fooify.sml | 2 - src/settings.sml | 3 +- src/sqlcache.sml | 478 +++++++++++++++++++++++++++------------------------- src/toy_cache.sml | 8 +- 5 files changed, 250 insertions(+), 249 deletions(-) (limited to 'src/mono_fooify.sml') diff --git a/src/lru_cache.sml b/src/lru_cache.sml index 275c3061..e69624d8 100644 --- a/src/lru_cache.sml +++ b/src/lru_cache.sml @@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc) fun withTyp typ = map (fn exp => (exp, typ)) fun ffiAppCache' (func, index, argTyps) = - let - val m = "Sqlcache" - val f = func ^ Int.toString index - in - Settings.addEffectful (m, f); - EFfiApp (m, f, argTyps) - end + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) fun check (index, keys) = ffiAppCache' ("check", index, withTyp stringTyp keys) diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index bbd34b15..e64207cd 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -167,7 +167,6 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = case t of TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) - (* TODO: better error message. (Then again, user should never see this.) *) then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) else raise CantPass (fm, tAll)) @@ -311,7 +310,6 @@ fun fooifyExp fk lookupENamed lookupDatatype fm exp = Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; (dummyExp, fm)) - (* Has to be set at the end of [Monoize]. *) val canonicalFm = ref (Fm.empty 0 : Fm.t) diff --git a/src/settings.sml b/src/settings.sml index ff99bf13..ecf353cd 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -151,7 +151,8 @@ val effectfulBase = basis ["dml", val effectful = ref effectfulBase fun setEffectful ls = effectful := S.addList (effectfulBase, ls) -fun isEffectful x = S.member (!effectful, x) +fun isEffectful ("Sqlcache", _) = true + | isEffectful x = S.member (!effectful, x) fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", diff --git a/src/sqlcache.sml b/src/sqlcache.sml index f3db5795..1a4d4e97 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -15,7 +15,7 @@ fun iterate f n x = if n < 0 then x else iterate f (n-1) (f x) -(* Filled in by [cacheWrap] during [Sqlcache]. *) +(* Filled in by [cacheWrap]. *) val ffiInfo : {index : int, params : int} list ref = ref [] fun resetFfiInfo () = ffiInfo := [] @@ -41,8 +41,7 @@ val ffiEffectful = "urlifyBool_w", "urlifyChannel_w"] in - (* ASK: nicer way than using [Settings.addEffectful] for each Sqlcache - function? Right now they're all always effectful. *) + (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) fn (m, f) => Settings.isEffectful (m, f) andalso not (m = "Basis" andalso SS.member (okayWrites, f)) end @@ -456,9 +455,9 @@ val tableDml = | Sql.Update (tab, _, _) => tab -(***************************) -(* Program Instrumentation *) -(***************************) +(*************************************) +(* Program Instrumentation Utilities *) +(*************************************) val varName = let @@ -496,33 +495,6 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (env, exp, resultTyp, args, i) = - 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 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 fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = let fun doVal env ((x, n, t, exp, s), state) = @@ -570,205 +542,6 @@ fun fileAllMapfoldB doExp file start = fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) -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) - end - -structure Invalidations = struct - - val loc = dummyLoc - - val optionAtomExpToExp = - fn NONE => (ENone stringTyp, loc) - | SOME e => (ESome (stringTyp, - (case e of - DmlRel n => ERel n - | Prim p => EPrim p - (* TODO: make new type containing only these two. *) - | _ => raise Match, - loc)), - loc) - - fun eqsToInvalidation numArgs eqs = - let - fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) - in - inv (numArgs - 1) - end - - (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here - represents unknown, which means a wider invalidation. *) - val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = - fn ([], []) => true - | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) - | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of - EQUAL => madeRedundantBy (xs, ys) - | _ => false) - | _ => false - - fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) - - fun invalidations ((query, numArgs), dml) = - (map (map optionAtomExpToExp) - o removeRedundant madeRedundantBy - o map (eqsToInvalidation numArgs) - o eqss) - (query, dml) - -end - -val invalidations = Invalidations.invalidations - -(* DEBUG *) -(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) -(* val gunk' : exp list ref = ref [] *) - -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) => - 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 - SOME queryNumArgs => - (* DEBUG *) - ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) - (i, invalidations (queryNumArgs, dmlParsed))) - (* TODO: fail more gracefully. *) - | NONE => raise Match)) - (SIMM.findList (tableToIndices, tableDml dmlParsed))) - | NONE => NONE - in - case inval of - (* TODO: fail more gracefully. *) - NONE => raise Match - | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) - end - | e' => e' - in - (* DEBUG *) - (* gunk := []; *) - (fileMap doExp file, index, effs) - end - -val inlineSql = - let - val doExp = - (* TODO: EQuery, too? *) - (* ASK: should this live in [MonoOpt]? *) - fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => - let - val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases - in - ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) - end - | e => e - in - fileMap doExp - end - (**********************) (* Mono Type Checking *) @@ -830,6 +603,33 @@ and typOfExp env (e', loc) = typOfExp' env e' (* Caching Pure Subexpressions *) (*******************************) +fun cacheWrap (env, exp, resultTyp, args, i) = + 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 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 + val freeVars = IS.listItems o MonoUtil.Exp.foldB @@ -1005,6 +805,220 @@ fun addPure (file, indexStart, effs) = #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) + end + + +(************) +(* Flushing *) +(************) + +structure Invalidations = struct + + val loc = dummyLoc + + val optionAtomExpToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, + (case e of + DmlRel n => ERel n + | Prim p => EPrim p + (* TODO: make new type containing only these two. *) + | _ => raise Match, + loc)), + loc) + + fun eqsToInvalidation numArgs eqs = + let + fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) + in + inv (numArgs - 1) + end + + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) + val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = + fn ([], []) => true + | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) + | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of + EQUAL => madeRedundantBy (xs, ys) + | _ => false) + | _ => false + + fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) + + fun invalidations ((query, numArgs), dml) = + (map (map optionAtomExpToExp) + o removeRedundant madeRedundantBy + o map (eqsToInvalidation numArgs) + o eqss) + (query, dml) + +end + +val invalidations = Invalidations.invalidations + +(* DEBUG *) +(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) +(* val gunk' : exp list ref = ref [] *) + +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) => + 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 + SOME queryNumArgs => + (* DEBUG *) + ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) + (i, invalidations (queryNumArgs, dmlParsed))) + (* TODO: fail more gracefully. *) + | NONE => raise Match)) + (SIMM.findList (tableToIndices, tableDml dmlParsed))) + | NONE => NONE + in + case inval of + (* TODO: fail more gracefully. *) + NONE => raise Match + | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) + end + | e' => e' + in + (* DEBUG *) + (* gunk := []; *) + (fileMap doExp file, index, effs) + end + + +(***************) +(* Entry point *) +(***************) + +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + fun insertAfterDatatypes ((decls, sideInfo), newDecls) = let val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls diff --git a/src/toy_cache.sml b/src/toy_cache.sml index cfde027b..377cae01 100644 --- a/src/toy_cache.sml +++ b/src/toy_cache.sml @@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc) fun withTyp typ = map (fn exp => (exp, typ)) fun ffiAppCache' (func, index, argTyps) = - let - val m = "Sqlcache" - val f = func ^ Int.toString index - in - Settings.addEffectful (m, f); - EFfiApp (m, f, argTyps) - end + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) fun check (index, keys) = ffiAppCache' ("check", index, withTyp stringTyp keys) -- cgit v1.2.3