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@2265: (* Filled in by [cacheWrap]. *) ziv@2213: val ffiInfo : {index : int, params : int} list ref = ref [] ziv@2209: ziv@2227: fun resetFfiInfo () = ffiInfo := [] ziv@2227: ziv@2213: fun getFfiInfo () = !ffiInfo 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@2266: (***********************) ziv@2266: (* General Combinators *) ziv@2266: (***********************) ziv@2266: ziv@2266: (* From the MLton wiki. *) ziv@2266: infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *) ziv@2266: infix 3 \> fun f \> y = f y (* Left application *) ziv@2266: infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *) ziv@2266: infixr 3 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@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@2235: List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE) ziv@2235: (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: val rec tablesQuery = ziv@2216: fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) ziv@2216: | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) ziv@2213: ziv@2213: val tableDml = ziv@2216: fn Sql.Insert (tab, _) => tab ziv@2216: | Sql.Delete (tab, _) => tab ziv@2216: | Sql.Update (tab, _, _) => tab 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@2230: val dummyLoc = ErrorMsg.dummySpan ziv@2216: 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@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@2265: fun cacheWrap (env, exp, resultTyp, args, i) = ziv@2265: let ziv@2265: val loc = dummyLoc ziv@2265: val rel0 = (ERel 0, loc) ziv@2265: in ziv@2265: case MonoFooify.urlify env (rel0, resultTyp) of ziv@2265: NONE => NONE ziv@2265: | SOME urlified => ziv@2265: let ziv@2265: val () = ffiInfo := {index = i, params = length args} :: !ffiInfo 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@2265: val check = (check (i, args), loc) ziv@2265: val store = (store (i, argsInc, urlified), loc) ziv@2265: in ziv@2265: SOME (ECase ziv@2265: (check, ziv@2265: [((PNone stringTyp, loc), ziv@2265: (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), ziv@2265: ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), ziv@2265: (* Boolean is false because we're not unurlifying from a cookie. *) ziv@2265: (EUnurlify (rel0, resultTyp, false), loc))], ziv@2265: {disc = (TOption stringTyp, loc), result = resultTyp})) ziv@2265: end ziv@2265: end ziv@2265: ziv@2267: val maxFreeVar = ziv@2267: MonoUtil.Exp.foldB ziv@2267: {typ = #2, ziv@2267: exp = fn (bound, ERel n, v) => Int.max (v, n - bound) | (_, _, v) => v, ziv@2267: bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} ziv@2267: 0 ziv@2267: ~1 ziv@2267: ziv@2257: val freeVars = ziv@2257: IS.listItems ziv@2257: o MonoUtil.Exp.foldB ziv@2257: {typ = #2, ziv@2257: exp = fn (bound, ERel n, vars) => if n < bound ziv@2257: then vars ziv@2257: else IS.add (vars, n - bound) ziv@2257: | (_, _, vars) => vars, ziv@2257: bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} ziv@2257: 0 ziv@2257: IS.empty ziv@2257: ziv@2258: val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 ziv@2258: ziv@2267: datatype subexp = Cachable of unit -> exp | Impure of exp ziv@2250: ziv@2250: val isImpure = ziv@2267: fn Cachable _ => false ziv@2250: | Impure _ => true ziv@2250: ziv@2250: val expOfSubexp = ziv@2267: fn Cachable f => f () ziv@2250: | Impure e => e ziv@2250: ziv@2259: (* TODO: pick a number. *) ziv@2259: val sizeWorthCaching = 5 ziv@2259: ziv@2266: type state = (SIMM.multimap * (Sql.query * int) IntBinaryMap.map * int) ziv@2266: ziv@2266: fun incIndex (x, y, index) = (x, y, index+1) ziv@2266: ziv@2266: fun cacheQuery effs env (state as (tableToIndices, indexToQueryNumArgs, index)) = ziv@2267: fn q as {query = queryText, ziv@2267: state = resultTyp, ziv@2267: initial, body, tables, exps} => ziv@2266: let ziv@2267: val numArgs = maxFreeVar queryText + 1 ziv@2267: val queryExp = (EQuery q, dummyLoc) ziv@2266: (* DEBUG *) ziv@2266: (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) ziv@2266: val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) 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@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@2267: <\oguard\> ziv@2267: Sql.parse Sql.query queryText ziv@2266: <\obind\> ziv@2267: (fn queryParsed => ziv@2267: (cacheWrap (env, queryExp, resultTyp, args, index)) ziv@2266: <\obind\> ziv@2267: (fn cachedExp => ziv@2267: SOME (cachedExp, ziv@2267: (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) ziv@2267: tableToIndices ziv@2267: (tablesQuery queryParsed), ziv@2267: IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), ziv@2267: index + 1)))) ziv@2266: in ziv@2266: case attempt of ziv@2266: SOME pair => pair ziv@2266: (* Even in this case, we have to increment index to avoid some bug, ziv@2266: but I forget exactly what it is or why this helps. *) ziv@2266: (* TODO: just use a reference for current index.... *) ziv@2266: | NONE => (EQuery q, incIndex state) ziv@2266: end ziv@2266: ziv@2266: fun cachePure (env, exp', (_, _, index)) = ziv@2267: case (expSize (exp', dummyLoc) > sizeWorthCaching) ziv@2267: ziv@2267: typOfExp' env exp' of ziv@2256: NONE => NONE ziv@2256: | SOME (TFun _, _) => NONE ziv@2256: | SOME typ => ziv@2267: (List.foldr (fn (_, NONE) => NONE ziv@2267: | ((n, typ), SOME args) => ziv@2267: (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) ziv@2267: ziv@2267: (fn arg => SOME (arg :: args))) ziv@2267: (SOME []) ziv@2267: (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) ziv@2267: (freeVars (exp', dummyLoc)))) ziv@2266: ziv@2266: (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, index)) ziv@2250: ziv@2266: fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) : subexp * state = ziv@2250: let ziv@2250: fun wrapBindN f (args : (MonoEnv.env * exp) list) = ziv@2250: let ziv@2266: val (subexps, state) = ListUtil.foldlMap (cache effs) state args ziv@2256: fun mkExp () = (f (map expOfSubexp subexps), loc) ziv@2250: in ziv@2250: if List.exists isImpure subexps ziv@2266: then (Impure (mkExp ()), state) ziv@2267: else (Cachable (fn () => case cachePure (env, f (map #2 args), state) of ziv@2267: NONE => mkExp () ziv@2267: | SOME e' => (e', loc)), ziv@2256: (* Conservatively increment index. *) ziv@2266: incIndex 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@2250: fun wrapN f es = wrapBindN f (map (fn e => (env, e)) es) ziv@2250: fun wrap1 f e = wrapBind1 f (env, e) ziv@2250: fun wrap2 f (e1, e2) = wrapBind2 f ((env, e1), (env, e2)) 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@2250: (MonoEnv.pushERel env s t1 NONE, e) 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@2250: ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) 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@2250: ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2)) ziv@2250: (* ASK: | EClosure (n, es) => ? *) ziv@2250: | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e ziv@2266: | EQuery q => ziv@2266: let ziv@2266: val (exp', state) = cacheQuery effs env state q ziv@2266: in ziv@2266: (Impure (exp', loc), state) ziv@2266: end ziv@2250: | _ => if effectful effs env exp ziv@2266: then (Impure exp, state) ziv@2267: else (Cachable (fn () => (case cachePure (env, exp', state) of ziv@2267: NONE => exp' ziv@2267: | SOME e' => e', ziv@2267: loc)), ziv@2266: incIndex state) ziv@2256: end ziv@2256: ziv@2266: fun addCaching file = ziv@2256: let ziv@2266: val effs = effectfulDecls file ziv@2266: fun doTopLevelExp env exp state = ziv@2256: let ziv@2266: val (subexp, state) = cache effs ((env, exp), state) ziv@2256: in ziv@2266: (expOfSubexp subexp, state) ziv@2256: end ziv@2256: in ziv@2266: ((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, 0)), 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@2265: let ziv@2265: fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) ziv@2265: in ziv@2265: inv (numArgs - 1) ziv@2265: end 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@2265: fun invalidations ((query, numArgs), dml) = ziv@2265: (map (map optionAtomExpToExp) ziv@2265: o removeRedundant madeRedundantBy ziv@2265: o map (eqsToInvalidation numArgs) ziv@2265: o eqss) ziv@2265: (query, dml) 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@2265: fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, 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@2265: SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of ziv@2265: SOME queryNumArgs => ziv@2265: (* DEBUG *) ziv@2265: ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) ziv@2265: (i, invalidations (queryNumArgs, dmlParsed))) ziv@2265: (* TODO: fail more gracefully. *) ziv@2265: | NONE => raise Match)) ziv@2265: (SIMM.findList (tableToIndices, tableDml 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@2266: fileMap doExp file ziv@2265: end ziv@2265: ziv@2265: ziv@2265: (***************) ziv@2265: (* Entry point *) ziv@2265: (***************) 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