Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2216:70ec9bb337be

Progress towards invalidation based on equalities of fields.

author	Ziv Scully <ziv@mit.edu>
date	Mon, 10 Nov 2014 22:04:40 -0500
parents	639e62ca2530
children	f7113855f3b7

comparison

equal deleted inserted replaced

-:639e62ca2530
+:70ec9bb337be
 structure Sqlcache (* :> SQLCACHE *) = struct
-open Sql
 open Mono
 structure IS = IntBinarySet
 structure IM = IntBinaryMap
 structure SK = struct type ord_key = string val compare = String.compare end
 structure SS = BinarySetFn(SK)
 structure SM = BinaryMapFn(SK)
 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
-(* Filled in by cacheWrap during Sqlcache. *)
+(* Filled in by [cacheWrap] during [Sqlcache]. *)
 val ffiInfo : {index : int, params : int} list ref = ref []
 fun getFfiInfo () = !ffiInfo
 (* Some FFIs have writing as their only effect, which the caching records. *)
 val ffiEffectful =
+(* TODO: have this less hard-coded. *)
 let
 val fs = SS.fromList ["htmlifyInt_w",
 "htmlifyFloat_w",
 "htmlifyString_w",
 "htmlifyBool_w",
 end
 (* Effect analysis. *)
-(* Makes an exception for EWrite (which is recorded when caching). *)
+(* Makes an exception for [EWrite] (which is recorded when caching). *)
 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
 (* If result is true, expression is definitely effectful. If result is
 false, then expression is definitely not effectful if effs is fully
 populated. The intended pattern is to use this a number of times equal
 to the number of declarations in a file, Bellman-Ford style. *)
 | ENamed name => if IS.member (effs, name) then tru "named" else false
 | ECon (_, _, NONE) => false
 | ECon (_, _, SOME e) => eff e
 | ENone _ => false
 | ESome (_, e) => eff e
-(* TODO: use FFI whitelist. *)
 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
 (* ASK: we're calling functions effectful if they have effects when
 applied or if the function expressions themselves have effects.
 Is that okay? *)
 in
 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
 end
+(* Boolean formula normalization. *)
+datatype normalForm = Cnf | Dnf
+datatype 'atom formula =
+Atom of 'atom
+| Negate of 'atom formula
+| Combo of normalForm * 'atom formula list
+val flipNf = fn Cnf => Dnf | Dnf => Cnf
+fun bind xs f = List.concat (map f xs)
+val rec cartesianProduct : 'a list list -> 'a list list =
+fn [] => [[]]
+| (xs :: xss) => bind (cartesianProduct xss)
+(fn ys => bind xs (fn x => [x :: ys]))
+fun normalize (negate : 'atom -> 'atom) (norm : normalForm) =
+fn Atom x => [[x]]
+| Negate f => map (map negate) (normalize negate (flipNf norm) f)
+| Combo (n, fs) =>
+let
+val fss = bind fs (normalize negate n)
+in
+if n = norm then fss else cartesianProduct fss
+end
+fun mapFormula mf =
+fn Atom x => Atom (mf x)
+| Negate f => Negate (mapFormula mf f)
+| Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
 (* SQL analysis. *)
-val useInjIfPossible =
+val rec chooseTwos : 'a list -> ('a * 'a) list =
-fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)),
+fn [] => []
-ErrorMsg.dummySpan)
+| x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
-| sqexp => sqexp
+datatype atomExp =
-fun equalities (canonicalTable : string -> string) :
+QueryArg of int
-sqexp -> ((string * string) * Mono.exp) list option =
+| DmlRel of int
-let
+| Prim of Prim.t
-val rec eqs =
+| Field of string * string
-fn Binop (Exps f, e1, e2) =>
-(* TODO: use a custom datatype in Exps instead of a function. *)
+structure AtomExpKey : ORD_KEY = struct
-(case f (Var 1, Var 2) of
-Reln (Eq, [Var 1, Var 2]) =>
+type ord_key = atomExp
-let
-val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2)
+val compare =
-in
+fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
-case (e1', e2') of
+| (QueryArg _, _) => LESS
-(Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)]
+| (_, QueryArg _) => GREATER
-| (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)]
+| (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
-| _ => NONE
+| (DmlRel _, _) => LESS
-end
+| (_, DmlRel _) => GREATER
+| (Prim p1, Prim p2) => Prim.compare (p1, p2)
+| (Prim _, _) => LESS
+| (_, Prim _) => GREATER
+| (Field (t1, f1), Field (t2, f2)) => String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2)
+end
+structure UF = UnionFindFn(AtomExpKey)
+fun conflictMaps (fQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula,
+fDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula) =
+let
+val toKnownEquality =
+(* [NONE] here means unkown. Anything that isn't a comparison between
+two knowns shouldn't be used, and simply dropping unused terms is
+okay in disjunctive normal form. *)
+fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
+| _ => NONE
+val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list =
+UF.classes
+o List.foldl UF.union' UF.empty
+o List.mapPartial toKnownEquality
+fun addToEqs (eqs, n, e) =
+case IM.find (eqs, n) of
+(* Comparing to a constant seems better? *)
+SOME (EPrim _) => eqs
+| _ => IM.insert (eqs, n, e)
+val accumulateEqs =
+(* [NONE] means we have a contradiction. *)
+fn (_, NONE) => NONE
+| ((Prim p1, Prim p2), eqso) =>
+(case Prim.compare (p1, p2) of
+EQUAL => eqso
 | _ => NONE)
