Mercurial > urweb

annotate src/sql_cache.sml @ 2208:cb74460f046a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Fri, 30 May 2014 12:00:44 -0400
parents 01c8aceac480
children
rev   line source
ziv@2203 1 structure SqlCache = struct
ziv@2203 2
ziv@2203 3 open Sql
ziv@2203 4 open Mono
ziv@2203 5
ziv@2203 6 structure IS = IntBinarySet
ziv@2203 7 structure IM = IntBinaryMap
ziv@2203 8 structure StringKey = struct type ord_key = string val compare = String.compare end
ziv@2203 9 structure SS = BinarySetFn (StringKey)
ziv@2203 10 structure SM = BinaryMapFn (StringKey)
ziv@2203 11 structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
ziv@2203 12
ziv@2204 13 val ffiIndices : int list ref = ref []
ziv@2204 14 val rs : int list ref = ref []
ziv@2204 15 val ws : int list ref = ref []
ziv@2204 16
ziv@2203 17 val rec tablesRead =
ziv@2203 18 fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2203 19 | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
ziv@2203 20
ziv@2203 21 val tableWritten =
ziv@2203 22 fn Insert (tab, _) => tab
ziv@2203 23 | Delete (tab, _) => tab
ziv@2203 24 | Update (tab, _, _) => tab
ziv@2203 25
ziv@2203 26 fun tablesInExp' exp' =
ziv@2203 27 let
ziv@2203 28 val nothing = {read = SS.empty, written = SS.empty}
ziv@2203 29 in
ziv@2203 30 case exp' of
ziv@2203 31 EQuery {query=e, ...} =>
ziv@2203 32 (case parse query e of
ziv@2203 33 SOME q => {read = tablesRead q, written = SS.empty}
ziv@2203 34 | NONE => nothing)
ziv@2203 35 | EDml (e, _) =>
ziv@2203 36 (case parse dml e of
ziv@2203 37 SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)}
ziv@2203 38 | NONE => nothing)
ziv@2203 39 | _ => nothing
ziv@2203 40 end
ziv@2203 41
ziv@2203 42 val tablesInExp =
ziv@2203 43 let
ziv@2203 44 fun addTables (exp', {read, written}) =
ziv@2203 45 let val {read = r, written = w} = tablesInExp' exp'
ziv@2203 46 in {read = SS.union (r, read), written = SS.union (w, written)} end
ziv@2203 47 in
ziv@2203 48 MonoUtil.Exp.fold {typ = #2, exp = addTables}
ziv@2203 49 {read = SS.empty, written = SS.empty}
ziv@2203 50 end
ziv@2203 51
ziv@2203 52 fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
ziv@2203 53 fun intTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2203 54 fun boolPat (b, loc) = (PCon (Enum,
ziv@2203 55 PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
ziv@2203 56 con = if b then "True" else "False"},
ziv@2203 57 NONE),
ziv@2203 58 loc)
ziv@2203 59 fun boolTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2203 60
ziv@2204 61 fun ffiAppExp (module, func, index, loc) =
ziv@2204 62 (EFfiApp (module, func ^ Int.toString index, []), loc)
ziv@2203 63
ziv@2203 64 fun sequence (befores, center, afters, loc) =
ziv@2203 65 List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc))
ziv@2203 66 (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc))
ziv@2203 67 center
ziv@2203 68 afters)
ziv@2203 69 befores
ziv@2203 70
ziv@2203 71 fun antiguardUnit (cond, exp, loc) =
ziv@2203 72 (ECase (cond,
ziv@2203 73 [(boolPat (false, loc), exp),
ziv@2203 74 (boolPat (true, loc), (ERecord [], loc))],
ziv@2203 75 {disc = boolTyp loc, result = (TRecord [], loc)}),
ziv@2203 76 loc)
ziv@2203 77
ziv@2203 78 fun underAbs f (exp as (exp', loc)) =
ziv@2203 79 case exp' of
ziv@2203 80 EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
ziv@2203 81 | _ => f exp
ziv@2203 82
ziv@2203 83 fun addCacheCheck (index, exp) =
ziv@2203 84 let
ziv@2203 85 fun f (body as (_, loc)) =
ziv@2203 86 let
ziv@2203 87 val check = ffiAppExp ("Cache", "check", index, loc)
ziv@2203 88 val store = ffiAppExp ("Cache", "store", index, loc)
ziv@2203 89 in
ziv@2203 90 antiguardUnit (check, sequence ([], body, [store], loc), loc)
ziv@2203 91 end
ziv@2203 92 in
ziv@2203 93 underAbs f exp
ziv@2203 94 end
ziv@2203 95
ziv@2203 96 fun addCacheFlush (exp, tablesToIndices) =
ziv@2203 97 let
ziv@2203 98 fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table))
ziv@2203 99 fun f (body as (_, loc)) =
ziv@2203 100 let
ziv@2203 101 fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
ziv@2203 102 val flushes =
ziv@2203 103 IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
ziv@2203 104
ziv@2203 105 in
ziv@2203 106 sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc)
ziv@2203 107 end
ziv@2203 108 in
ziv@2203 109 underAbs f exp
ziv@2203 110 end
ziv@2203 111
ziv@2203 112 val handlerIndices =
ziv@2203 113 let
ziv@2203 114 val isUnit =
ziv@2203 115 fn (TRecord [], _) => true
ziv@2203 116 | _ => false
ziv@2203 117 fun maybeAdd (d, soFar as {readers, writers}) =
ziv@2203 118 case d of
ziv@2203 119 DExport (Link ReadOnly, _, name, typs, typ, _) =>
ziv@2203 120 if List.all isUnit (typ::typs)
ziv@2203 121 then {readers = IS.add (readers, name), writers = writers}
ziv@2203 122 else soFar
ziv@2203 123 | DExport (_, _, name, _, _, _) => (* Not read only. *)
ziv@2203 124 {readers = readers, writers = IS.add (writers, name)}
ziv@2203 125 | _ => soFar
ziv@2203 126 in
ziv@2203 127 MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd}
ziv@2203 128 {readers = IS.empty, writers = IS.empty}
ziv@2203 129 end
ziv@2203 130
ziv@2203 131 fun fileFoldMapiSelected f init (file, indices) =
ziv@2203 132 let
ziv@2203 133 fun doExp (original as ((a, index, b, exp, c), state)) =
ziv@2203 134 if IS.member (indices, index)
ziv@2203 135 then let val (newExp, newState) = f (index, exp, state)
ziv@2203 136 in ((a, index, b, newExp, c), newState) end
ziv@2203 137 else original
ziv@2203 138 fun doDecl decl state =
ziv@2203 139 let
ziv@2203 140 val result =
ziv@2203 141 case decl of
ziv@2203 142 DVal x =>
ziv@2203 143 let val (y, newState) = doExp (x, state)
ziv@2203 144 in (DVal y, newState) end
ziv@2203 145 | DValRec xs =>
ziv@2203 146 let val (ys, newState) = ListUtil.foldlMap doExp state xs
ziv@2203 147 in (DValRec ys, newState) end
ziv@2203 148 | _ => (decl, state)
ziv@2203 149 in
ziv@2203 150 Search.Continue result
ziv@2203 151 end
ziv@2203 152 fun nada x y = Search.Continue (x, y)
ziv@2203 153 in
ziv@2203 154 case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
ziv@2203 155 Search.Continue x => x
ziv@2203 156 | _ => (file, init) (* Should never happen. *)
ziv@2203 157 end
ziv@2203 158
ziv@2203 159 fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
ziv@2203 160
ziv@2203 161 val addCacheChecking =
ziv@2203 162 let
ziv@2203 163 fun f (index, exp, tablesToIndices) =
ziv@2203 164 (addCacheCheck (index, exp),
ziv@2203 165 SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index))
ziv@2203 166 tablesToIndices
ziv@2203 167 (#read (tablesInExp exp)))
ziv@2203 168 in
ziv@2203 169 fileFoldMapiSelected f (SM.empty)
ziv@2203 170 end
ziv@2203 171
ziv@2203 172 fun addCacheFlushing (file, tablesToIndices, writers) =
ziv@2203 173 fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers)
ziv@2203 174
ziv@2203 175 fun go file =
ziv@2203 176 let
ziv@2203 177 val {readers, writers} = handlerIndices file
ziv@2203 178 val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
ziv@2203 179 in
ziv@2204 180 rs := IS.listItems readers;
ziv@2204 181 ws := IS.listItems writers;
ziv@2204 182 ffiIndices := IS.listItems readers;
ziv@2203 183 addCacheFlushing (fileWithChecks, tablesToIndices, writers)
ziv@2203 184 end
ziv@2203 185
ziv@2203 186 end