ziv@2250: structure Sqlcache :> SQLCACHE = struct ziv@2209: ziv@2209: open Mono ziv@2209: ziv@2209: structure IS = IntBinarySet ziv@2209: structure IM = IntBinaryMap ziv@2213: structure SK = struct type ord_key = string val compare = String.compare end ziv@2213: structure SS = BinarySetFn(SK) ziv@2213: structure SM = BinaryMapFn(SK) ziv@2213: structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) ziv@2209: ziv@2250: fun iterate f n x = if n < 0 ziv@2250: then raise Fail "Can't iterate function negative number of times." ziv@2250: else if n = 0 ziv@2250: then x ziv@2250: else iterate f (n-1) (f x) ziv@2250: ziv@2268: (* Filled in by [addFlushing]. *) ziv@2268: val ffiInfoRef : {index : int, params : int} list ref = ref [] ziv@2209: ziv@2268: fun resetFfiInfo () = ffiInfoRef := [] ziv@2227: ziv@2268: fun getFfiInfo () = !ffiInfoRef ziv@2213: ziv@2215: (* Some FFIs have writing as their only effect, which the caching records. *) ziv@2215: val ffiEffectful = ziv@2223: (* ASK: how can this be less hard-coded? *) ziv@2215: let ziv@2258: val okayWrites = SS.fromList ["htmlifyInt_w", ziv@2258: "htmlifyFloat_w", ziv@2258: "htmlifyString_w", ziv@2258: "htmlifyBool_w", ziv@2258: "htmlifyTime_w", ziv@2258: "attrifyInt_w", ziv@2258: "attrifyFloat_w", ziv@2258: "attrifyString_w", ziv@2258: "attrifyChar_w", ziv@2258: "urlifyInt_w", ziv@2258: "urlifyFloat_w", ziv@2258: "urlifyString_w", ziv@2258: "urlifyBool_w", ziv@2258: "urlifyChannel_w"] ziv@2215: in ziv@2265: (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) ziv@2215: fn (m, f) => Settings.isEffectful (m, f) ziv@2258: andalso not (m = "Basis" andalso SS.member (okayWrites, f)) ziv@2215: end ziv@2215: ziv@2234: val cache = ref LruCache.cache ziv@2233: fun setCache c = cache := c ziv@2233: fun getCache () = !cache ziv@2233: ziv@2248: (* Used to have type context for local variables in MonoUtil functions. *) ziv@2248: val doBind = ziv@2262: fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE ziv@2262: | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s ziv@2262: | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs ziv@2215: ziv@2271: val dummyLoc = ErrorMsg.dummySpan ziv@2271: ziv@2271: ziv@2271: (*********************) ziv@2271: (* General Utilities *) ziv@2271: (*********************) ziv@2266: ziv@2266: (* From the MLton wiki. *) ziv@2266: infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *) ziv@2266: infixr 3 SOME (f x) | _ => NONE ziv@2271: fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE ziv@2271: fun osequence ys = List.foldr (omap2 op::) (SOME []) ys ziv@2248: ziv@2271: fun indexOf test = ziv@2271: let ziv@2271: fun f n = ziv@2271: fn [] => NONE ziv@2271: | (x::xs) => if test x then SOME n else f (n+1) xs ziv@2271: in ziv@2271: f 0 ziv@2271: end ziv@2268: ziv@2248: (*******************) ziv@2248: (* Effect Analysis *) ziv@2248: (*******************) ziv@2215: ziv@2216: (* Makes an exception for [EWrite] (which is recorded when caching). *) ziv@2248: fun effectful (effs : IS.set) = ziv@2215: let ziv@2248: val isFunction = ziv@2248: fn (TFun _, _) => true ziv@2248: | _ => false ziv@2250: fun doExp (env, e) = ziv@2248: case e of ziv@2248: EPrim _ => false ziv@2248: (* For now: variables of function type might be effectful, but ziv@2248: others are fully evaluated and are therefore not effectful. *) ziv@2250: | ERel n => isFunction (#2 (MonoEnv.lookupERel env n)) ziv@2248: | ENamed n => IS.member (effs, n) ziv@2248: | EFfi (m, f) => ffiEffectful (m, f) ziv@2248: | EFfiApp (m, f, _) => ffiEffectful (m, f) ziv@2248: (* These aren't effectful unless a subexpression is. *) ziv@2248: | ECon _ => false ziv@2248: | ENone _ => false ziv@2248: | ESome _ => false ziv@2248: | EApp _ => false ziv@2248: | EAbs _ => false ziv@2248: | EUnop _ => false ziv@2248: | EBinop _ => false ziv@2248: | ERecord _ => false ziv@2248: | EField _ => false ziv@2248: | ECase _ => false ziv@2248: | EStrcat _ => false ziv@2248: (* EWrite is a special exception because we record writes when caching. *) ziv@2248: | EWrite _ => false ziv@2248: | ESeq _ => false ziv@2248: | ELet _ => false ziv@2250: | EUnurlify _ => false ziv@2248: (* ASK: what should we do about closures? *) ziv@2248: (* Everything else is some sort of effect. We could flip this and ziv@2248: explicitly list bits of Mono that are effectful, but this is ziv@2248: conservatively robust to future changes (however unlikely). *) ziv@2248: | _ => true ziv@2215: in ziv@2248: MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind} ziv@2215: end ziv@2215: ziv@2215: (* TODO: test this. *) ziv@2252: fun effectfulDecls (decls, _) = ziv@2215: let ziv@2248: fun doVal ((_, name, _, e, _), effs) = ziv@2250: if effectful effs MonoEnv.empty e ziv@2248: then IS.add (effs, name) ziv@2248: else effs ziv@2215: val doDecl = ziv@2248: fn ((DVal v, _), effs) => doVal (v, effs) ziv@2248: (* Repeat the list of declarations a number of times equal to its size, ziv@2248: making sure effectfulness propagates everywhere it should. This is ziv@2248: analagous to the Bellman-Ford algorithm. *) ziv@2248: | ((DValRec vs, _), effs) => ziv@2248: List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs)) ziv@2215: (* ASK: any other cases? *) ziv@2248: | (_, effs) => effs ziv@2215: in ziv@2248: List.foldl doDecl IS.empty decls ziv@2215: end ziv@2215: ziv@2215: ziv@2248: (*********************************) ziv@2248: (* Boolean Formula Normalization *) ziv@2248: (*********************************) ziv@2216: ziv@2234: datatype junctionType = Conj | Disj ziv@2216: ziv@2216: datatype 'atom formula = ziv@2216: Atom of 'atom ziv@2216: | Negate of 'atom formula ziv@2234: | Combo of junctionType * 'atom formula list ziv@2216: ziv@2243: (* Guaranteed to have all negation pushed to the atoms. *) ziv@2243: datatype 'atom formula' = ziv@2243: Atom' of 'atom ziv@2243: | Combo' of junctionType * 'atom formula' list ziv@2243: ziv@2234: val flipJt = fn Conj => Disj | Disj => Conj ziv@2216: ziv@2236: fun concatMap f xs = List.concat (map f xs) ziv@2216: ziv@2216: val rec cartesianProduct : 'a list list -> 'a list list = ziv@2216: fn [] => [[]] ziv@2236: | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) ziv@2236: (cartesianProduct xss) ziv@2216: ziv@2218: (* Pushes all negation to the atoms.*) ziv@2244: fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = ziv@2244: fn Atom x => Atom' (normalizeAtom (negating, x)) ziv@2244: | Negate f => pushNegate normalizeAtom (not negating) f ziv@2244: | Combo (j, fs) => Combo' (if negating then flipJt j else j, ziv@2244: map (pushNegate normalizeAtom negating) fs) ziv@2218: ziv@2218: val rec flatten = ziv@2243: fn Combo' (_, [f]) => flatten f ziv@2243: | Combo' (j, fs) => ziv@2243: Combo' (j, List.foldr (fn (f, acc) => ziv@2243: case f of ziv@2243: Combo' (j', fs') => ziv@2243: if j = j' orelse length fs' = 1 ziv@2243: then fs' @ acc ziv@2243: else f :: acc ziv@2243: | _ => f :: acc) ziv@2243: [] ziv@2243: (map flatten fs)) ziv@2218: | f => f ziv@2218: ziv@2243: (* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj], ziv@2243: consider the list of lists to be a disjunction of conjunctions. *) ziv@2237: fun normalize' (simplify : 'a list list -> 'a list list) ziv@2235: (junc : junctionType) = ziv@2216: let ziv@2235: fun norm junc = ziv@2237: simplify ziv@2243: o (fn Atom' x => [[x]] ziv@2243: | Combo' (j, fs) => ziv@2235: let ziv@2236: val fss = map (norm junc) fs ziv@2235: in ziv@2236: if j = junc ziv@2236: then List.concat fss ziv@2236: else map List.concat (cartesianProduct fss) ziv@2235: end) ziv@2216: in ziv@2235: norm junc ziv@2216: end ziv@2216: ziv@2244: fun normalize simplify normalizeAtom junc = ziv@2243: normalize' simplify junc ziv@2235: o flatten ziv@2244: o pushNegate normalizeAtom false ziv@2216: ziv@2221: fun mapFormula mf = ziv@2221: fn Atom x => Atom (mf x) ziv@2221: | Negate f => Negate (mapFormula mf f) ziv@2235: | Combo (j, fs) => Combo (j, map (mapFormula mf) fs) ziv@2216: ziv@2230: ziv@2248: (****************) ziv@2248: (* SQL Analysis *) ziv@2248: (****************) ziv@2213: ziv@2240: structure CmpKey = struct ziv@2235: ziv@2235: type ord_key = Sql.cmp ziv@2235: ziv@2235: val compare = ziv@2235: fn (Sql.Eq, Sql.Eq) => EQUAL ziv@2235: | (Sql.Eq, _) => LESS ziv@2235: | (_, Sql.Eq) => GREATER ziv@2235: | (Sql.Ne, Sql.Ne) => EQUAL ziv@2235: | (Sql.Ne, _) => LESS ziv@2235: | (_, Sql.Ne) => GREATER ziv@2235: | (Sql.Lt, Sql.Lt) => EQUAL ziv@2235: | (Sql.Lt, _) => LESS ziv@2235: | (_, Sql.Lt) => GREATER ziv@2235: | (Sql.Le, Sql.Le) => EQUAL ziv@2235: | (Sql.Le, _) => LESS ziv@2235: | (_, Sql.Le) => GREATER ziv@2235: | (Sql.Gt, Sql.Gt) => EQUAL ziv@2235: | (Sql.Gt, _) => LESS ziv@2235: | (_, Sql.Gt) => GREATER ziv@2235: | (Sql.Ge, Sql.Ge) => EQUAL ziv@2235: ziv@2235: end ziv@2235: ziv@2216: val rec chooseTwos : 'a list -> ('a * 'a) list = ziv@2216: fn [] => [] ziv@2216: | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys ziv@2213: ziv@2237: fun removeRedundant madeRedundantBy zs = ziv@2237: let ziv@2237: fun removeRedundant' (xs, ys) = ziv@2237: case xs of ziv@2237: [] => ys ziv@2237: | x :: xs' => ziv@2237: removeRedundant' (xs', ziv@2237: if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys) ziv@2237: then ys ziv@2237: else x :: ys) ziv@2237: in ziv@2237: removeRedundant' (zs, []) ziv@2237: end ziv@2237: ziv@2216: datatype atomExp = ziv@2216: QueryArg of int ziv@2216: | DmlRel of int ziv@2216: | Prim of Prim.t ziv@2216: | Field of string * string ziv@2216: ziv@2216: structure AtomExpKey : ORD_KEY = struct ziv@2216: ziv@2234: type ord_key = atomExp ziv@2216: ziv@2234: val compare = ziv@2234: fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) ziv@2234: | (QueryArg _, _) => LESS ziv@2234: | (_, QueryArg _) => GREATER ziv@2234: | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) ziv@2234: | (DmlRel _, _) => LESS ziv@2234: | (_, DmlRel _) => GREATER ziv@2234: | (Prim p1, Prim p2) => Prim.compare (p1, p2) ziv@2234: | (Prim _, _) => LESS ziv@2234: | (_, Prim _) => GREATER ziv@2234: | (Field (t1, f1), Field (t2, f2)) => ziv@2234: case String.compare (t1, t2) of ziv@2234: EQUAL => String.compare (f1, f2) ziv@2234: | ord => ord ziv@2216: ziv@2216: end ziv@2216: ziv@2244: structure AtomOptionKey = OptionKeyFn(AtomExpKey) ziv@2244: ziv@2271: val rec tablesOfQuery = ziv@2271: fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) ziv@2271: | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) ziv@2271: ziv@2271: val tableOfDml = ziv@2271: fn Sql.Insert (tab, _) => tab ziv@2271: | Sql.Delete (tab, _) => tab ziv@2271: | Sql.Update (tab, _, _) => tab ziv@2271: ziv@2271: val freeVars = ziv@2271: MonoUtil.Exp.foldB ziv@2271: {typ = #2, ziv@2271: exp = fn (bound, ERel n, vars) => if n < bound ziv@2271: then vars ziv@2271: else IS.add (vars, n - bound) ziv@2271: | (_, _, vars) => vars, ziv@2271: bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} ziv@2271: 0 ziv@2271: IS.empty ziv@2271: ziv@2271: datatype unbind = Known of exp | Unknowns of int ziv@2271: ziv@2271: structure InvalInfo :> sig ziv@2271: type t ziv@2271: type state = {tableToIndices : SIMM.multimap, ziv@2271: indexToInvalInfo : (t * int) IntBinaryMap.map, ziv@2271: ffiInfo : {index : int, params : int} list, ziv@2271: index : int} ziv@2271: val empty : t ziv@2271: val singleton : Sql.query -> t ziv@2271: val query : t -> Sql.query ziv@2271: val orderArgs : t * IS.set -> int list ziv@2271: val unbind : t * unbind -> t option ziv@2271: val union : t * t -> t ziv@2271: val updateState : t * int * state -> state ziv@2271: end = struct ziv@2271: ziv@2271: type t = Sql.query list ziv@2271: ziv@2271: type state = {tableToIndices : SIMM.multimap, ziv@2271: indexToInvalInfo : (t * int) IntBinaryMap.map, ziv@2271: ffiInfo : {index : int, params : int} list, ziv@2271: index : int} ziv@2271: ziv@2271: val empty = [] ziv@2271: ziv@2271: fun singleton q = [q] ziv@2271: ziv@2271: val union = op@ ziv@2271: ziv@2271: (* Need lift', etc. because we don't have rank-2 polymorphism. This should ziv@2271: probably use a functor, but this works for now. *) ziv@2271: fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = ziv@2271: let ziv@2271: val rec tr = ziv@2271: fn Sql.SqNot se => lift Sql.SqNot (tr se) ziv@2271: | Sql.Binop (r, se1, se2) => ziv@2271: lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) ziv@2271: | Sql.SqKnown se => lift Sql.SqKnown (tr se) ziv@2271: | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e') ziv@2271: | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) ziv@2271: | se => pure se ziv@2271: in ziv@2271: tr ziv@2271: end ziv@2271: ziv@2271: fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f = ziv@2271: let ziv@2271: val rec mp = ziv@2271: fn Sql.Query1 q => ziv@2271: (case #Where q of ziv@2271: NONE => pure' (Sql.Query1 q) ziv@2271: | SOME se => ziv@2271: lift' (fn mpse => Sql.Query1 {Select = #Select q, ziv@2271: From = #From q, ziv@2271: Where = SOME mpse}) ziv@2271: (traverseSqexp ops f se)) ziv@2271: | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) ziv@2271: in ziv@2271: mp ziv@2271: end ziv@2271: ziv@2271: fun foldMapQuery plus zero = traverseQuery (fn _ => zero, ziv@2271: fn _ => zero, ziv@2271: fn _ => fn x => x, ziv@2271: fn _ => fn x => x, ziv@2271: fn _ => fn x => x, ziv@2271: fn _ => plus, ziv@2271: fn _ => plus) ziv@2271: ziv@2271: val omapQuery = traverseQuery (SOME, SOME, omap, omap, omap, omap2, omap2) ziv@2271: ziv@2271: val varsOfQuery = foldMapQuery IS.union ziv@2271: IS.empty ziv@2271: (fn e' => freeVars (e', dummyLoc)) ziv@2271: ziv@2271: val varsOfList = ziv@2271: fn [] => IS.empty ziv@2271: | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs) ziv@2271: ziv@2271: fun orderArgs (qs, vars) = ziv@2271: let ziv@2271: val invalVars = varsOfList qs ziv@2271: in ziv@2271: (* Put arguments we might invalidate by first. *) ziv@2271: IS.listItems invalVars @ IS.listItems (IS.difference (vars, invalVars)) ziv@2271: end ziv@2271: ziv@2271: (* As a kludge, we rename the variables in the query to correspond to the ziv@2271: argument of the cache they're part of. *) ziv@2271: val query = ziv@2271: fn (q::qs) => ziv@2271: let ziv@2271: val q = List.foldl Sql.Union q qs ziv@2271: val ns = IS.listItems (varsOfQuery q) ziv@2271: val rename = ziv@2271: fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) ziv@2271: | _ => raise Match ziv@2271: in ziv@2271: case omapQuery rename q of ziv@2271: SOME q => q ziv@2271: (* We should never get NONE because indexOf should never fail. *) ziv@2271: | NONE => raise Match ziv@2271: end ziv@2271: (* We should never reach this case because [updateState] won't put ziv@2271: anything in the state if there are no queries. *) ziv@2271: | [] => raise Match ziv@2271: ziv@2271: fun unbind1 ub = ziv@2271: case ub of ziv@2271: Known (e', loc) => ziv@2271: let ziv@2271: val replaceRel0 = case e' of ziv@2271: ERel m => SOME (ERel m) ziv@2271: | _ => NONE ziv@2271: in ziv@2271: omapQuery (fn ERel 0 => replaceRel0 ziv@2271: | ERel n => SOME (ERel (n-1)) ziv@2271: | _ => raise Match) ziv@2271: end ziv@2271: | Unknowns k => ziv@2271: omapQuery (fn ERel n => if n >= k then NONE else SOME (ERel (n-k)) ziv@2271: | _ => raise Match) ziv@2271: ziv@2271: fun unbind (qs, ub) = ziv@2271: case ub of ziv@2271: (* Shortcut if nothing's changing. *) ziv@2271: Unknowns 0 => SOME qs ziv@2271: | _ => osequence (map (unbind1 ub) qs) ziv@2271: ziv@2271: fun updateState ((qs, numArgs, state as {index, ...}) : t * int * state) = ziv@2271: {tableToIndices = List.foldr (fn (q, acc) => ziv@2271: SS.foldl (fn (tab, acc) => ziv@2271: SIMM.insert (acc, tab, index)) ziv@2271: acc ziv@2271: (tablesOfQuery q)) ziv@2271: (#tableToIndices state) ziv@2271: qs, ziv@2271: indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)), ziv@2271: ffiInfo = {index = index, params = numArgs} :: #ffiInfo state, ziv@2271: index = index + 1} ziv@2271: ziv@2271: end ziv@2271: ziv@2216: structure UF = UnionFindFn(AtomExpKey) ziv@2234: ziv@2235: structure ConflictMaps = struct ziv@2235: ziv@2235: structure TK = TripleKeyFn(structure I = CmpKey ziv@2244: structure J = AtomOptionKey ziv@2244: structure K = AtomOptionKey) ziv@2244: structure TS : ORD_SET = BinarySetFn(TK) ziv@2235: ziv@2235: val toKnownEquality = ziv@2235: (* [NONE] here means unkown. Anything that isn't a comparison between two ziv@2235: knowns shouldn't be used, and simply dropping unused terms is okay in ziv@2235: disjunctive normal form. *) ziv@2235: fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2) ziv@2235: | _ => NONE ziv@2235: ziv@2235: val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list = ziv@2235: UF.classes ziv@2235: o List.foldl UF.union' UF.empty ziv@2235: o List.mapPartial toKnownEquality ziv@2235: ziv@2235: fun addToEqs (eqs, n, e) = ziv@2235: case IM.find (eqs, n) of ziv@2235: (* Comparing to a constant is probably better than comparing to a ziv@2235: variable? Checking that existing constants match a new ones is ziv@2235: handled by [accumulateEqs]. *) ziv@2235: SOME (Prim _) => eqs ziv@2235: | _ => IM.insert (eqs, n, e) ziv@2235: ziv@2235: val accumulateEqs = ziv@2235: (* [NONE] means we have a contradiction. *) ziv@2235: fn (_, NONE) => NONE ziv@2235: | ((Prim p1, Prim p2), eqso) => ziv@2235: (case Prim.compare (p1, p2) of ziv@2235: EQUAL => eqso ziv@2235: | _ => NONE) ziv@2235: | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) ziv@2235: | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) ziv@2235: | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) ziv@2235: | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) ziv@2235: (* TODO: deal with equalities between [DmlRel]s and [Prim]s. ziv@2235: This would involve guarding the invalidation with a check for the ziv@2235: relevant comparisons. *) ziv@2235: | (_, eqso) => eqso ziv@2235: ziv@2235: val eqsOfClass : atomExp list -> atomExp IM.map option = ziv@2235: List.foldl accumulateEqs (SOME IM.empty) ziv@2235: o chooseTwos ziv@2235: ziv@2235: fun toAtomExps rel (cmp, e1, e2) = ziv@2235: let ziv@2235: val qa = ziv@2235: (* Here [NONE] means unkown. *) ziv@2235: fn Sql.SqConst p => SOME (Prim p) ziv@2235: | Sql.Field tf => SOME (Field tf) ziv@2235: | Sql.Inj (EPrim p, _) => SOME (Prim p) ziv@2235: | Sql.Inj (ERel n, _) => SOME (rel n) ziv@2235: (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP ziv@2235: becomes Sql.Unmodeled, which becomes NONE here. *) ziv@2235: | _ => NONE ziv@2235: in ziv@2235: (cmp, qa e1, qa e2) ziv@2235: end ziv@2235: ziv@2244: val negateCmp = ziv@2244: fn Sql.Eq => Sql.Ne ziv@2244: | Sql.Ne => Sql.Eq ziv@2244: | Sql.Lt => Sql.Ge ziv@2244: | Sql.Le => Sql.Gt ziv@2244: | Sql.Gt => Sql.Le ziv@2244: | Sql.Ge => Sql.Lt ziv@2244: ziv@2244: fun normalizeAtom (negating, (cmp, e1, e2)) = ziv@2244: (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with ziv@2244: simplification, where we put the triples in sets. *) ziv@2244: case (if negating then negateCmp cmp else cmp) of ziv@2244: Sql.Eq => (case AtomOptionKey.compare (e1, e2) of ziv@2244: LESS => (Sql.Eq, e2, e1) ziv@2244: | _ => (Sql.Eq, e1, e2)) ziv@2244: | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of ziv@2244: LESS => (Sql.Ne, e2, e1) ziv@2244: | _ => (Sql.Ne, e1, e2)) ziv@2244: | Sql.Lt => (Sql.Lt, e1, e2) ziv@2244: | Sql.Le => (Sql.Le, e1, e2) ziv@2244: | Sql.Gt => (Sql.Lt, e2, e1) ziv@2244: | Sql.Ge => (Sql.Le, e2, e1) ziv@2235: ziv@2235: val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> ziv@2235: (Sql.cmp * atomExp option * atomExp option) formula = ziv@2235: mapFormula (toAtomExps QueryArg) ziv@2235: ziv@2235: val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> ziv@2235: (Sql.cmp * atomExp option * atomExp option) formula = ziv@2235: mapFormula (toAtomExps DmlRel) ziv@2250: ziv@2235: (* No eqs should have key conflicts because no variable is in two ziv@2235: equivalence classes, so the [#1] could be [#2]. *) ziv@2235: val mergeEqs : (atomExp IntBinaryMap.map option list ziv@2235: -> atomExp IntBinaryMap.map option) = ziv@2271: List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty) ziv@2235: ziv@2239: val simplify = ziv@2239: map TS.listItems ziv@2239: o removeRedundant (fn (x, y) => TS.isSubset (y, x)) ziv@2239: o map (fn xs => TS.addList (TS.empty, xs)) ziv@2239: ziv@2235: fun dnf (fQuery, fDml) = ziv@2244: normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml])) ziv@2235: ziv@2235: val conflictMaps = List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf ziv@2235: ziv@2235: end ziv@2235: ziv@2235: val conflictMaps = ConflictMaps.conflictMaps ziv@2213: ziv@2216: val rec sqexpToFormula = ziv@2234: fn Sql.SqTrue => Combo (Conj, []) ziv@2234: | Sql.SqFalse => Combo (Disj, []) ziv@2216: | Sql.SqNot e => Negate (sqexpToFormula e) ziv@2216: | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) ziv@2234: | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, ziv@2216: [sqexpToFormula p1, sqexpToFormula p2]) ziv@2216: (* ASK: any other sqexps that can be props? *) ziv@2216: | _ => raise Match ziv@2213: ziv@2218: fun renameTables tablePairs = ziv@2216: let ziv@2216: fun renameString table = ziv@2216: case List.find (fn (_, t) => table = t) tablePairs of ziv@2216: NONE => table ziv@2216: | SOME (realTable, _) => realTable ziv@2216: val renameSqexp = ziv@2216: fn Sql.Field (table, field) => Sql.Field (renameString table, field) ziv@2216: | e => e ziv@2218: fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2) ziv@2216: in ziv@2218: mapFormula renameAtom ziv@2216: end ziv@2218: ziv@2218: val rec queryToFormula = ziv@2234: fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, []) ziv@2218: | Sql.Query1 {From = tablePairs, Where = SOME e, ...} => ziv@2218: renameTables tablePairs (sqexpToFormula e) ziv@2234: | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2]) ziv@2216: ziv@2218: fun valsToFormula (table, vals) = ziv@2234: Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) ziv@2218: ziv@2216: val rec dmlToFormula = ziv@2221: fn Sql.Insert (table, vals) => valsToFormula (table, vals) ziv@2218: | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher) ziv@2218: | Sql.Update (table, vals, wher) => ziv@2218: let ziv@2221: val fWhere = sqexpToFormula wher ziv@2221: val fVals = valsToFormula (table, vals) ziv@2237: val modifiedFields = SS.addList (SS.empty, map #1 vals) ziv@2221: (* TODO: don't use field name hack. *) ziv@2221: val markField = ziv@2237: fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v) ziv@2237: then Sql.Field (t, v ^ "'") ziv@2237: else e ziv@2221: | e => e ziv@2221: val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) ziv@2218: in ziv@2218: renameTables [(table, "T")] ziv@2234: (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]), ziv@2244: Combo (Conj, [mark fVals, fWhere])])) ziv@2218: end ziv@2213: ziv@2213: ziv@2265: (*************************************) ziv@2265: (* Program Instrumentation Utilities *) ziv@2265: (*************************************) ziv@2213: ziv@2234: val varName = ziv@2234: let ziv@2234: val varNumber = ref 0 ziv@2234: in ziv@2234: fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber)) ziv@2234: end ziv@2234: ziv@2233: val {check, store, flush, ...} = getCache () ziv@2233: ziv@2248: val dummyTyp = (TRecord [], dummyLoc) ziv@2248: ziv@2230: fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) ziv@2230: ziv@2230: val stringTyp = (TFfi ("Basis", "string"), dummyLoc) ziv@2213: ziv@2213: val sequence = ziv@2213: fn (exp :: exps) => ziv@2213: let ziv@2230: val loc = dummyLoc ziv@2213: in ziv@2213: List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps ziv@2213: end ziv@2213: | _ => raise Match ziv@2213: ziv@2248: (* Always increments negative indices as a hack we use later. *) ziv@2248: fun incRels inc = ziv@2215: MonoUtil.Exp.mapB ziv@2248: {typ = fn t' => t', ziv@2248: exp = fn bound => ziv@2248: (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) ziv@2248: | e' => e'), ziv@2248: bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} ziv@2248: 0 ziv@2213: ziv@2262: fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = ziv@2262: let ziv@2262: fun doVal env ((x, n, t, exp, s), state) = ziv@2262: let ziv@2262: val (exp, state) = doTopLevelExp env exp state ziv@2262: in ziv@2262: ((x, n, t, exp, s), state) ziv@2262: end ziv@2262: fun doDecl' env (decl', state) = ziv@2262: case decl' of ziv@2262: DVal v => ziv@2262: let ziv@2262: val (v, state) = doVal env (v, state) ziv@2262: in ziv@2262: (DVal v, state) ziv@2262: end ziv@2262: | DValRec vs => ziv@2262: let ziv@2262: val (vs, state) = ListUtil.foldlMap (doVal env) state vs ziv@2262: in ziv@2262: (DValRec vs, state) ziv@2262: end ziv@2262: | _ => (decl', state) ziv@2262: fun doDecl (decl as (decl', loc), (env, state)) = ziv@2262: let ziv@2262: val env = MonoEnv.declBinds env decl ziv@2262: val (decl', state) = doDecl' env (decl', state) ziv@2262: in ziv@2262: ((decl', loc), (env, state)) ziv@2262: end ziv@2262: val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls) ziv@2262: in ziv@2262: ((decls, sideInfo), state) ziv@2262: end ziv@2262: ziv@2262: fun fileAllMapfoldB doExp file start = ziv@2248: case MonoUtil.File.mapfoldB ziv@2248: {typ = Search.return2, ziv@2250: exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), ziv@2248: decl = fn _ => Search.return2, ziv@2248: bind = doBind} ziv@2250: MonoEnv.empty file start of ziv@2213: Search.Continue x => x ziv@2213: | Search.Return _ => raise Match ziv@2213: ziv@2262: fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) ziv@2213: ziv@2267: (* TODO: make this a bit prettier.... *) ziv@2267: val simplifySql = ziv@2266: let ziv@2267: fun factorOutNontrivial text = ziv@2267: let ziv@2267: val loc = dummyLoc ziv@2267: fun strcat (e1, e2) = (EStrcat (e1, e2), loc) ziv@2267: val chunks = Sql.chunkify text ziv@2267: val (newText, newVariables) = ziv@2267: (* Important that this is foldr (to oppose foldl below). *) ziv@2267: List.foldr ziv@2267: (fn (chunk, (qText, newVars)) => ziv@2267: (* Variable bound to the head of newVars will have the lowest index. *) ziv@2267: case chunk of ziv@2267: (* EPrim should always be a string in this case. *) ziv@2267: Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) ziv@2267: | Sql.Exp e => ziv@2267: let ziv@2267: val n = length newVars ziv@2267: in ziv@2267: (* This is the (n+1)th new variable, so there are ziv@2267: already n new variables bound, so we increment ziv@2267: indices by n. *) ziv@2267: (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) ziv@2267: end ziv@2267: | Sql.String s => (strcat (stringExp s, qText), newVars)) ziv@2267: (stringExp "", []) ziv@2267: chunks ziv@2267: fun wrapLets e' = ziv@2267: (* Important that this is foldl (to oppose foldr above). *) ziv@2267: List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) ziv@2267: e' ziv@2267: newVariables ziv@2267: val numArgs = length newVariables ziv@2267: in ziv@2267: (newText, wrapLets, numArgs) ziv@2267: end ziv@2267: fun doExp exp' = ziv@2267: let ziv@2267: val text = case exp' of ziv@2267: EQuery {query = text, ...} => text ziv@2267: | EDml (text, _) => text ziv@2267: | _ => raise Match ziv@2267: val (newText, wrapLets, numArgs) = factorOutNontrivial text ziv@2267: val newExp' = case exp' of ziv@2267: EQuery q => EQuery {query = newText, ziv@2267: exps = #exps q, ziv@2267: tables = #tables q, ziv@2267: state = #state q, ziv@2267: body = #body q, ziv@2267: initial = #initial q} ziv@2267: | EDml (_, failureMode) => EDml (newText, failureMode) ziv@2267: | _ => raise Match ziv@2267: in ziv@2267: (* Increment once for each new variable just made. This is ziv@2267: where we use the negative De Bruijn indices hack. *) ziv@2267: (* TODO: please don't use that hack. As anyone could have ziv@2267: predicted, it was incomprehensible a year later.... *) ziv@2267: wrapLets (#1 (incRels numArgs (newExp', dummyLoc))) ziv@2267: end ziv@2266: in ziv@2267: fileMap (fn exp' => case exp' of ziv@2267: EQuery _ => doExp exp' ziv@2267: | EDml _ => doExp exp' ziv@2267: | _ => exp') ziv@2266: end ziv@2266: ziv@2250: ziv@2250: (**********************) ziv@2250: (* Mono Type Checking *) ziv@2250: (**********************) ziv@2250: ziv@2250: fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = ziv@2250: fn EPrim p => SOME (TFfi ("Basis", case p of ziv@2250: Prim.Int _ => "int" ziv@2250: | Prim.Float _ => "double" ziv@2250: | Prim.String _ => "string" ziv@2250: | Prim.Char _ => "char"), ziv@2250: dummyLoc) ziv@2250: | ERel n => SOME (#2 (MonoEnv.lookupERel env n)) ziv@2250: | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n)) ziv@2250: (* ASK: okay to make a new [ref] each time? *) ziv@2250: | ECon (dk, PConVar nCon, _) => ziv@2250: let ziv@2250: val (_, _, nData) = MonoEnv.lookupConstructor env nCon ziv@2250: val (_, cs) = MonoEnv.lookupDatatype env nData ziv@2250: in ziv@2250: SOME (TDatatype (nData, ref (dk, cs)), dummyLoc) ziv@2250: end ziv@2250: | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc) ziv@2250: | ENone t => SOME (TOption t, dummyLoc) ziv@2250: | ESome (t, _) => SOME (TOption t, dummyLoc) ziv@2250: | EFfi _ => NONE ziv@2250: | EFfiApp _ => NONE ziv@2250: | EApp (e1, e2) => (case typOfExp env e1 of ziv@2250: SOME (TFun (_, t), _) => SOME t ziv@2250: | _ => NONE) ziv@2250: | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc) ziv@2250: (* ASK: is this right? *) ziv@2250: | EUnop (unop, e) => (case unop of ziv@2250: "!" => SOME (TFfi ("Basis", "bool"), dummyLoc) ziv@2250: | "-" => typOfExp env e ziv@2250: | _ => NONE) ziv@2250: (* ASK: how should this (and other "=> NONE" cases) work? *) ziv@2250: | EBinop _ => NONE ziv@2250: | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc) ziv@2250: | EField (e, s) => (case typOfExp env e of ziv@2250: SOME (TRecord fields, _) => ziv@2250: (case List.find (fn (s', _) => s = s') fields of ziv@2250: SOME (_, t) => SOME t ziv@2250: | _ => NONE) ziv@2250: | _ => NONE) ziv@2250: | ECase (_, _, {result, ...}) => SOME result ziv@2250: | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc) ziv@2250: | EWrite _ => SOME (TRecord [], dummyLoc) ziv@2250: | ESeq (_, e) => typOfExp env e ziv@2250: | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 ziv@2250: | EClosure _ => NONE ziv@2250: | EUnurlify (_, t, _) => SOME t ziv@2269: | EQuery {state, ...} => SOME state ziv@2256: | _ => NONE ziv@2250: ziv@2250: and typOfExp env (e', loc) = typOfExp' env e' ziv@2250: ziv@2250: ziv@2266: (***********) ziv@2266: (* Caching *) ziv@2266: (***********) ziv@2250: ziv@2267: (* ziv@2267: ziv@2267: To get the invalidations for a dml, we need (each <- is list-monad-y): ziv@2267: * table <- dml ziv@2267: * cache <- table ziv@2267: * query <- cache ziv@2267: * inval <- (query, dml), ziv@2267: where inval is a list of query argument indices, so ziv@2267: * way to change query args in inval to cache args. ziv@2267: For now, the last one is just ziv@2267: * a map from query arg number to the corresponding free variable (per query) ziv@2267: * a map from free variable to cache arg number (per cache). ziv@2267: Both queries and caches should have IDs. ziv@2267: ziv@2267: *) ziv@2267: ziv@2271: type state = InvalInfo.state ziv@2271: ziv@2271: datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp ziv@2271: ziv@2271: val isImpure = ziv@2271: fn Cachable _ => false ziv@2271: | Impure _ => true ziv@2271: ziv@2271: val runSubexp : subexp * state -> exp * state = ziv@2271: fn (Cachable (_, f), state) => f state ziv@2271: | (Impure e, state) => (e, state) ziv@2271: ziv@2271: val invalInfoOfSubexp = ziv@2271: fn Cachable (invalInfo, _) => invalInfo ziv@2271: | Impure _ => raise Match ziv@2271: ziv@2271: fun cacheWrap (env, exp, typ, args, index) = ziv@2265: let ziv@2265: val loc = dummyLoc ziv@2265: val rel0 = (ERel 0, loc) ziv@2265: in ziv@2271: case MonoFooify.urlify env (rel0, typ) of ziv@2265: NONE => NONE ziv@2265: | SOME urlified => ziv@2265: let ziv@2265: (* We ensure before this step that all arguments aren't effectful. ziv@2265: by turning them into local variables as needed. *) ziv@2265: val argsInc = map (incRels 1) args ziv@2268: val check = (check (index, args), loc) ziv@2268: val store = (store (index, argsInc, urlified), loc) ziv@2265: in ziv@2271: SOME (ECase (check, ziv@2271: [((PNone stringTyp, loc), ziv@2271: (ELet (varName "q", typ, exp, (ESeq (store, rel0), loc)), loc)), ziv@2271: ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), ziv@2271: (* Boolean is false because we're not unurlifying from a cookie. *) ziv@2271: (EUnurlify (rel0, typ, false), loc))], ziv@2271: {disc = (TOption stringTyp, loc), result = typ})) ziv@2265: end ziv@2265: end ziv@2265: ziv@2258: val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 ziv@2258: ziv@2259: (* TODO: pick a number. *) ziv@2259: val sizeWorthCaching = 5 ziv@2259: ziv@2269: val worthCaching = ziv@2269: fn EQuery _ => true ziv@2269: | exp' => expSize (exp', dummyLoc) > sizeWorthCaching ziv@2269: ziv@2271: fun cacheExp ((env, exp', invalInfo, state) : MonoEnv.env * exp' * InvalInfo.t * state) = ziv@2269: case (worthCaching exp') ziv@2269: ziv@2269: typOfExp' env exp' of ziv@2269: NONE => NONE ziv@2269: | SOME (TFun _, _) => NONE ziv@2269: | SOME typ => ziv@2271: let ziv@2271: val ns = InvalInfo.orderArgs (invalInfo, freeVars (exp', dummyLoc)) ziv@2271: val numArgs = length ns ziv@2271: in (List.foldr (fn (_, NONE) => NONE ziv@2271: | ((n, typ), SOME args) => ziv@2271: (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) ziv@2271: ziv@2271: (fn arg => SOME (arg :: args))) ziv@2271: (SOME []) ziv@2271: (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) ns)) ziv@2271: ziv@2271: (fn args => ziv@2271: (cacheWrap (env, (exp', dummyLoc), typ, args, #index state)) ziv@2271: ziv@2271: (fn cachedExp => ziv@2271: SOME (cachedExp, InvalInfo.updateState (invalInfo, numArgs, state)))) ziv@2271: end ziv@2269: ziv@2271: fun cacheQuery (effs, env, q) : subexp = ziv@2266: let ziv@2266: (* We use dummyTyp here. I think this is okay because databases don't ziv@2266: store (effectful) functions, but perhaps there's some pathalogical ziv@2266: corner case missing.... *) ziv@2266: fun safe bound = ziv@2266: not ziv@2266: o effectful effs ziv@2266: (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) ziv@2266: bound ziv@2266: env) ziv@2271: val {query = queryText, initial, body, ...} = q ziv@2271: (* DEBUG *) ziv@2271: (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) ziv@2266: val attempt = ziv@2266: (* Ziv misses Haskell's do notation.... *) ziv@2267: (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ziv@2268: ziv@2268: Sql.parse Sql.query queryText ziv@2268: ziv@2268: (fn queryParsed => ziv@2271: let ziv@2271: val invalInfo = InvalInfo.singleton queryParsed ziv@2271: fun mkExp state = ziv@2271: case cacheExp (env, EQuery q, invalInfo, state) of ziv@2271: NONE => ((EQuery q, dummyLoc), state) ziv@2271: | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) ziv@2271: in ziv@2271: SOME (Cachable (invalInfo, mkExp)) ziv@2271: end) ziv@2266: in ziv@2266: case attempt of ziv@2271: NONE => Impure (EQuery q, dummyLoc) ziv@2271: | SOME subexp => subexp ziv@2266: end ziv@2266: ziv@2271: fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = ziv@2250: let ziv@2271: fun wrapBindN (f : exp list -> exp') ziv@2271: (args : ((MonoEnv.env * exp) * unbind) list) = ziv@2250: let ziv@2271: val (subexps, state) = ziv@2271: ListUtil.foldlMap (cacheTree effs) ziv@2271: state ziv@2271: (map #1 args) ziv@2268: fun mkExp state = mapFst (fn exps => (f exps, loc)) ziv@2268: (ListUtil.foldlMap runSubexp state subexps) ziv@2271: val attempt = ziv@2271: if List.exists isImpure subexps ziv@2271: then NONE ziv@2271: else (List.foldl (omap2 InvalInfo.union) ziv@2271: (SOME InvalInfo.empty) ziv@2271: (ListPair.map ziv@2271: (fn (subexp, (_, unbinds)) => ziv@2271: InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) ziv@2271: (subexps, args))) ziv@2271: ziv@2271: (fn invalInfo => ziv@2271: SOME (Cachable (invalInfo, ziv@2271: fn state => ziv@2271: case cacheExp (env, ziv@2271: f (map (#2 o #1) args), ziv@2271: invalInfo, ziv@2271: state) of ziv@2271: NONE => mkExp state ziv@2271: | SOME (e', state) => ((e', loc), state)), ziv@2271: state)) ziv@2250: in ziv@2271: case attempt of ziv@2271: SOME (subexp, state) => (subexp, state) ziv@2271: | NONE => mapFst Impure (mkExp state) ziv@2250: end ziv@2250: fun wrapBind1 f arg = ziv@2250: wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] ziv@2250: fun wrapBind2 f (arg1, arg2) = ziv@2250: wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2] ziv@2271: fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es) ziv@2271: fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0) ziv@2271: fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0)) ziv@2250: in ziv@2250: case exp' of ziv@2250: ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e ziv@2250: | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e ziv@2250: | EFfiApp (s1, s2, args) => ziv@2258: if ffiEffectful (s1, s2) ziv@2266: then (Impure exp, state) ziv@2258: else wrapN (fn es => ziv@2258: EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args))) ziv@2258: (map #1 args) ziv@2250: | EApp (e1, e2) => wrap2 EApp (e1, e2) ziv@2250: | EAbs (s, t1, t2, e) => ziv@2250: wrapBind1 (fn e => EAbs (s, t1, t2, e)) ziv@2271: ((MonoEnv.pushERel env s t1 NONE, e), Unknowns 1) ziv@2250: | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e ziv@2250: | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2) ziv@2250: | ERecord fields => ziv@2250: wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields))) ziv@2250: (map #2 fields) ziv@2250: | EField (e, s) => wrap1 (fn e => EField (e, s)) e ziv@2250: | ECase (e, cases, {disc, result}) => ziv@2250: wrapBindN (fn (e::es) => ziv@2250: ECase (e, ziv@2250: (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), ziv@2256: {disc = disc, result = result}) ziv@2256: | _ => raise Match) ziv@2271: (((env, e), Unknowns 0) ziv@2271: :: map (fn (p, e) => ziv@2271: ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p))) ziv@2271: cases) ziv@2250: | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) ziv@2250: (* We record page writes, so they're cachable. *) ziv@2250: | EWrite e => wrap1 EWrite e ziv@2250: | ESeq (e1, e2) => wrap2 ESeq (e1, e2) ziv@2250: | ELet (s, t, e1, e2) => ziv@2250: wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2)) ziv@2271: (((env, e1), Unknowns 0), ziv@2271: ((MonoEnv.pushERel env s t (SOME e1), e2), Known e1)) ziv@2250: (* ASK: | EClosure (n, es) => ? *) ziv@2250: | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e ziv@2271: | EQuery q => (cacheQuery (effs, env, q), state) ziv@2269: | _ => (if effectful effs env exp ziv@2269: then Impure exp ziv@2271: else Cachable (InvalInfo.empty, ziv@2271: fn state => ziv@2271: case cacheExp (env, exp', InvalInfo.empty, state) of ziv@2269: NONE => ((exp', loc), state) ziv@2269: | SOME (exp', state) => ((exp', loc), state)), ziv@2269: state) ziv@2256: end ziv@2256: ziv@2266: fun addCaching file = ziv@2256: let ziv@2266: val effs = effectfulDecls file ziv@2271: fun doTopLevelExp env exp state = runSubexp (cacheTree effs ((env, exp), state)) ziv@2256: in ziv@2271: (fileTopLevelMapfoldB doTopLevelExp ziv@2271: file ziv@2271: {tableToIndices = SIMM.empty, ziv@2271: indexToInvalInfo = IM.empty, ziv@2271: ffiInfo = [], ziv@2271: index = 0}, ziv@2271: effs) ziv@2265: end ziv@2265: ziv@2265: ziv@2265: (************) ziv@2265: (* Flushing *) ziv@2265: (************) ziv@2265: ziv@2265: structure Invalidations = struct ziv@2265: ziv@2265: val loc = dummyLoc ziv@2265: ziv@2265: val optionAtomExpToExp = ziv@2265: fn NONE => (ENone stringTyp, loc) ziv@2265: | SOME e => (ESome (stringTyp, ziv@2265: (case e of ziv@2265: DmlRel n => ERel n ziv@2265: | Prim p => EPrim p ziv@2265: (* TODO: make new type containing only these two. *) ziv@2265: | _ => raise Match, ziv@2265: loc)), ziv@2265: loc) ziv@2265: ziv@2265: fun eqsToInvalidation numArgs eqs = ziv@2269: List.tabulate (numArgs, (fn n => IM.find (eqs, n))) ziv@2265: ziv@2265: (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here ziv@2265: represents unknown, which means a wider invalidation. *) ziv@2265: val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = ziv@2265: fn ([], []) => true ziv@2265: | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) ziv@2265: | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of ziv@2265: EQUAL => madeRedundantBy (xs, ys) ziv@2265: | _ => false) ziv@2265: | _ => false ziv@2265: ziv@2265: fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) ziv@2265: ziv@2271: fun invalidations ((invalInfo, numArgs), dml) = ziv@2271: let ziv@2271: val query = InvalInfo.query invalInfo ziv@2271: in ziv@2271: (map (map optionAtomExpToExp) ziv@2271: o removeRedundant madeRedundantBy ziv@2271: o map (eqsToInvalidation numArgs) ziv@2271: o eqss) ziv@2271: (query, dml) ziv@2271: end ziv@2265: ziv@2265: end ziv@2265: ziv@2265: val invalidations = Invalidations.invalidations ziv@2265: ziv@2265: (* DEBUG *) ziv@2265: (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) ziv@2265: (* val gunk' : exp list ref = ref [] *) ziv@2265: ziv@2271: fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, index}), effs) = ziv@2265: let ziv@2265: val flushes = List.concat ziv@2265: o map (fn (i, argss) => map (fn args => flush (i, args)) argss) ziv@2265: val doExp = ziv@2267: fn dmlExp as EDml (dmlText, failureMode) => ziv@2265: let ziv@2265: (* DEBUG *) ziv@2265: (* val () = gunk' := origDmlText :: !gunk' *) ziv@2265: (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) ziv@2265: val inval = ziv@2265: case Sql.parse Sql.dml dmlText of ziv@2265: SOME dmlParsed => ziv@2271: SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of ziv@2271: SOME invalInfo => ziv@2271: (i, invalidations (invalInfo, dmlParsed)) ziv@2265: (* TODO: fail more gracefully. *) ziv@2271: (* This probably means invalidating everything.... *) ziv@2265: | NONE => raise Match)) ziv@2271: (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) ziv@2265: | NONE => NONE ziv@2265: in ziv@2265: case inval of ziv@2265: (* TODO: fail more gracefully. *) ziv@2265: NONE => raise Match ziv@2267: | SOME invs => sequence (flushes invs @ [dmlExp]) ziv@2265: end ziv@2265: | e' => e' ziv@2265: in ziv@2265: (* DEBUG *) ziv@2265: (* gunk := []; *) ziv@2268: ffiInfoRef := ffiInfo; ziv@2266: fileMap doExp file ziv@2265: end ziv@2265: ziv@2265: ziv@2268: (************************) ziv@2268: (* Compiler Entry Point *) ziv@2268: (************************) ziv@2265: ziv@2265: val inlineSql = ziv@2265: let ziv@2265: val doExp = ziv@2265: (* TODO: EQuery, too? *) ziv@2265: (* ASK: should this live in [MonoOpt]? *) ziv@2265: fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => ziv@2265: let ziv@2265: val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases ziv@2265: in ziv@2265: ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) ziv@2265: end ziv@2265: | e => e ziv@2265: in ziv@2265: fileMap doExp ziv@2265: end ziv@2265: ziv@2262: fun insertAfterDatatypes ((decls, sideInfo), newDecls) = ziv@2262: let ziv@2262: val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls ziv@2262: in ziv@2262: (datatypes @ newDecls @ others, sideInfo) ziv@2262: end ziv@2262: ziv@2267: val go' = addFlushing o addCaching o simplifySql o inlineSql ziv@2256: ziv@2256: fun go file = ziv@2256: let ziv@2256: (* TODO: do something nicer than [Sql] being in one of two modes. *) ziv@2256: val () = (resetFfiInfo (); Sql.sqlcacheMode := true) ziv@2262: val file = go' file ziv@2262: (* Important that this happens after [MonoFooify.urlify] calls! *) ziv@2262: val fmDecls = MonoFooify.getNewFmDecls () ziv@2256: val () = Sql.sqlcacheMode := false ziv@2256: in ziv@2262: insertAfterDatatypes (file, rev fmDecls) ziv@2250: end ziv@2250: ziv@2209: end