-| Binop (Props f, e1, e2) =>
+| ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, EPrim p))
-(* TODO: use a custom datatype in Props instead of a function. *)
+| ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, ERel r))
-(case f (True, False) of
+| ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, EPrim p))
-And (True, False) =>
+| ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, ERel r))
-(case (eqs e1, eqs e2) of
+(* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. *)
-(SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2)
+| (_, eqso) => eqso
-| _ => NONE)
+val eqsOfClass : atomExp list -> Mono.exp' IM.map option =
-| _ => NONE)
+List.foldl accumulateEqs (SOME IM.empty)
-| _ => NONE
+o chooseTwos
-in
+fun toAtomExps rel (cmp, e1, e2) =
-eqs
+let
-end
+val qa =
+(* Here [NONE] means unkown. *)
-val equalitiesQuery =
+fn Sql.SqConst p => SOME (Prim p)
-fn Query1 {From = tablePairs, Where = SOME exp, ...} =>
+| Sql.Field tf => SOME (Field tf)
-equalities
+| Sql.Inj (EPrim p, _) => SOME (Prim p)
-(* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *)
+| Sql.Inj (ERel n, _) => SOME (rel n)
-(fn t =>
+(* We can't deal with anything else. *)
-case List.find (fn (_, tAs) => t = tAs) tablePairs of
+| _ => NONE
-NONE => t
+in
-| SOME (tOrig, _) => tOrig)
+(cmp, qa e1, qa e2)
-exp
+end
-| Query1 {Where = NONE, ...} => SOME []
+fun negateCmp (cmp, e1, e2) =
-| _ => NONE
+(case cmp of
+Sql.Eq => Sql.Ne
-val equalitiesDml =
+| Sql.Ne => Sql.Eq
-fn Insert (tab, eqs) => SOME (List.mapPartial
+| Sql.Lt => Sql.Ge
-(fn (name, sqexp) =>
+| Sql.Le => Sql.Gt
-case useInjIfPossible sqexp of
+| Sql.Gt => Sql.Le
-Inj e => SOME ((tab, name), e)
+| Sql.Ge => Sql.Lt,
-| _ => NONE)
+e1, e2)
-eqs)
+val markQuery = mapFormula (toAtomExps QueryArg)
-| Delete (tab, exp) => equalities (fn _ => tab) exp
+val markDml = mapFormula (toAtomExps DmlRel)
-(* TODO: examine the updated values and not just the way they're filtered. *)
+val dnf = normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml]))
-(* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the
+(* If one of the terms in a conjunction leads to a contradiction, which
-Id = 42 and Id = 9001 cache entries. Could also think of it as doing a
+is represented by [NONE], drop the entire conjunction. *)
-Delete immediately followed by an Insert. *)
+val sequenceOption = List.foldr (fn (SOME x, SOME xs) => SOME (x :: xs) | _ => NONE)
-| Update (tab, _, exp) => equalities (fn _ => tab) exp
+(SOME [])
+in
+List.mapPartial (sequenceOption o map eqsOfClass o equivClasses) dnf
+end
+val rec sqexpToFormula =
+fn Sql.SqTrue => Combo (Cnf, [])
+| Sql.SqFalse => Combo (Dnf, [])
+| Sql.SqNot e => Negate (sqexpToFormula e)
+| Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
+| Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Cnf | Sql.Or => Dnf,
+[sqexpToFormula p1, sqexpToFormula p2])
+(* ASK: any other sqexps that can be props? *)
+| _ => raise Match
+val rec queryToFormula =
+fn Sql.Query1 {From = tablePairs, Where = NONE, ...} => Combo (Cnf, [])
+| Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
+let
+fun renameString table =
+case List.find (fn (_, t) => table = t) tablePairs of
+NONE => table
+| SOME (realTable, _) => realTable
+val renameSqexp =
+fn Sql.Field (table, field) => Sql.Field (renameString table, field)
+| e => e
+fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2)
+in
+mapFormula renameAtom (sqexpToFormula e)
+end
+| Sql.Union (q1, q2) => Combo (Dnf, [queryToFormula q1, queryToFormula q2])
+val rec dmlToFormula =
+fn Sql.Insert (table, vals) =>
+Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
+| Sql.Delete (_, wher) => sqexpToFormula wher
+(* TODO: refine formula for the vals part, which could take into account the wher part. *)
+| Sql.Update (table, vals, wher) => Combo (Dnf, [dmlToFormula (Sql.Insert (table, vals)),
+dmlToFormula (Sql.Delete (table, wher))])
 val rec tablesQuery =
-fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
-| Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
+| Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
 val tableDml =
-fn Insert (tab, _) => tab
+fn Sql.Insert (tab, _) => tab
-| Delete (tab, _) => tab
+| Sql.Delete (tab, _) => tab
-| Update (tab, _, _) => tab
+| Sql.Update (tab, _, _) => tab
 (* Program instrumentation. *)
 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
 val sequence =
 fn (exp :: exps) =>
 let
 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
 bound
 val incRels = incRelsBound 0
-(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
+(* Filled in by instrumentQuery during [Monoize], used during [Sqlcache]. *)
 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
-(* Used by Monoize. *)
+(* Used by [Monoize]. *)
 val instrumentQuery =
 let
 val nextQuery = ref 0
 fun iq (query, urlifiedRel0) =
 case query of
 in
 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
 (ELet (varPrefix ^ Int.toString i, typ, query,
 (* Uses a dummy FFI call to keep the urlified expression around, which
 in turn keeps the declarations required for urlification safe from
-MonoShake. The dummy call is removed during Sqlcache. *)
+[MonoShake]. The dummy call is removed during [Sqlcache]. *)
-(* TODO: thread a Monoize.Fm.t through this module. *)
+(* TODO: thread a [Monoize.Fm.t] through this module. *)
-(ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
+(ESeq ((EFfiApp ("Sqlcache",
+"dummy",
+[(urlifiedRel0, stringTyp)]),
+loc),
 (ERel 0, loc)),
 loc)),
 loc)
 end
 | _ => raise Match
 in
 iq
 end
-fun cacheWrap (query, i, urlifiedRel0, eqs) =
+fun cacheWrap (query, i, urlifiedRel0, args) =
 case query of
 (EQuery {state = typ, ...}, _) =>
 let
-val () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo
+val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
 val loc = ErrorMsg.dummySpan
 (* We ensure before this step that all arguments aren't effectful.
 by turning them into local variables as needed. *)
-val args = map (fn (_, e) => (e, stringTyp)) eqs
+val argTyps = map (fn e => (e, stringTyp)) args
-val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args
+val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps
-val check = ffiAppCache ("check", i, args)
+val check = ffiAppCache ("check", i, argTyps)
-val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc)
+val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc)
 val rel0 = (ERel 0, loc)
 in
 (ECase (check,
 [((PNone stringTyp, loc),
 (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)),
 queryExp' as (EQuery {query = origQueryText,
 initial, body, state, tables, exps}, queryLoc),
 letBody) =>
 let
 val loc = ErrorMsg.dummySpan
