ziv@2250
|
1 structure Sqlcache :> SQLCACHE = struct
|
ziv@2209
|
2
|
ziv@2209
|
3 open Mono
|
ziv@2209
|
4
|
ziv@2209
|
5 structure IS = IntBinarySet
|
ziv@2209
|
6 structure IM = IntBinaryMap
|
ziv@2213
|
7 structure SK = struct type ord_key = string val compare = String.compare end
|
ziv@2213
|
8 structure SS = BinarySetFn(SK)
|
ziv@2213
|
9 structure SM = BinaryMapFn(SK)
|
ziv@2213
|
10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
|
ziv@2209
|
11
|
ziv@2250
|
12 fun iterate f n x = if n < 0
|
ziv@2250
|
13 then raise Fail "Can't iterate function negative number of times."
|
ziv@2250
|
14 else if n = 0
|
ziv@2250
|
15 then x
|
ziv@2250
|
16 else iterate f (n-1) (f x)
|
ziv@2250
|
17
|
ziv@2265
|
18 (* Filled in by [cacheWrap]. *)
|
ziv@2213
|
19 val ffiInfo : {index : int, params : int} list ref = ref []
|
ziv@2209
|
20
|
ziv@2227
|
21 fun resetFfiInfo () = ffiInfo := []
|
ziv@2227
|
22
|
ziv@2213
|
23 fun getFfiInfo () = !ffiInfo
|
ziv@2213
|
24
|
ziv@2215
|
25 (* Some FFIs have writing as their only effect, which the caching records. *)
|
ziv@2215
|
26 val ffiEffectful =
|
ziv@2223
|
27 (* ASK: how can this be less hard-coded? *)
|
ziv@2215
|
28 let
|
ziv@2258
|
29 val okayWrites = SS.fromList ["htmlifyInt_w",
|
ziv@2258
|
30 "htmlifyFloat_w",
|
ziv@2258
|
31 "htmlifyString_w",
|
ziv@2258
|
32 "htmlifyBool_w",
|
ziv@2258
|
33 "htmlifyTime_w",
|
ziv@2258
|
34 "attrifyInt_w",
|
ziv@2258
|
35 "attrifyFloat_w",
|
ziv@2258
|
36 "attrifyString_w",
|
ziv@2258
|
37 "attrifyChar_w",
|
ziv@2258
|
38 "urlifyInt_w",
|
ziv@2258
|
39 "urlifyFloat_w",
|
ziv@2258
|
40 "urlifyString_w",
|
ziv@2258
|
41 "urlifyBool_w",
|
ziv@2258
|
42 "urlifyChannel_w"]
|
ziv@2215
|
43 in
|
ziv@2265
|
44 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
|
ziv@2215
|
45 fn (m, f) => Settings.isEffectful (m, f)
|
ziv@2258
|
46 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
|
ziv@2215
|
47 end
|
ziv@2215
|
48
|
ziv@2234
|
49 val cache = ref LruCache.cache
|
ziv@2233
|
50 fun setCache c = cache := c
|
ziv@2233
|
51 fun getCache () = !cache
|
ziv@2233
|
52
|
ziv@2248
|
53 (* Used to have type context for local variables in MonoUtil functions. *)
|
ziv@2248
|
54 val doBind =
|
ziv@2262
|
55 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
|
ziv@2262
|
56 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
|
ziv@2262
|
57 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
|
ziv@2215
|
58
|
ziv@2266
|
59 (***********************)
|
ziv@2266
|
60 (* General Combinators *)
|
ziv@2266
|
61 (***********************)
|
ziv@2266
|
62
|
ziv@2266
|
63 (* From the MLton wiki. *)
|
ziv@2266
|
64 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
|
ziv@2266
|
65 infix 3 \> fun f \> y = f y (* Left application *)
|
ziv@2266
|
66 infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *)
|
ziv@2266
|
67 infixr 3 </ fun x </ f = f x (* Right application *)
|
ziv@2266
|
68
|
ziv@2266
|
69 (* Option monad. *)
|
ziv@2266
|
70 fun obind (x, f) = Option.mapPartial f x
|
ziv@2266
|
71 fun oguard (b, x) = if b then x else NONE
|
ziv@2248
|
72
|
ziv@2248
|
73 (*******************)
|
ziv@2248
|
74 (* Effect Analysis *)
|
ziv@2248
|
75 (*******************)
|
ziv@2215
|
76
|
ziv@2216
|
77 (* Makes an exception for [EWrite] (which is recorded when caching). *)
|
ziv@2248
|
78 fun effectful (effs : IS.set) =
|
ziv@2215
|
79 let
|
ziv@2248
|
80 val isFunction =
|
ziv@2248
|
81 fn (TFun _, _) => true
|
ziv@2248
|
82 | _ => false
|
ziv@2250
|
83 fun doExp (env, e) =
|
ziv@2248
|
84 case e of
|
ziv@2248
|
85 EPrim _ => false
|
ziv@2248
|
86 (* For now: variables of function type might be effectful, but
|
ziv@2248
|
87 others are fully evaluated and are therefore not effectful. *)
|
ziv@2250
|
88 | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
|
ziv@2248
|
89 | ENamed n => IS.member (effs, n)
|
ziv@2248
|
90 | EFfi (m, f) => ffiEffectful (m, f)
|
ziv@2248
|
91 | EFfiApp (m, f, _) => ffiEffectful (m, f)
|
ziv@2248
|
92 (* These aren't effectful unless a subexpression is. *)
|
ziv@2248
|
93 | ECon _ => false
|
ziv@2248
|
94 | ENone _ => false
|
ziv@2248
|
95 | ESome _ => false
|
ziv@2248
|
96 | EApp _ => false
|
ziv@2248
|
97 | EAbs _ => false
|
ziv@2248
|
98 | EUnop _ => false
|
ziv@2248
|
99 | EBinop _ => false
|
ziv@2248
|
100 | ERecord _ => false
|
ziv@2248
|
101 | EField _ => false
|
ziv@2248
|
102 | ECase _ => false
|
ziv@2248
|
103 | EStrcat _ => false
|
ziv@2248
|
104 (* EWrite is a special exception because we record writes when caching. *)
|
ziv@2248
|
105 | EWrite _ => false
|
ziv@2248
|
106 | ESeq _ => false
|
ziv@2248
|
107 | ELet _ => false
|
ziv@2250
|
108 | EUnurlify _ => false
|
ziv@2248
|
109 (* ASK: what should we do about closures? *)
|
ziv@2248
|
110 (* Everything else is some sort of effect. We could flip this and
|
ziv@2248
|
111 explicitly list bits of Mono that are effectful, but this is
|
ziv@2248
|
112 conservatively robust to future changes (however unlikely). *)
|
ziv@2248
|
113 | _ => true
|
ziv@2215
|
114 in
|
ziv@2248
|
115 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind}
|
ziv@2215
|
116 end
|
ziv@2215
|
117
|
ziv@2215
|
118 (* TODO: test this. *)
|
ziv@2252
|
119 fun effectfulDecls (decls, _) =
|
ziv@2215
|
120 let
|
ziv@2248
|
121 fun doVal ((_, name, _, e, _), effs) =
|
ziv@2250
|
122 if effectful effs MonoEnv.empty e
|
ziv@2248
|
123 then IS.add (effs, name)
|
ziv@2248
|
124 else effs
|
ziv@2215
|
125 val doDecl =
|
ziv@2248
|
126 fn ((DVal v, _), effs) => doVal (v, effs)
|
ziv@2248
|
127 (* Repeat the list of declarations a number of times equal to its size,
|
ziv@2248
|
128 making sure effectfulness propagates everywhere it should. This is
|
ziv@2248
|
129 analagous to the Bellman-Ford algorithm. *)
|
ziv@2248
|
130 | ((DValRec vs, _), effs) =>
|
ziv@2248
|
131 List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs))
|
ziv@2215
|
132 (* ASK: any other cases? *)
|
ziv@2248
|
133 | (_, effs) => effs
|
ziv@2215
|
134 in
|
ziv@2248
|
135 List.foldl doDecl IS.empty decls
|
ziv@2215
|
136 end
|
ziv@2215
|
137
|
ziv@2215
|
138
|
ziv@2248
|
139 (*********************************)
|
ziv@2248
|
140 (* Boolean Formula Normalization *)
|
ziv@2248
|
141 (*********************************)
|
ziv@2216
|
142
|
ziv@2234
|
143 datatype junctionType = Conj | Disj
|
ziv@2216
|
144
|
ziv@2216
|
145 datatype 'atom formula =
|
ziv@2216
|
146 Atom of 'atom
|
ziv@2216
|
147 | Negate of 'atom formula
|
ziv@2234
|
148 | Combo of junctionType * 'atom formula list
|
ziv@2216
|
149
|
ziv@2243
|
150 (* Guaranteed to have all negation pushed to the atoms. *)
|
ziv@2243
|
151 datatype 'atom formula' =
|
ziv@2243
|
152 Atom' of 'atom
|
ziv@2243
|
153 | Combo' of junctionType * 'atom formula' list
|
ziv@2243
|
154
|
ziv@2234
|
155 val flipJt = fn Conj => Disj | Disj => Conj
|
ziv@2216
|
156
|
ziv@2236
|
157 fun concatMap f xs = List.concat (map f xs)
|
ziv@2216
|
158
|
ziv@2216
|
159 val rec cartesianProduct : 'a list list -> 'a list list =
|
ziv@2216
|
160 fn [] => [[]]
|
ziv@2236
|
161 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
|
ziv@2236
|
162 (cartesianProduct xss)
|
ziv@2216
|
163
|
ziv@2218
|
164 (* Pushes all negation to the atoms.*)
|
ziv@2244
|
165 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
|
ziv@2244
|
166 fn Atom x => Atom' (normalizeAtom (negating, x))
|
ziv@2244
|
167 | Negate f => pushNegate normalizeAtom (not negating) f
|
ziv@2244
|
168 | Combo (j, fs) => Combo' (if negating then flipJt j else j,
|
ziv@2244
|
169 map (pushNegate normalizeAtom negating) fs)
|
ziv@2218
|
170
|
ziv@2218
|
171 val rec flatten =
|
ziv@2243
|
172 fn Combo' (_, [f]) => flatten f
|
ziv@2243
|
173 | Combo' (j, fs) =>
|
ziv@2243
|
174 Combo' (j, List.foldr (fn (f, acc) =>
|
ziv@2243
|
175 case f of
|
ziv@2243
|
176 Combo' (j', fs') =>
|
ziv@2243
|
177 if j = j' orelse length fs' = 1
|
ziv@2243
|
178 then fs' @ acc
|
ziv@2243
|
179 else f :: acc
|
ziv@2243
|
180 | _ => f :: acc)
|
ziv@2243
|
181 []
|
ziv@2243
|
182 (map flatten fs))
|
ziv@2218
|
183 | f => f
|
ziv@2218
|
184
|
ziv@2243
|
185 (* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj],
|
ziv@2243
|
186 consider the list of lists to be a disjunction of conjunctions. *)
|
ziv@2237
|
187 fun normalize' (simplify : 'a list list -> 'a list list)
|
ziv@2235
|
188 (junc : junctionType) =
|
ziv@2216
|
189 let
|
ziv@2235
|
190 fun norm junc =
|
ziv@2237
|
191 simplify
|
ziv@2243
|
192 o (fn Atom' x => [[x]]
|
ziv@2243
|
193 | Combo' (j, fs) =>
|
ziv@2235
|
194 let
|
ziv@2236
|
195 val fss = map (norm junc) fs
|
ziv@2235
|
196 in
|
ziv@2236
|
197 if j = junc
|
ziv@2236
|
198 then List.concat fss
|
ziv@2236
|
199 else map List.concat (cartesianProduct fss)
|
ziv@2235
|
200 end)
|
ziv@2216
|
201 in
|
ziv@2235
|
202 norm junc
|
ziv@2216
|
203 end
|
ziv@2216
|
204
|
ziv@2244
|
205 fun normalize simplify normalizeAtom junc =
|
ziv@2243
|
206 normalize' simplify junc
|
ziv@2235
|
207 o flatten
|
ziv@2244
|
208 o pushNegate normalizeAtom false
|
ziv@2216
|
209
|
ziv@2221
|
210 fun mapFormula mf =
|
ziv@2221
|
211 fn Atom x => Atom (mf x)
|
ziv@2221
|
212 | Negate f => Negate (mapFormula mf f)
|
ziv@2235
|
213 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs)
|
ziv@2216
|
214
|
ziv@2230
|
215
|
ziv@2248
|
216 (****************)
|
ziv@2248
|
217 (* SQL Analysis *)
|
ziv@2248
|
218 (****************)
|
ziv@2213
|
219
|
ziv@2240
|
220 structure CmpKey = struct
|
ziv@2235
|
221
|
ziv@2235
|
222 type ord_key = Sql.cmp
|
ziv@2235
|
223
|
ziv@2235
|
224 val compare =
|
ziv@2235
|
225 fn (Sql.Eq, Sql.Eq) => EQUAL
|
ziv@2235
|
226 | (Sql.Eq, _) => LESS
|
ziv@2235
|
227 | (_, Sql.Eq) => GREATER
|
ziv@2235
|
228 | (Sql.Ne, Sql.Ne) => EQUAL
|
ziv@2235
|
229 | (Sql.Ne, _) => LESS
|
ziv@2235
|
230 | (_, Sql.Ne) => GREATER
|
ziv@2235
|
231 | (Sql.Lt, Sql.Lt) => EQUAL
|
ziv@2235
|
232 | (Sql.Lt, _) => LESS
|
ziv@2235
|
233 | (_, Sql.Lt) => GREATER
|
ziv@2235
|
234 | (Sql.Le, Sql.Le) => EQUAL
|
ziv@2235
|
235 | (Sql.Le, _) => LESS
|
ziv@2235
|
236 | (_, Sql.Le) => GREATER
|
ziv@2235
|
237 | (Sql.Gt, Sql.Gt) => EQUAL
|
ziv@2235
|
238 | (Sql.Gt, _) => LESS
|
ziv@2235
|
239 | (_, Sql.Gt) => GREATER
|
ziv@2235
|
240 | (Sql.Ge, Sql.Ge) => EQUAL
|
ziv@2235
|
241
|
ziv@2235
|
242 end
|
ziv@2235
|
243
|
ziv@2216
|
244 val rec chooseTwos : 'a list -> ('a * 'a) list =
|
ziv@2216
|
245 fn [] => []
|
ziv@2216
|
246 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
|
ziv@2213
|
247
|
ziv@2237
|
248 fun removeRedundant madeRedundantBy zs =
|
ziv@2237
|
249 let
|
ziv@2237
|
250 fun removeRedundant' (xs, ys) =
|
ziv@2237
|
251 case xs of
|
ziv@2237
|
252 [] => ys
|
ziv@2237
|
253 | x :: xs' =>
|
ziv@2237
|
254 removeRedundant' (xs',
|
ziv@2237
|
255 if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys)
|
ziv@2237
|
256 then ys
|
ziv@2237
|
257 else x :: ys)
|
ziv@2237
|
258 in
|
ziv@2237
|
259 removeRedundant' (zs, [])
|
ziv@2237
|
260 end
|
ziv@2237
|
261
|
ziv@2216
|
262 datatype atomExp =
|
ziv@2216
|
263 QueryArg of int
|
ziv@2216
|
264 | DmlRel of int
|
ziv@2216
|
265 | Prim of Prim.t
|
ziv@2216
|
266 | Field of string * string
|
ziv@2216
|
267
|
ziv@2216
|
268 structure AtomExpKey : ORD_KEY = struct
|
ziv@2216
|
269
|
ziv@2234
|
270 type ord_key = atomExp
|
ziv@2216
|
271
|
ziv@2234
|
272 val compare =
|
ziv@2234
|
273 fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
|
ziv@2234
|
274 | (QueryArg _, _) => LESS
|
ziv@2234
|
275 | (_, QueryArg _) => GREATER
|
ziv@2234
|
276 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
|
ziv@2234
|
277 | (DmlRel _, _) => LESS
|
ziv@2234
|
278 | (_, DmlRel _) => GREATER
|
ziv@2234
|
279 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
|
ziv@2234
|
280 | (Prim _, _) => LESS
|
ziv@2234
|
281 | (_, Prim _) => GREATER
|
ziv@2234
|
282 | (Field (t1, f1), Field (t2, f2)) =>
|
ziv@2234
|
283 case String.compare (t1, t2) of
|
ziv@2234
|
284 EQUAL => String.compare (f1, f2)
|
ziv@2234
|
285 | ord => ord
|
ziv@2216
|
286
|
ziv@2216
|
287 end
|
ziv@2216
|
288
|
ziv@2244
|
289 structure AtomOptionKey = OptionKeyFn(AtomExpKey)
|
ziv@2244
|
290
|
ziv@2216
|
291 structure UF = UnionFindFn(AtomExpKey)
|
ziv@2234
|
292
|
ziv@2235
|
293 structure ConflictMaps = struct
|
ziv@2235
|
294
|
ziv@2235
|
295 structure TK = TripleKeyFn(structure I = CmpKey
|
ziv@2244
|
296 structure J = AtomOptionKey
|
ziv@2244
|
297 structure K = AtomOptionKey)
|
ziv@2244
|
298 structure TS : ORD_SET = BinarySetFn(TK)
|
ziv@2235
|
299
|
ziv@2235
|
300 val toKnownEquality =
|
ziv@2235
|
301 (* [NONE] here means unkown. Anything that isn't a comparison between two
|
ziv@2235
|
302 knowns shouldn't be used, and simply dropping unused terms is okay in
|
ziv@2235
|
303 disjunctive normal form. *)
|
ziv@2235
|
304 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
|
ziv@2235
|
305 | _ => NONE
|
ziv@2235
|
306
|
ziv@2235
|
307 val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list =
|
ziv@2235
|
308 UF.classes
|
ziv@2235
|
309 o List.foldl UF.union' UF.empty
|
ziv@2235
|
310 o List.mapPartial toKnownEquality
|
ziv@2235
|
311
|
ziv@2235
|
312 fun addToEqs (eqs, n, e) =
|
ziv@2235
|
313 case IM.find (eqs, n) of
|
ziv@2235
|
314 (* Comparing to a constant is probably better than comparing to a
|
ziv@2235
|
315 variable? Checking that existing constants match a new ones is
|
ziv@2235
|
316 handled by [accumulateEqs]. *)
|
ziv@2235
|
317 SOME (Prim _) => eqs
|
ziv@2235
|
318 | _ => IM.insert (eqs, n, e)
|
ziv@2235
|
319
|
ziv@2235
|
320 val accumulateEqs =
|
ziv@2235
|
321 (* [NONE] means we have a contradiction. *)
|
ziv@2235
|
322 fn (_, NONE) => NONE
|
ziv@2235
|
323 | ((Prim p1, Prim p2), eqso) =>
|
ziv@2235
|
324 (case Prim.compare (p1, p2) of
|
ziv@2235
|
325 EQUAL => eqso
|
ziv@2235
|
326 | _ => NONE)
|
ziv@2235
|
327 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
|
ziv@2235
|
328 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
|
ziv@2235
|
329 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
|
ziv@2235
|
330 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
|
ziv@2235
|
331 (* TODO: deal with equalities between [DmlRel]s and [Prim]s.
|
ziv@2235
|
332 This would involve guarding the invalidation with a check for the
|
ziv@2235
|
333 relevant comparisons. *)
|
ziv@2235
|
334 | (_, eqso) => eqso
|
ziv@2235
|
335
|
ziv@2235
|
336 val eqsOfClass : atomExp list -> atomExp IM.map option =
|
ziv@2235
|
337 List.foldl accumulateEqs (SOME IM.empty)
|
ziv@2235
|
338 o chooseTwos
|
ziv@2235
|
339
|
ziv@2235
|
340 fun toAtomExps rel (cmp, e1, e2) =
|
ziv@2235
|
341 let
|
ziv@2235
|
342 val qa =
|
ziv@2235
|
343 (* Here [NONE] means unkown. *)
|
ziv@2235
|
344 fn Sql.SqConst p => SOME (Prim p)
|
ziv@2235
|
345 | Sql.Field tf => SOME (Field tf)
|
ziv@2235
|
346 | Sql.Inj (EPrim p, _) => SOME (Prim p)
|
ziv@2235
|
347 | Sql.Inj (ERel n, _) => SOME (rel n)
|
ziv@2235
|
348 (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
|
ziv@2235
|
349 becomes Sql.Unmodeled, which becomes NONE here. *)
|
ziv@2235
|
350 | _ => NONE
|
ziv@2235
|
351 in
|
ziv@2235
|
352 (cmp, qa e1, qa e2)
|
ziv@2235
|
353 end
|
ziv@2235
|
354
|
ziv@2244
|
355 val negateCmp =
|
ziv@2244
|
356 fn Sql.Eq => Sql.Ne
|
ziv@2244
|
357 | Sql.Ne => Sql.Eq
|
ziv@2244
|
358 | Sql.Lt => Sql.Ge
|
ziv@2244
|
359 | Sql.Le => Sql.Gt
|
ziv@2244
|
360 | Sql.Gt => Sql.Le
|
ziv@2244
|
361 | Sql.Ge => Sql.Lt
|
ziv@2244
|
362
|
ziv@2244
|
363 fun normalizeAtom (negating, (cmp, e1, e2)) =
|
ziv@2244
|
364 (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with
|
ziv@2244
|
365 simplification, where we put the triples in sets. *)
|
ziv@2244
|
366 case (if negating then negateCmp cmp else cmp) of
|
ziv@2244
|
367 Sql.Eq => (case AtomOptionKey.compare (e1, e2) of
|
ziv@2244
|
368 LESS => (Sql.Eq, e2, e1)
|
ziv@2244
|
369 | _ => (Sql.Eq, e1, e2))
|
ziv@2244
|
370 | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of
|
ziv@2244
|
371 LESS => (Sql.Ne, e2, e1)
|
ziv@2244
|
372 | _ => (Sql.Ne, e1, e2))
|
ziv@2244
|
373 | Sql.Lt => (Sql.Lt, e1, e2)
|
ziv@2244
|
374 | Sql.Le => (Sql.Le, e1, e2)
|
ziv@2244
|
375 | Sql.Gt => (Sql.Lt, e2, e1)
|
ziv@2244
|
376 | Sql.Ge => (Sql.Le, e2, e1)
|
ziv@2235
|
377
|
ziv@2235
|
378 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
|
ziv@2235
|
379 (Sql.cmp * atomExp option * atomExp option) formula =
|
ziv@2235
|
380 mapFormula (toAtomExps QueryArg)
|
ziv@2235
|
381
|
ziv@2235
|
382 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
|
ziv@2235
|
383 (Sql.cmp * atomExp option * atomExp option) formula =
|
ziv@2235
|
384 mapFormula (toAtomExps DmlRel)
|
ziv@2250
|
385
|
ziv@2235
|
386 (* No eqs should have key conflicts because no variable is in two
|
ziv@2235
|
387 equivalence classes, so the [#1] could be [#2]. *)
|
ziv@2235
|
388 val mergeEqs : (atomExp IntBinaryMap.map option list
|
ziv@2235
|
389 -> atomExp IntBinaryMap.map option) =
|
ziv@2235
|
390 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
|
ziv@2235
|
391 (SOME IM.empty)
|
ziv@2235
|
392
|
ziv@2239
|
393 val simplify =
|
ziv@2239
|
394 map TS.listItems
|
ziv@2239
|
395 o removeRedundant (fn (x, y) => TS.isSubset (y, x))
|
ziv@2239
|
396 o map (fn xs => TS.addList (TS.empty, xs))
|
ziv@2239
|
397
|
ziv@2235
|
398 fun dnf (fQuery, fDml) =
|
ziv@2244
|
399 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
|
ziv@2235
|
400
|
ziv@2235
|
401 val conflictMaps = List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
|
ziv@2235
|
402
|
ziv@2235
|
403 end
|
ziv@2235
|
404
|
ziv@2235
|
405 val conflictMaps = ConflictMaps.conflictMaps
|
ziv@2213
|
406
|
ziv@2216
|
407 val rec sqexpToFormula =
|
ziv@2234
|
408 fn Sql.SqTrue => Combo (Conj, [])
|
ziv@2234
|
409 | Sql.SqFalse => Combo (Disj, [])
|
ziv@2216
|
410 | Sql.SqNot e => Negate (sqexpToFormula e)
|
ziv@2216
|
411 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
|
ziv@2234
|
412 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
|
ziv@2216
|
413 [sqexpToFormula p1, sqexpToFormula p2])
|
ziv@2216
|
414 (* ASK: any other sqexps that can be props? *)
|
ziv@2216
|
415 | _ => raise Match
|
ziv@2213
|
416
|
ziv@2218
|
417 fun renameTables tablePairs =
|
ziv@2216
|
418 let
|
ziv@2216
|
419 fun renameString table =
|
ziv@2216
|
420 case List.find (fn (_, t) => table = t) tablePairs of
|
ziv@2216
|
421 NONE => table
|
ziv@2216
|
422 | SOME (realTable, _) => realTable
|
ziv@2216
|
423 val renameSqexp =
|
ziv@2216
|
424 fn Sql.Field (table, field) => Sql.Field (renameString table, field)
|
ziv@2216
|
425 | e => e
|
ziv@2218
|
426 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2)
|
ziv@2216
|
427 in
|
ziv@2218
|
428 mapFormula renameAtom
|
ziv@2216
|
429 end
|
ziv@2218
|
430
|
ziv@2218
|
431 val rec queryToFormula =
|
ziv@2234
|
432 fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, [])
|
ziv@2218
|
433 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
|
ziv@2218
|
434 renameTables tablePairs (sqexpToFormula e)
|
ziv@2234
|
435 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2])
|
ziv@2216
|
436
|
ziv@2218
|
437 fun valsToFormula (table, vals) =
|
ziv@2234
|
438 Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
|
ziv@2218
|
439
|
ziv@2216
|
440 val rec dmlToFormula =
|
ziv@2221
|
441 fn Sql.Insert (table, vals) => valsToFormula (table, vals)
|
ziv@2218
|
442 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
|
ziv@2218
|
443 | Sql.Update (table, vals, wher) =>
|
ziv@2218
|
444 let
|
ziv@2221
|
445 val fWhere = sqexpToFormula wher
|
ziv@2221
|
446 val fVals = valsToFormula (table, vals)
|
ziv@2237
|
447 val modifiedFields = SS.addList (SS.empty, map #1 vals)
|
ziv@2221
|
448 (* TODO: don't use field name hack. *)
|
ziv@2221
|
449 val markField =
|
ziv@2237
|
450 fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v)
|
ziv@2237
|
451 then Sql.Field (t, v ^ "'")
|
ziv@2237
|
452 else e
|
ziv@2221
|
453 | e => e
|
ziv@2221
|
454 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
|
ziv@2218
|
455 in
|
ziv@2218
|
456 renameTables [(table, "T")]
|
ziv@2234
|
457 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]),
|
ziv@2244
|
458 Combo (Conj, [mark fVals, fWhere])]))
|
ziv@2218
|
459 end
|
ziv@2213
|
460
|
ziv@2213
|
461 val rec tablesQuery =
|
ziv@2216
|
462 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
|
ziv@2216
|
463 | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
|
ziv@2213
|
464
|
ziv@2213
|
465 val tableDml =
|
ziv@2216
|
466 fn Sql.Insert (tab, _) => tab
|
ziv@2216
|
467 | Sql.Delete (tab, _) => tab
|
ziv@2216
|
468 | Sql.Update (tab, _, _) => tab
|
ziv@2213
|
469
|
ziv@2213
|
470
|
ziv@2265
|
471 (*************************************)
|
ziv@2265
|
472 (* Program Instrumentation Utilities *)
|
ziv@2265
|
473 (*************************************)
|
ziv@2213
|
474
|
ziv@2234
|
475 val varName =
|
ziv@2234
|
476 let
|
ziv@2234
|
477 val varNumber = ref 0
|
ziv@2234
|
478 in
|
ziv@2234
|
479 fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber))
|
ziv@2234
|
480 end
|
ziv@2234
|
481
|
ziv@2233
|
482 val {check, store, flush, ...} = getCache ()
|
ziv@2233
|
483
|
ziv@2230
|
484 val dummyLoc = ErrorMsg.dummySpan
|
ziv@2216
|
485
|
ziv@2248
|
486 val dummyTyp = (TRecord [], dummyLoc)
|
ziv@2248
|
487
|
ziv@2230
|
488 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
|
ziv@2230
|
489
|
ziv@2230
|
490 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
|
ziv@2213
|
491
|
ziv@2213
|
492 val sequence =
|
ziv@2213
|
493 fn (exp :: exps) =>
|
ziv@2213
|
494 let
|
ziv@2230
|
495 val loc = dummyLoc
|
ziv@2213
|
496 in
|
ziv@2213
|
497 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
|
ziv@2213
|
498 end
|
ziv@2213
|
499 | _ => raise Match
|
ziv@2213
|
500
|
ziv@2248
|
501 (* Always increments negative indices as a hack we use later. *)
|
ziv@2248
|
502 fun incRels inc =
|
ziv@2215
|
503 MonoUtil.Exp.mapB
|
ziv@2248
|
504 {typ = fn t' => t',
|
ziv@2248
|
505 exp = fn bound =>
|
ziv@2248
|
506 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
|
ziv@2248
|
507 | e' => e'),
|
ziv@2248
|
508 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
|
ziv@2248
|
509 0
|
ziv@2213
|
510
|
ziv@2262
|
511 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
|
ziv@2262
|
512 let
|
ziv@2262
|
513 fun doVal env ((x, n, t, exp, s), state) =
|
ziv@2262
|
514 let
|
ziv@2262
|
515 val (exp, state) = doTopLevelExp env exp state
|
ziv@2262
|
516 in
|
ziv@2262
|
517 ((x, n, t, exp, s), state)
|
ziv@2262
|
518 end
|
ziv@2262
|
519 fun doDecl' env (decl', state) =
|
ziv@2262
|
520 case decl' of
|
ziv@2262
|
521 DVal v =>
|
ziv@2262
|
522 let
|
ziv@2262
|
523 val (v, state) = doVal env (v, state)
|
ziv@2262
|
524 in
|
ziv@2262
|
525 (DVal v, state)
|
ziv@2262
|
526 end
|
ziv@2262
|
527 | DValRec vs =>
|
ziv@2262
|
528 let
|
ziv@2262
|
529 val (vs, state) = ListUtil.foldlMap (doVal env) state vs
|
ziv@2262
|
530 in
|
ziv@2262
|
531 (DValRec vs, state)
|
ziv@2262
|
532 end
|
ziv@2262
|
533 | _ => (decl', state)
|
ziv@2262
|
534 fun doDecl (decl as (decl', loc), (env, state)) =
|
ziv@2262
|
535 let
|
ziv@2262
|
536 val env = MonoEnv.declBinds env decl
|
ziv@2262
|
537 val (decl', state) = doDecl' env (decl', state)
|
ziv@2262
|
538 in
|
ziv@2262
|
539 ((decl', loc), (env, state))
|
ziv@2262
|
540 end
|
ziv@2262
|
541 val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
|
ziv@2262
|
542 in
|
ziv@2262
|
543 ((decls, sideInfo), state)
|
ziv@2262
|
544 end
|
ziv@2262
|
545
|
ziv@2262
|
546 fun fileAllMapfoldB doExp file start =
|
ziv@2248
|
547 case MonoUtil.File.mapfoldB
|
ziv@2248
|
548 {typ = Search.return2,
|
ziv@2250
|
549 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
|
ziv@2248
|
550 decl = fn _ => Search.return2,
|
ziv@2248
|
551 bind = doBind}
|
ziv@2250
|
552 MonoEnv.empty file start of
|
ziv@2213
|
553 Search.Continue x => x
|
ziv@2213
|
554 | Search.Return _ => raise Match
|
ziv@2213
|
555
|
ziv@2262
|
556 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
|
ziv@2213
|
557
|
ziv@2266
|
558 (* Takes a text expression and returns
|
ziv@2266
|
559 newText: a new expression with any subexpressions that do computation
|
ziv@2266
|
560 replaced with variables,
|
ziv@2266
|
561 wrapLets: a function that wraps its argument expression with lets binding
|
ziv@2266
|
562 those variables to their corresponding computations, and
|
ziv@2266
|
563 numArgs: the number of such bindings.
|
ziv@2266
|
564 The De Bruijn indices work out for [wrapLets (incRels numArgs newText)], but
|
ziv@2266
|
565 the intention is that newText might be augmented. *)
|
ziv@2266
|
566 fun factorOutNontrivial text =
|
ziv@2266
|
567 let
|
ziv@2266
|
568 val loc = dummyLoc
|
ziv@2266
|
569 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
|
ziv@2266
|
570 val chunks = Sql.chunkify text
|
ziv@2266
|
571 val (newText, newVariables) =
|
ziv@2266
|
572 (* Important that this is foldr (to oppose foldl below). *)
|
ziv@2266
|
573 List.foldr
|
ziv@2266
|
574 (fn (chunk, (qText, newVars)) =>
|
ziv@2266
|
575 (* Variable bound to the head of newVars will have the lowest index. *)
|
ziv@2266
|
576 case chunk of
|
ziv@2266
|
577 (* EPrim should always be a string in this case. *)
|
ziv@2266
|
578 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
|
ziv@2266
|
579 | Sql.Exp e =>
|
ziv@2266
|
580 let
|
ziv@2266
|
581 val n = length newVars
|
ziv@2266
|
582 in
|
ziv@2266
|
583 (* This is the (n+1)th new variable, so there are
|
ziv@2266
|
584 already n new variables bound, so we increment
|
ziv@2266
|
585 indices by n. *)
|
ziv@2266
|
586 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
|
ziv@2266
|
587 end
|
ziv@2266
|
588 | Sql.String s => (strcat (stringExp s, qText), newVars))
|
ziv@2266
|
589 (stringExp "", [])
|
ziv@2266
|
590 chunks
|
ziv@2266
|
591 fun wrapLets e' =
|
ziv@2266
|
592 (* Important that this is foldl (to oppose foldr above). *)
|
ziv@2266
|
593 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
|
ziv@2266
|
594 e'
|
ziv@2266
|
595 newVariables
|
ziv@2266
|
596 val numArgs = length newVariables
|
ziv@2266
|
597 in
|
ziv@2266
|
598 (newText, wrapLets, numArgs)
|
ziv@2266
|
599 end
|
ziv@2266
|
600
|
ziv@2250
|
601
|
ziv@2250
|
602 (**********************)
|
ziv@2250
|
603 (* Mono Type Checking *)
|
ziv@2250
|
604 (**********************)
|
ziv@2250
|
605
|
ziv@2250
|
606 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
|
ziv@2250
|
607 fn EPrim p => SOME (TFfi ("Basis", case p of
|
ziv@2250
|
608 Prim.Int _ => "int"
|
ziv@2250
|
609 | Prim.Float _ => "double"
|
ziv@2250
|
610 | Prim.String _ => "string"
|
ziv@2250
|
611 | Prim.Char _ => "char"),
|
ziv@2250
|
612 dummyLoc)
|
ziv@2250
|
613 | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
|
ziv@2250
|
614 | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
|
ziv@2250
|
615 (* ASK: okay to make a new [ref] each time? *)
|
ziv@2250
|
616 | ECon (dk, PConVar nCon, _) =>
|
ziv@2250
|
617 let
|
ziv@2250
|
618 val (_, _, nData) = MonoEnv.lookupConstructor env nCon
|
ziv@2250
|
619 val (_, cs) = MonoEnv.lookupDatatype env nData
|
ziv@2250
|
620 in
|
ziv@2250
|
621 SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
|
ziv@2250
|
622 end
|
ziv@2250
|
623 | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
|
ziv@2250
|
624 | ENone t => SOME (TOption t, dummyLoc)
|
ziv@2250
|
625 | ESome (t, _) => SOME (TOption t, dummyLoc)
|
ziv@2250
|
626 | EFfi _ => NONE
|
ziv@2250
|
627 | EFfiApp _ => NONE
|
ziv@2250
|
628 | EApp (e1, e2) => (case typOfExp env e1 of
|
ziv@2250
|
629 SOME (TFun (_, t), _) => SOME t
|
ziv@2250
|
630 | _ => NONE)
|
ziv@2250
|
631 | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
|
ziv@2250
|
632 (* ASK: is this right? *)
|
ziv@2250
|
633 | EUnop (unop, e) => (case unop of
|
ziv@2250
|
634 "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
|
ziv@2250
|
635 | "-" => typOfExp env e
|
ziv@2250
|
636 | _ => NONE)
|
ziv@2250
|
637 (* ASK: how should this (and other "=> NONE" cases) work? *)
|
ziv@2250
|
638 | EBinop _ => NONE
|
ziv@2250
|
639 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
|
ziv@2250
|
640 | EField (e, s) => (case typOfExp env e of
|
ziv@2250
|
641 SOME (TRecord fields, _) =>
|
ziv@2250
|
642 (case List.find (fn (s', _) => s = s') fields of
|
ziv@2250
|
643 SOME (_, t) => SOME t
|
ziv@2250
|
644 | _ => NONE)
|
ziv@2250
|
645 | _ => NONE)
|
ziv@2250
|
646 | ECase (_, _, {result, ...}) => SOME result
|
ziv@2250
|
647 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
|
ziv@2250
|
648 | EWrite _ => SOME (TRecord [], dummyLoc)
|
ziv@2250
|
649 | ESeq (_, e) => typOfExp env e
|
ziv@2250
|
650 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
|
ziv@2250
|
651 | EClosure _ => NONE
|
ziv@2250
|
652 | EUnurlify (_, t, _) => SOME t
|
ziv@2256
|
653 | _ => NONE
|
ziv@2250
|
654
|
ziv@2250
|
655 and typOfExp env (e', loc) = typOfExp' env e'
|
ziv@2250
|
656
|
ziv@2250
|
657
|
ziv@2266
|
658 (***********)
|
ziv@2266
|
659 (* Caching *)
|
ziv@2266
|
660 (***********)
|
ziv@2250
|
661
|
ziv@2265
|
662 fun cacheWrap (env, exp, resultTyp, args, i) =
|
ziv@2265
|
663 let
|
ziv@2265
|
664 val loc = dummyLoc
|
ziv@2265
|
665 val rel0 = (ERel 0, loc)
|
ziv@2265
|
666 in
|
ziv@2265
|
667 case MonoFooify.urlify env (rel0, resultTyp) of
|
ziv@2265
|
668 NONE => NONE
|
ziv@2265
|
669 | SOME urlified =>
|
ziv@2265
|
670 let
|
ziv@2265
|
671 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
|
ziv@2265
|
672 (* We ensure before this step that all arguments aren't effectful.
|
ziv@2265
|
673 by turning them into local variables as needed. *)
|
ziv@2265
|
674 val argsInc = map (incRels 1) args
|
ziv@2265
|
675 val check = (check (i, args), loc)
|
ziv@2265
|
676 val store = (store (i, argsInc, urlified), loc)
|
ziv@2265
|
677 in
|
ziv@2265
|
678 SOME (ECase
|
ziv@2265
|
679 (check,
|
ziv@2265
|
680 [((PNone stringTyp, loc),
|
ziv@2265
|
681 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
|
ziv@2265
|
682 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
|
ziv@2265
|
683 (* Boolean is false because we're not unurlifying from a cookie. *)
|
ziv@2265
|
684 (EUnurlify (rel0, resultTyp, false), loc))],
|
ziv@2265
|
685 {disc = (TOption stringTyp, loc), result = resultTyp}))
|
ziv@2265
|
686 end
|
ziv@2265
|
687 end
|
ziv@2265
|
688
|
ziv@2257
|
689 val freeVars =
|
ziv@2257
|
690 IS.listItems
|
ziv@2257
|
691 o MonoUtil.Exp.foldB
|
ziv@2257
|
692 {typ = #2,
|
ziv@2257
|
693 exp = fn (bound, ERel n, vars) => if n < bound
|
ziv@2257
|
694 then vars
|
ziv@2257
|
695 else IS.add (vars, n - bound)
|
ziv@2257
|
696 | (_, _, vars) => vars,
|
ziv@2257
|
697 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
|
ziv@2257
|
698 0
|
ziv@2257
|
699 IS.empty
|
ziv@2257
|
700
|
ziv@2258
|
701 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
|
ziv@2258
|
702
|
ziv@2250
|
703 datatype subexp = Pure of unit -> exp | Impure of exp
|
ziv@2250
|
704
|
ziv@2250
|
705 val isImpure =
|
ziv@2250
|
706 fn Pure _ => false
|
ziv@2250
|
707 | Impure _ => true
|
ziv@2250
|
708
|
ziv@2250
|
709 val expOfSubexp =
|
ziv@2250
|
710 fn Pure f => f ()
|
ziv@2250
|
711 | Impure e => e
|
ziv@2250
|
712
|
ziv@2259
|
713 (* TODO: pick a number. *)
|
ziv@2259
|
714 val sizeWorthCaching = 5
|
ziv@2259
|
715
|
ziv@2266
|
716 type state = (SIMM.multimap * (Sql.query * int) IntBinaryMap.map * int)
|
ziv@2266
|
717
|
ziv@2266
|
718 fun incIndex (x, y, index) = (x, y, index+1)
|
ziv@2266
|
719
|
ziv@2266
|
720 fun cacheQuery effs env (state as (tableToIndices, indexToQueryNumArgs, index)) =
|
ziv@2266
|
721 fn q as {query = origQueryText,
|
ziv@2266
|
722 state = resultTyp,
|
ziv@2266
|
723 initial, body, tables, exps} =>
|
ziv@2266
|
724 let
|
ziv@2266
|
725 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
|
ziv@2266
|
726 (* Increment once for each new variable just made. This is where we
|
ziv@2266
|
727 use the negative De Bruijn indices hack. *)
|
ziv@2266
|
728 (* TODO: please don't use that hack. As anyone could have predicted, it
|
ziv@2266
|
729 was incomprehensible a year later.... *)
|
ziv@2266
|
730 val queryExp = incRels numArgs
|
ziv@2266
|
731 (EQuery {query = newQueryText,
|
ziv@2266
|
732 state = resultTyp,
|
ziv@2266
|
733 initial = initial,
|
ziv@2266
|
734 body = body,
|
ziv@2266
|
735 tables = tables,
|
ziv@2266
|
736 exps = exps},
|
ziv@2266
|
737 dummyLoc)
|
ziv@2266
|
738 (* DEBUG *)
|
ziv@2266
|
739 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
|
ziv@2266
|
740 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
|
ziv@2266
|
741 (* We use dummyTyp here. I think this is okay because databases don't
|
ziv@2266
|
742 store (effectful) functions, but perhaps there's some pathalogical
|
ziv@2266
|
743 corner case missing.... *)
|
ziv@2266
|
744 fun safe bound =
|
ziv@2266
|
745 not
|
ziv@2266
|
746 o effectful effs
|
ziv@2266
|
747 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
|
ziv@2266
|
748 bound
|
ziv@2266
|
749 env)
|
ziv@2266
|
750 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
|
ziv@2266
|
751 val attempt =
|
ziv@2266
|
752 (* Ziv misses Haskell's do notation.... *)
|
ziv@2266
|
753 textOfQuery queryExp
|
ziv@2266
|
754 <\obind\>
|
ziv@2266
|
755 (fn queryText =>
|
ziv@2266
|
756 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
|
ziv@2266
|
757 <\oguard\>
|
ziv@2266
|
758 Sql.parse Sql.query queryText
|
ziv@2266
|
759 <\obind\>
|
ziv@2266
|
760 (fn queryParsed =>
|
ziv@2266
|
761 (cacheWrap (env, queryExp, resultTyp, args, index))
|
ziv@2266
|
762 <\obind\>
|
ziv@2266
|
763 (fn cachedExp =>
|
ziv@2266
|
764 SOME (wrapLets cachedExp,
|
ziv@2266
|
765 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
|
ziv@2266
|
766 tableToIndices
|
ziv@2266
|
767 (tablesQuery queryParsed),
|
ziv@2266
|
768 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
|
ziv@2266
|
769 index + 1)))))
|
ziv@2266
|
770 in
|
ziv@2266
|
771 case attempt of
|
ziv@2266
|
772 SOME pair => pair
|
ziv@2266
|
773 (* Even in this case, we have to increment index to avoid some bug,
|
ziv@2266
|
774 but I forget exactly what it is or why this helps. *)
|
ziv@2266
|
775 (* TODO: just use a reference for current index.... *)
|
ziv@2266
|
776 | NONE => (EQuery q, incIndex state)
|
ziv@2266
|
777 end
|
ziv@2266
|
778
|
ziv@2266
|
779 fun cachePure (env, exp', (_, _, index)) =
|
ziv@2256
|
780 case typOfExp' env exp' of
|
ziv@2256
|
781 NONE => NONE
|
ziv@2256
|
782 | SOME (TFun _, _) => NONE
|
ziv@2256
|
783 | SOME typ =>
|
ziv@2266
|
784 (expSize (exp', dummyLoc) < sizeWorthCaching)
|
ziv@2266
|
785 </oguard/>
|
ziv@2266
|
786 (List.foldr (fn (_, NONE) => NONE
|
ziv@2266
|
787 | ((n, typ), SOME args) =>
|
ziv@2266
|
788 (MonoFooify.urlify env ((ERel n, dummyLoc), typ))
|
ziv@2266
|
789 </obind/>
|
ziv@2266
|
790 (fn arg => SOME (arg :: args)))
|
ziv@2266
|
791 (SOME [])
|
ziv@2266
|
792 (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
|
ziv@2266
|
793 (freeVars (exp', dummyLoc))))
|
ziv@2266
|
794 </obind/>
|
ziv@2266
|
795 (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, index))
|
ziv@2250
|
796
|
ziv@2266
|
797 fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) : subexp * state =
|
ziv@2250
|
798 let
|
ziv@2250
|
799 fun wrapBindN f (args : (MonoEnv.env * exp) list) =
|
ziv@2250
|
800 let
|
ziv@2266
|
801 val (subexps, state) = ListUtil.foldlMap (cache effs) state args
|
ziv@2256
|
802 fun mkExp () = (f (map expOfSubexp subexps), loc)
|
ziv@2250
|
803 in
|
ziv@2250
|
804 if List.exists isImpure subexps
|
ziv@2266
|
805 then (Impure (mkExp ()), state)
|
ziv@2266
|
806 else (Pure (fn () => case cachePure (env, f (map #2 args), state) of
|
ziv@2256
|
807 NONE => mkExp ()
|
ziv@2256
|
808 | SOME e' => (e', loc)),
|
ziv@2256
|
809 (* Conservatively increment index. *)
|
ziv@2266
|
810 incIndex state)
|
ziv@2250
|
811 end
|
ziv@2250
|
812 fun wrapBind1 f arg =
|
ziv@2250
|
813 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
|
ziv@2250
|
814 fun wrapBind2 f (arg1, arg2) =
|
ziv@2250
|
815 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
|
ziv@2250
|
816 fun wrapN f es = wrapBindN f (map (fn e => (env, e)) es)
|
ziv@2250
|
817 fun wrap1 f e = wrapBind1 f (env, e)
|
ziv@2250
|
818 fun wrap2 f (e1, e2) = wrapBind2 f ((env, e1), (env, e2))
|
ziv@2250
|
819 in
|
ziv@2250
|
820 case exp' of
|
ziv@2250
|
821 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
|
ziv@2250
|
822 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
|
ziv@2250
|
823 | EFfiApp (s1, s2, args) =>
|
ziv@2258
|
824 if ffiEffectful (s1, s2)
|
ziv@2266
|
825 then (Impure exp, state)
|
ziv@2258
|
826 else wrapN (fn es =>
|
ziv@2258
|
827 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
|
ziv@2258
|
828 (map #1 args)
|
ziv@2250
|
829 | EApp (e1, e2) => wrap2 EApp (e1, e2)
|
ziv@2250
|
830 | EAbs (s, t1, t2, e) =>
|
ziv@2250
|
831 wrapBind1 (fn e => EAbs (s, t1, t2, e))
|
ziv@2250
|
832 (MonoEnv.pushERel env s t1 NONE, e)
|
ziv@2250
|
833 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
|
ziv@2250
|
834 | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
|
ziv@2250
|
835 | ERecord fields =>
|
ziv@2250
|
836 wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
|
ziv@2250
|
837 (map #2 fields)
|
ziv@2250
|
838 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
|
ziv@2250
|
839 | ECase (e, cases, {disc, result}) =>
|
ziv@2250
|
840 wrapBindN (fn (e::es) =>
|
ziv@2250
|
841 ECase (e,
|
ziv@2250
|
842 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
|
ziv@2256
|
843 {disc = disc, result = result})
|
ziv@2256
|
844 | _ => raise Match)
|
ziv@2250
|
845 ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases)
|
ziv@2250
|
846 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
|
ziv@2250
|
847 (* We record page writes, so they're cachable. *)
|
ziv@2250
|
848 | EWrite e => wrap1 EWrite e
|
ziv@2250
|
849 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
|
ziv@2250
|
850 | ELet (s, t, e1, e2) =>
|
ziv@2250
|
851 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
|
ziv@2250
|
852 ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
|
ziv@2250
|
853 (* ASK: | EClosure (n, es) => ? *)
|
ziv@2250
|
854 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
|
ziv@2266
|
855 | EQuery q =>
|
ziv@2266
|
856 let
|
ziv@2266
|
857 val (exp', state) = cacheQuery effs env state q
|
ziv@2266
|
858 in
|
ziv@2266
|
859 (Impure (exp', loc), state)
|
ziv@2266
|
860 end
|
ziv@2250
|
861 | _ => if effectful effs env exp
|
ziv@2266
|
862 then (Impure exp, state)
|
ziv@2266
|
863 else (Pure (fn () => (case cachePure (env, exp', state) of
|
ziv@2256
|
864 NONE => exp'
|
ziv@2256
|
865 | SOME e' => e',
|
ziv@2256
|
866 loc)),
|
ziv@2266
|
867 incIndex state)
|
ziv@2256
|
868 end
|
ziv@2256
|
869
|
ziv@2266
|
870 fun addCaching file =
|
ziv@2256
|
871 let
|
ziv@2266
|
872 val effs = effectfulDecls file
|
ziv@2266
|
873 fun doTopLevelExp env exp state =
|
ziv@2256
|
874 let
|
ziv@2266
|
875 val (subexp, state) = cache effs ((env, exp), state)
|
ziv@2256
|
876 in
|
ziv@2266
|
877 (expOfSubexp subexp, state)
|
ziv@2256
|
878 end
|
ziv@2256
|
879 in
|
ziv@2266
|
880 ((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, 0)), effs)
|
ziv@2265
|
881 end
|
ziv@2265
|
882
|
ziv@2265
|
883
|
ziv@2265
|
884 (************)
|
ziv@2265
|
885 (* Flushing *)
|
ziv@2265
|
886 (************)
|
ziv@2265
|
887
|
ziv@2265
|
888 structure Invalidations = struct
|
ziv@2265
|
889
|
ziv@2265
|
890 val loc = dummyLoc
|
ziv@2265
|
891
|
ziv@2265
|
892 val optionAtomExpToExp =
|
ziv@2265
|
893 fn NONE => (ENone stringTyp, loc)
|
ziv@2265
|
894 | SOME e => (ESome (stringTyp,
|
ziv@2265
|
895 (case e of
|
ziv@2265
|
896 DmlRel n => ERel n
|
ziv@2265
|
897 | Prim p => EPrim p
|
ziv@2265
|
898 (* TODO: make new type containing only these two. *)
|
ziv@2265
|
899 | _ => raise Match,
|
ziv@2265
|
900 loc)),
|
ziv@2265
|
901 loc)
|
ziv@2265
|
902
|
ziv@2265
|
903 fun eqsToInvalidation numArgs eqs =
|
ziv@2265
|
904 let
|
ziv@2265
|
905 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
|
ziv@2265
|
906 in
|
ziv@2265
|
907 inv (numArgs - 1)
|
ziv@2265
|
908 end
|
ziv@2265
|
909
|
ziv@2265
|
910 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
|
ziv@2265
|
911 represents unknown, which means a wider invalidation. *)
|
ziv@2265
|
912 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
|
ziv@2265
|
913 fn ([], []) => true
|
ziv@2265
|
914 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
|
ziv@2265
|
915 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
|
ziv@2265
|
916 EQUAL => madeRedundantBy (xs, ys)
|
ziv@2265
|
917 | _ => false)
|
ziv@2265
|
918 | _ => false
|
ziv@2265
|
919
|
ziv@2265
|
920 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
|
ziv@2265
|
921
|
ziv@2265
|
922 fun invalidations ((query, numArgs), dml) =
|
ziv@2265
|
923 (map (map optionAtomExpToExp)
|
ziv@2265
|
924 o removeRedundant madeRedundantBy
|
ziv@2265
|
925 o map (eqsToInvalidation numArgs)
|
ziv@2265
|
926 o eqss)
|
ziv@2265
|
927 (query, dml)
|
ziv@2265
|
928
|
ziv@2265
|
929 end
|
ziv@2265
|
930
|
ziv@2265
|
931 val invalidations = Invalidations.invalidations
|
ziv@2265
|
932
|
ziv@2265
|
933 (* DEBUG *)
|
ziv@2265
|
934 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
|
ziv@2265
|
935 (* val gunk' : exp list ref = ref [] *)
|
ziv@2265
|
936
|
ziv@2265
|
937 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
|
ziv@2265
|
938 let
|
ziv@2265
|
939 val flushes = List.concat
|
ziv@2265
|
940 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
|
ziv@2265
|
941 val doExp =
|
ziv@2265
|
942 fn EDml (origDmlText, failureMode) =>
|
ziv@2265
|
943 let
|
ziv@2265
|
944 (* DEBUG *)
|
ziv@2265
|
945 (* val () = gunk' := origDmlText :: !gunk' *)
|
ziv@2265
|
946 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
|
ziv@2265
|
947 val dmlText = incRels numArgs newDmlText
|
ziv@2265
|
948 val dmlExp = EDml (dmlText, failureMode)
|
ziv@2265
|
949 (* DEBUG *)
|
ziv@2265
|
950 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
|
ziv@2265
|
951 val inval =
|
ziv@2265
|
952 case Sql.parse Sql.dml dmlText of
|
ziv@2265
|
953 SOME dmlParsed =>
|
ziv@2265
|
954 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
|
ziv@2265
|
955 SOME queryNumArgs =>
|
ziv@2265
|
956 (* DEBUG *)
|
ziv@2265
|
957 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
|
ziv@2265
|
958 (i, invalidations (queryNumArgs, dmlParsed)))
|
ziv@2265
|
959 (* TODO: fail more gracefully. *)
|
ziv@2265
|
960 | NONE => raise Match))
|
ziv@2265
|
961 (SIMM.findList (tableToIndices, tableDml dmlParsed)))
|
ziv@2265
|
962 | NONE => NONE
|
ziv@2265
|
963 in
|
ziv@2265
|
964 case inval of
|
ziv@2265
|
965 (* TODO: fail more gracefully. *)
|
ziv@2265
|
966 NONE => raise Match
|
ziv@2265
|
967 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
|
ziv@2265
|
968 end
|
ziv@2265
|
969 | e' => e'
|
ziv@2265
|
970 in
|
ziv@2265
|
971 (* DEBUG *)
|
ziv@2265
|
972 (* gunk := []; *)
|
ziv@2266
|
973 fileMap doExp file
|
ziv@2265
|
974 end
|
ziv@2265
|
975
|
ziv@2265
|
976
|
ziv@2265
|
977 (***************)
|
ziv@2265
|
978 (* Entry point *)
|
ziv@2265
|
979 (***************)
|
ziv@2265
|
980
|
ziv@2265
|
981 val inlineSql =
|
ziv@2265
|
982 let
|
ziv@2265
|
983 val doExp =
|
ziv@2265
|
984 (* TODO: EQuery, too? *)
|
ziv@2265
|
985 (* ASK: should this live in [MonoOpt]? *)
|
ziv@2265
|
986 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
|
ziv@2265
|
987 let
|
ziv@2265
|
988 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
|
ziv@2265
|
989 in
|
ziv@2265
|
990 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
|
ziv@2265
|
991 end
|
ziv@2265
|
992 | e => e
|
ziv@2265
|
993 in
|
ziv@2265
|
994 fileMap doExp
|
ziv@2265
|
995 end
|
ziv@2265
|
996
|
ziv@2262
|
997 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
|
ziv@2262
|
998 let
|
ziv@2262
|
999 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
|
ziv@2262
|
1000 in
|
ziv@2262
|
1001 (datatypes @ newDecls @ others, sideInfo)
|
ziv@2262
|
1002 end
|
ziv@2262
|
1003
|
ziv@2266
|
1004 val go' = addFlushing o addCaching o inlineSql
|
ziv@2256
|
1005
|
ziv@2256
|
1006 fun go file =
|
ziv@2256
|
1007 let
|
ziv@2256
|
1008 (* TODO: do something nicer than [Sql] being in one of two modes. *)
|
ziv@2256
|
1009 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
|
ziv@2262
|
1010 val file = go' file
|
ziv@2262
|
1011 (* Important that this happens after [MonoFooify.urlify] calls! *)
|
ziv@2262
|
1012 val fmDecls = MonoFooify.getNewFmDecls ()
|
ziv@2256
|
1013 val () = Sql.sqlcacheMode := false
|
ziv@2256
|
1014 in
|
ziv@2262
|
1015 insertAfterDatatypes (file, rev fmDecls)
|
ziv@2250
|
1016 end
|
ziv@2250
|
1017
|
ziv@2209
|
1018 end
|