Mercurial > urweb

comparison src/sql_cache.sml @ 2203:39faa4a037f4

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