ziv@2203: structure SqlCache = struct
ziv@2203: 
ziv@2203: open Sql
ziv@2203: open Mono
ziv@2203: 
ziv@2203: structure IS = IntBinarySet
ziv@2203: structure IM = IntBinaryMap
ziv@2203: structure StringKey = struct type ord_key = string val compare = String.compare end
ziv@2203: structure SS = BinarySetFn (StringKey)
ziv@2203: structure SM = BinaryMapFn (StringKey)
ziv@2203: structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
ziv@2203: 
ziv@2204: val ffiIndices : int list ref = ref []
ziv@2204: val rs : int list ref = ref []
ziv@2204: val ws : int list ref = ref []
ziv@2204: 
ziv@2203: val rec tablesRead =
ziv@2203:  fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2203:   | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
ziv@2203: 
ziv@2203: val tableWritten =
ziv@2203:  fn Insert (tab, _) => tab
ziv@2203:   | Delete (tab, _) => tab
ziv@2203:   | Update (tab, _, _) => tab
ziv@2203: 
ziv@2203: fun tablesInExp' exp' =
ziv@2203:     let
ziv@2203:         val nothing = {read = SS.empty, written = SS.empty}
ziv@2203:     in
ziv@2203:         case exp' of
ziv@2203:             EQuery {query=e, ...} =>
ziv@2203:             (case parse query e of
ziv@2203:                  SOME q => {read = tablesRead q, written = SS.empty}
ziv@2203:                | NONE => nothing)
ziv@2203:           | EDml (e, _) =>
ziv@2203:             (case parse dml e of
ziv@2203:                  SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)}
ziv@2203:                | NONE => nothing)
ziv@2203:           | _ => nothing
ziv@2203:     end
ziv@2203: 
ziv@2203: val tablesInExp =
ziv@2203:     let
ziv@2203:         fun addTables (exp', {read, written}) =
ziv@2203:             let val {read = r, written = w} = tablesInExp' exp'
ziv@2203:             in {read = SS.union (r, read), written = SS.union (w, written)} end
ziv@2203:     in
ziv@2203:         MonoUtil.Exp.fold {typ = #2, exp = addTables}
ziv@2203:                           {read = SS.empty, written = SS.empty}
ziv@2203:     end
ziv@2203: 
ziv@2203: fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
ziv@2203: fun intTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2203: fun boolPat (b, loc) = (PCon (Enum,
ziv@2203:                               PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
ziv@2203:                                        con = if b then "True" else "False"},
ziv@2203:                               NONE),
ziv@2203:                         loc)
ziv@2203: fun boolTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2203: 
ziv@2204: fun ffiAppExp (module, func, index, loc) =
ziv@2204:     (EFfiApp (module, func ^ Int.toString index, []), loc)
ziv@2203: 
ziv@2203: fun sequence (befores, center, afters, loc) =
ziv@2203:     List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc))
ziv@2203:                (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc))
ziv@2203:                            center
ziv@2203:                            afters)
ziv@2203:                befores
ziv@2203: 
ziv@2203: fun antiguardUnit (cond, exp, loc) =
ziv@2203:     (ECase (cond,
ziv@2203:             [(boolPat (false, loc), exp),
ziv@2203:              (boolPat (true, loc), (ERecord [], loc))],
ziv@2203:             {disc = boolTyp loc, result = (TRecord [], loc)}),
ziv@2203:      loc)
ziv@2203: 
ziv@2203: fun underAbs f (exp as (exp', loc)) =
ziv@2203:     case exp' of
ziv@2203:         EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
ziv@2203:       | _ => f exp
ziv@2203: 
ziv@2203: fun addCacheCheck (index, exp) =
ziv@2203:     let
ziv@2203:         fun f (body as (_, loc)) =
ziv@2203:             let
ziv@2203:                 val check = ffiAppExp ("Cache", "check", index, loc)
ziv@2203:                 val store = ffiAppExp ("Cache", "store", index, loc)
ziv@2203:             in
ziv@2203:                 antiguardUnit (check, sequence ([], body, [store], loc), loc)
ziv@2203:             end
ziv@2203:     in
ziv@2203:         underAbs f exp
ziv@2203:     end
ziv@2203: 
ziv@2203: fun addCacheFlush (exp, tablesToIndices) =
ziv@2203:     let
ziv@2203:         fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table))
ziv@2203:         fun f (body as (_, loc)) =
ziv@2203:             let
ziv@2203:                 fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
ziv@2203:                 val flushes =
ziv@2203:                     IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
ziv@2203: 
ziv@2203:             in
ziv@2203:                 sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc)
ziv@2203:             end
ziv@2203:     in
ziv@2203:         underAbs f exp
ziv@2203:     end
ziv@2203: 
ziv@2203: val handlerIndices =
ziv@2203:     let
ziv@2203:         val isUnit =
ziv@2203:          fn (TRecord [], _) => true
ziv@2203:           | _ => false
ziv@2203:         fun maybeAdd (d, soFar as {readers, writers}) =
ziv@2203:             case d of
ziv@2203:                 DExport (Link ReadOnly, _, name, typs, typ, _) =>
ziv@2203:                 if List.all isUnit (typ::typs)
ziv@2203:                 then {readers = IS.add (readers, name), writers = writers}
ziv@2203:                 else soFar
ziv@2203:               | DExport (_, _, name, _, _, _) => (* Not read only. *)
ziv@2203:                 {readers = readers, writers = IS.add (writers, name)}
ziv@2203:               | _ => soFar
ziv@2203:     in
ziv@2203:         MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd}
ziv@2203:                            {readers = IS.empty, writers = IS.empty}
ziv@2203:     end
ziv@2203: 
ziv@2203: fun fileFoldMapiSelected f init (file, indices) =
ziv@2203:     let
ziv@2203:         fun doExp (original as ((a, index, b, exp, c), state)) =
ziv@2203:             if IS.member (indices, index)
ziv@2203:             then let val (newExp, newState) = f (index, exp, state)
ziv@2203:                  in ((a, index, b, newExp, c), newState) end
ziv@2203:             else original
ziv@2203:         fun doDecl decl state =
ziv@2203:             let
ziv@2203:                 val result =
ziv@2203:                     case decl of
ziv@2203:                         DVal x =>
ziv@2203:                         let val (y, newState) = doExp (x, state)
ziv@2203:                         in (DVal y, newState) end
ziv@2203:                       | DValRec xs =>
ziv@2203:                         let val (ys, newState) = ListUtil.foldlMap doExp state xs
ziv@2203:                         in (DValRec ys, newState) end
ziv@2203:                       | _ => (decl, state)
ziv@2203:             in
ziv@2203:                 Search.Continue result
ziv@2203:             end
ziv@2203:         fun nada x y = Search.Continue (x, y)
ziv@2203:     in
ziv@2203:         case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
ziv@2203:             Search.Continue x => x
ziv@2203:           | _ => (file, init) (* Should never happen. *)
ziv@2203:     end
ziv@2203: 
ziv@2203: fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
ziv@2203: 
ziv@2203: val addCacheChecking =
ziv@2203:     let
ziv@2203:         fun f (index, exp, tablesToIndices) =
ziv@2203:             (addCacheCheck (index, exp),
ziv@2203:              SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index))
ziv@2203:                       tablesToIndices
ziv@2203:                       (#read (tablesInExp exp)))
ziv@2203:     in
ziv@2203:         fileFoldMapiSelected f (SM.empty)
ziv@2203:     end
ziv@2203: 
ziv@2203: fun addCacheFlushing (file, tablesToIndices, writers) =
ziv@2203:     fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers)
ziv@2203: 
ziv@2203: fun go file =
ziv@2203:     let
ziv@2203:         val {readers, writers} = handlerIndices file
ziv@2203:         val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
ziv@2203:     in
ziv@2204:         rs := IS.listItems readers;
ziv@2204:         ws := IS.listItems writers;
ziv@2204:         ffiIndices := IS.listItems readers;
ziv@2203:         addCacheFlushing (fileWithChecks, tablesToIndices, writers)
ziv@2203:     end
ziv@2203: 
ziv@2203: end