-val chunks = chunkify origQueryText
+val chunks = Sql.chunkify origQueryText
 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
 val (newQueryText, 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
-Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
-| Exp (e as (ERel _, _)) => (strcat (e, qText), newVars)
+| Sql.Exp e =>
-| Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars)
-(* Head of newVars has lowest index. *)
-| 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
-| String s => (strcat (stringExp s, qText), newVars))
+| 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 ("sqlArgz", stringTyp, v, (e', loc))) e' newVariables
+List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc)))
+e'
+newVariables
+val numArgs = length newVariables
 (* Increment once for each new variable just made. *)
 val queryExp = incRels (length newVariables)
 (EQuery {query = newQueryText,
 initial = initial,
 body = body,
 tables = tables,
 exps = exps},
 queryLoc)
 val (EQuery {query = queryText, ...}, _) = queryExp
 (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *)
+val args = List.tabulate (numArgs, fn n => (ERel n, loc))
 fun bind x f = Option.mapPartial f x
 fun guard b x = if b then x else NONE
 (* DEBUG: set first boolean argument to true to turn on printing. *)
 fun safe bound = not o effectful true (effectfulMap file) false bound
 val attempt =
 (* Ziv misses Haskell's do notation.... *)
 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
-bind (parse query queryText) (fn queryParsed =>
+bind (Sql.parse Sql.query queryText) (fn queryParsed =>
 bind (indexOfName v) (fn i =>
-bind (equalitiesQuery queryParsed) (fn eqs =>
 bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
 SOME (wrapLets (ELet (v, t,
-cacheWrap (queryExp, i, urlifiedRel0, eqs),
+cacheWrap (queryExp, i, urlifiedRel0, args),
 incRelsBound 1 (length newVariables) letBody)),
 SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
 queryInfo
-(tablesQuery queryParsed)))))))
+(tablesQuery queryParsed))))))
 in
 case attempt of
 SOME pair => pair
 | NONE => (e', queryInfo)
 end
 | e' => (e', queryInfo)
 in
 fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
 end
+fun invalidations (nQueryArgs, query, dml) =
+let
+val loc = ErrorMsg.dummySpan
+val optionToExp =
+fn NONE => (ENone stringTyp, loc)
+| SOME e => (ESome (stringTyp, (e, loc)), loc)
+fun eqsToInvalidation eqs =
+let
+fun inv n = if n < 0 then [] else optionToExp (IM.find (eqs, n)) :: inv (n - 1)
+in
+inv (nQueryArgs - 1)
+end
+in
+map (map eqsToInvalidation) (conflictMaps (queryToFormula query, dmlToFormula dml))
+end
 fun addFlushing (file, queryInfo) =
 let
 val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
 fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices
 val doExp =
 fn dmlExp as EDml (dmlText, _) =>
 let
 val indices =
-case parse dml dmlText of
+case Sql.parse Sql.dml dmlText of
 SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed)
 | NONE => allIndices
 in
 sequence (flushes indices @ [dmlExp])
 end
 val () = Sql.sqlcacheMode := false
 in
 file'
 end
