Mercurial > urweb

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