Mercurial > urweb

annotate src/sqlcache.sml @ 2209:0ca11d57c175

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