-(* BEGIN OLD
-fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
-fun intTyp loc = (TFfi ("Basis", "int"), loc)
-fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc)
-fun boolPat (b, loc) = (PCon (Enum,
-PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
-con = if b then "True" else "False"},
-NONE),
-loc)
-fun boolTyp loc = (TFfi ("Basis", "int"), loc)
-fun ffiAppExp (module, func, index, args, loc) =
-(EFfiApp (module, func ^ Int.toString index, args), loc)
-val sequence =
-fn ((exp :: exps), loc) =>
-List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
-| _ => raise Match
-fun antiguardUnit (cond, exp, loc) =
-(ECase (cond,
-[(boolPat (false, loc), exp),
-(boolPat (true, loc), (ERecord [], loc))],
-{disc = boolTyp loc, result = (TRecord [], loc)}),
-loc)
-fun underAbs f (exp as (exp', loc)) =
-case exp' of
-EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
-| _ => f exp
-val rec tablesRead =
-fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
-| Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2)
-val tableWritten =
-fn Insert (tab, _) => tab
-| Delete (tab, _) => tab
-| Update (tab, _, _) => tab
-fun tablesInExp' exp' =
-let
-val nothing = {read = SS.empty, written = SS.empty}
-in
-case exp' of
-EQuery {query = e, ...} =>
-(case parse query e of
-SOME q => {read = tablesRead q, written = SS.empty}
-| NONE => nothing)
-| EDml (e, _) =>
-(case parse dml e of
-SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)}
-| NONE => nothing)
-| _ => nothing
-end
-val tablesInExp =
-let
-fun addTables (exp', {read, written}) =
-let
-val {read = r, written = w} = tablesInExp' exp'
-in
-{read = SS.union (r, read), written = SS.union (w, written)}
-end
-in
-MonoUtil.Exp.fold {typ = #2, exp = addTables}
-{read = SS.empty, written = SS.empty}
-end
-fun addCacheCheck (index, exp) =
-let
-fun f (body as (_, loc)) =
-let
-val check = ffiAppExp ("Cache", "check", index, loc)
-val store = ffiAppExp ("Cache", "store", index, loc)
-in
-antiguardUnit (check, sequence ([body, store], loc), loc)
-end
-in
-underAbs f exp
-end
-fun addCacheFlush (exp, tablesToIndices) =
-let
-fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table))
-fun f (body as (_, loc)) =
-let
-fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
-val flushes =
-IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
-in
-sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc)
-end
-in
-underAbs f exp
-end
-val handlerIndices =
-let
-val isUnit =
-fn (TRecord [], _) => true
-| _ => false
-fun maybeAdd (d, soFar as {readers, writers}) =
-case d of
-DExport (Link ReadOnly, _, name, typs, typ, _) =>
-if List.all isUnit (typ::typs)
-then {readers = IS.add (readers, name), writers = writers}
-else soFar
-| DExport (_, _, name, _, _, _) => (* Not read only. *)
-{readers = readers, writers = IS.add (writers, name)}
-| _ => soFar
-in
-MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd}
-{readers = IS.empty, writers = IS.empty}
-end
-fun fileFoldMapiSelected f init (file, indices) =
-let
-fun doExp (original as ((a, index, b, exp, c), state)) =
-if IS.member (indices, index)
-then let val (newExp, newState) = f (index, exp, state)
-in ((a, index, b, newExp, c), newState) end
-else original
-fun doDecl decl state =
-let
-val result =
-case decl of
-DVal x =>
-let val (y, newState) = doExp (x, state)
-in (DVal y, newState) end
-| DValRec xs =>
-let val (ys, newState) = ListUtil.foldlMap doExp state xs
-in (DValRec ys, newState) end
-| _ => (decl, state)
-in
-Search.Continue result
-end
-fun nada x y = Search.Continue (x, y)
-in
-case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
-Search.Continue x => x
-| _ => raise Match (* Should never happen. *)
-end
-fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
-val addCacheChecking =
-let
-fun f (index, exp, tablesToIndices) =
-(addCacheCheck (index, exp),
-SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index))
-tablesToIndices
-(#read (tablesInExp exp)))
-in
-fileFoldMapiSelected f (SM.empty)
-end
-fun addCacheFlushing (file, tablesToIndices, writers) =
-fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers)
-fun go file =
-let
-val {readers, writers} = handlerIndices file
-val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
-in
-ffiIndices := IS.listItems readers;
-addCacheFlushing (fileWithChecks, tablesToIndices, writers)
-end
-END OLD *)
 end

Mercurial > urweb

comparison src/sqlcache.sml @ 2216:70ec9bb337be