Mercurial > urweb

comparison src/sqlcache.sml @ 2304:6fb9232ade99

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge Sqlcache
author Adam Chlipala <adam@chlipala.net>
date Sun, 20 Dec 2015 14:18:52 -0500
parents 8d772fbf59c1
children
comparison
equal deleted inserted replaced
2201:1091227f535a 2304:6fb9232ade99
1 structure Sqlcache :> SQLCACHE = struct
2
3
4 (*********************)
5 (* General Utilities *)
6 (*********************)
7
8 structure IK = struct type ord_key = int val compare = Int.compare end
9 structure IS = IntBinarySet
10 structure IM = IntBinaryMap
11 structure SK = struct type ord_key = string val compare = String.compare end
12 structure SS = BinarySetFn(SK)
13 structure SM = BinaryMapFn(SK)
14 structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS)
15 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
16
17 fun id x = x
18
19 fun iterate f n x = if n < 0
20 then raise Fail "Can't iterate function negative number of times."
21 else if n = 0
22 then x
23 else iterate f (n-1) (f x)
24
25 (* From the MLton wiki. *)
26 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
27 infix 3 \> fun f \> y = f y (* Left application *)
28
29 fun mapFst f (x, y) = (f x, y)
30
31 (* Option monad. *)
32 fun obind (x, f) = Option.mapPartial f x
33 fun oguard (b, x) = if b then x () else NONE
34 fun omap f = fn SOME x => SOME (f x) | _ => NONE
35 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
36 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
37
38 fun concatMap f xs = List.concat (map f xs)
39
40 val rec cartesianProduct : 'a list list -> 'a list list =
41 fn [] => [[]]
42 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
43 (cartesianProduct xss)
44
45 fun indexOf test =
46 let
47 fun f n =
48 fn [] => NONE
49 | (x::xs) => if test x then SOME n else f (n+1) xs
50 in
51 f 0
52 end
53
54
55 (************)
56 (* Settings *)
57 (************)
58
59 open Mono
60
61 (* Filled in by [addFlushing]. *)
62 val ffiInfoRef : {index : int, params : int} list ref = ref []
63
64 fun resetFfiInfo () = ffiInfoRef := []
65
66 fun getFfiInfo () = !ffiInfoRef
67
68 (* Some FFIs have writing as their only effect, which the caching records. *)
69 val ffiEffectful =
70 (* ASK: how can this be less hard-coded? *)
71 let
72 val okayWrites = SS.fromList ["htmlifyInt_w",
73 "htmlifyFloat_w",
74 "htmlifyString_w",
75 "htmlifyBool_w",
76 "htmlifyTime_w",
77 "attrifyInt_w",
78 "attrifyFloat_w",
79 "attrifyString_w",
80 "attrifyChar_w",
81 "urlifyInt_w",
82 "urlifyFloat_w",
83 "urlifyString_w",
84 "urlifyBool_w",
85 "urlifyChannel_w"]
86 in
87 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
88 fn (m, f) => Settings.isEffectful (m, f)
89 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
90 end
91
92 val cacheRef = ref LruCache.cache
93 fun setCache c = cacheRef := c
94 fun getCache () = !cacheRef
95
96 datatype heuristic = Smart | Always | Never | NoPureAll | NoPureOne | NoCombo
97
98 val heuristicRef = ref NoPureOne
99 fun setHeuristic h = heuristicRef := (case h of
100 "smart" => Smart
101 | "always" => Always
102 | "never" => Never
103 | "nopureall" => NoPureAll
104 | "nopureone" => NoPureOne
105 | "nocombo" => NoCombo
106 | _ => raise Fail "Sqlcache: setHeuristic")
107 fun getHeuristic () = !heuristicRef
108
109
110 (************************)
111 (* Really Useful Things *)
112 (************************)
113
114 (* Used to have type context for local variables in MonoUtil functions. *)
115 val doBind =
116 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
117 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
118 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
119
120 val dummyLoc = ErrorMsg.dummySpan
121
122 (* DEBUG *)
123 fun printExp msg exp =
124 (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp)
125 fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp')
126 fun printTyp msg typ =
127 (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ)
128 fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ')
129 fun obindDebug printer (x, f) =
130 case x of
131 NONE => NONE
132 | SOME x' => case f x' of
133 NONE => (printer (); NONE)
134 | y => y
135
136
137 (*******************)
138 (* Effect Analysis *)
139 (*******************)
140
141 (* TODO: test this. *)
142 fun transitiveAnalysis doVal state (decls, _) =
143 let
144 val doDecl =
145 fn ((DVal v, _), state) => doVal (v, state)
146 (* Pass over the list of values a number of times equal to its size,
147 making sure whatever property we're testing propagates everywhere
148 it should. This is analagous to the Bellman-Ford algorithm. *)
149 | ((DValRec vs, _), state) =>
150 iterate (fn state => List.foldl doVal state vs) (length vs) state
151 | (_, state) => state
152 in
153 List.foldl doDecl state decls
154 end
155
156 (* Makes an exception for [EWrite] (which is recorded when caching). *)
157 fun effectful (effs : IS.set) =
158 let
159 val isFunction =
160 fn (TFun _, _) => true
161 | _ => false
162 fun doExp (env, e) =
163 case e of
164 EPrim _ => false
165 (* For now: variables of function type might be effectful, but
166 others are fully evaluated and are therefore not effectful. *)
167 | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
168 | ENamed n => IS.member (effs, n)
169 | EFfi (m, f) => ffiEffectful (m, f)
170 | EFfiApp (m, f, _) => ffiEffectful (m, f)
171 (* These aren't effectful unless a subexpression is. *)
172 | ECon _ => false
173 | ENone _ => false
174 | ESome _ => false
175 | EApp _ => false
176 | EAbs _ => false
177 | EUnop _ => false
178 | EBinop _ => false
179 | ERecord _ => false
180 | EField _ => false
181 | ECase _ => false
182 | EStrcat _ => false
183 (* EWrite is a special exception because we record writes when caching. *)
184 | EWrite _ => false
185 | ESeq _ => false
186 | ELet _ => false
187 | EUnurlify _ => false
188 (* ASK: what should we do about closures? *)
189 (* Everything else is some sort of effect. We could flip this and
190 explicitly list bits of Mono that are effectful, but this is
191 conservatively robust to future changes (however unlikely). *)
192 | _ => true
193 in
194 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind}
195 end
196
197 (* TODO: test this. *)
198 fun effectfulDecls file =
199 transitiveAnalysis (fn ((_, name, _, e, _), effs) =>
200 if effectful effs MonoEnv.empty e
201 then IS.add (effs, name)
202 else effs)
203 IS.empty
204 file
205
206
207 (*********************************)
208 (* Boolean Formula Normalization *)
209 (*********************************)
210
211 datatype junctionType = Conj | Disj
212
213 datatype 'atom formula =
214 Atom of 'atom
215 | Negate of 'atom formula
216 | Combo of junctionType * 'atom formula list
217
218 (* Guaranteed to have all negation pushed to the atoms. *)
219 datatype 'atom formula' =
220 Atom' of 'atom
221 | Combo' of junctionType * 'atom formula' list
222
223 val flipJt = fn Conj => Disj | Disj => Conj
224
225 (* Pushes all negation to the atoms.*)
226 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
227 fn Atom x => Atom' (normalizeAtom (negating, x))
228 | Negate f => pushNegate normalizeAtom (not negating) f
229 | Combo (j, fs) => Combo' (if negating then flipJt j else j,
230 map (pushNegate normalizeAtom negating) fs)
231
232 val rec flatten =
233 fn Combo' (_, [f]) => flatten f
234 | Combo' (j, fs) =>
235 Combo' (j, List.foldr (fn (f, acc) =>
236 case f of
237 Combo' (j', fs') =>
238 if j = j' orelse length fs' = 1
239 then fs' @ acc
240 else f :: acc
241 | _ => f :: acc)
242 []
243 (map flatten fs))
244 | f => f
245
246 (* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj],
247 consider the list of lists to be a disjunction of conjunctions. *)
248 fun normalize' (simplify : 'a list list -> 'a list list)
249 (junc : junctionType) =
250 let
251 fun norm junc =
252 simplify
253 o (fn Atom' x => [[x]]
254 | Combo' (j, fs) =>
255 let
256 val fss = map (norm junc) fs
257 in
258 if j = junc
259 then List.concat fss
260 else map List.concat (cartesianProduct fss)
261 end)
262 in
263 norm junc
264 end
265
266 fun normalize simplify normalizeAtom junc =
267 normalize' simplify junc
268 o flatten
269 o pushNegate normalizeAtom false
270
271 fun mapFormula mf =
272 fn Atom x => Atom (mf x)
273 | Negate f => Negate (mapFormula mf f)
274 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs)
275
276 fun mapFormulaExps mf = mapFormula (fn (cmp, e1, e2) => (cmp, mf e1, mf e2))
277
278
279 (****************)
280 (* SQL Analysis *)
281 (****************)
282
283 structure CmpKey = struct
284
285 type ord_key = Sql.cmp
286
287 val compare =
288 fn (Sql.Eq, Sql.Eq) => EQUAL
289 | (Sql.Eq, _) => LESS
290 | (_, Sql.Eq) => GREATER
291 | (Sql.Ne, Sql.Ne) => EQUAL
292 | (Sql.Ne, _) => LESS
293 | (_, Sql.Ne) => GREATER
294 | (Sql.Lt, Sql.Lt) => EQUAL
295 | (Sql.Lt, _) => LESS
296 | (_, Sql.Lt) => GREATER
297 | (Sql.Le, Sql.Le) => EQUAL
298 | (Sql.Le, _) => LESS
299 | (_, Sql.Le) => GREATER
300 | (Sql.Gt, Sql.Gt) => EQUAL
301 | (Sql.Gt, _) => LESS
302 | (_, Sql.Gt) => GREATER
303 | (Sql.Ge, Sql.Ge) => EQUAL
304
305 end
306
307 val rec chooseTwos : 'a list -> ('a * 'a) list =
308 fn [] => []
309 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
310
311 fun removeRedundant madeRedundantBy zs =
312 let
313 fun removeRedundant' (xs, ys) =
314 case xs of
315 [] => ys
316 | x :: xs' =>
317 removeRedundant' (xs',
318 if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys)
319 then ys
320 else x :: ys)
321 in
322 removeRedundant' (zs, [])
323 end
324
325 datatype atomExp =
326 True
327 | False
328 | QueryArg of int
329 | DmlRel of int
330 | Prim of Prim.t
331 | Field of string * string
332
333 structure AtomExpKey : ORD_KEY = struct
334
335 type ord_key = atomExp
336
337 val compare =
338 fn (True, True) => EQUAL
339 | (True, _) => LESS
340 | (_, True) => GREATER
341 | (False, False) => EQUAL
342 | (False, _) => LESS
343 | (_, False) => GREATER
344 | (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
345 | (QueryArg _, _) => LESS
346 | (_, QueryArg _) => GREATER
347 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
348 | (DmlRel _, _) => LESS
349 | (_, DmlRel _) => GREATER
350 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
351 | (Prim _, _) => LESS
352 | (_, Prim _) => GREATER
353 | (Field (t1, f1), Field (t2, f2)) =>
354 case String.compare (t1, t2) of
355 EQUAL => String.compare (f1, f2)
356 | ord => ord
357
358 end
359
360 structure AtomOptionKey = OptionKeyFn(AtomExpKey)
361
362 val rec tablesOfQuery =
363 fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems)
364 | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2)
365 and tableOfFitem =
366 fn Sql.Table (t, _) => SS.singleton t
367 | Sql.Nested (q, _) => tablesOfQuery q
368 | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2)
369
370 val tableOfDml =
371 fn Sql.Insert (tab, _) => tab
372 | Sql.Delete (tab, _) => tab
373 | Sql.Update (tab, _, _) => tab
374
375 val freeVars =
376 MonoUtil.Exp.foldB
377 {typ = #2,
378 exp = fn (bound, ERel n, vars) => if n < bound
379 then vars
380 else IS.add (vars, n - bound)
381 | (_, _, vars) => vars,
382 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1
383 | (bound, _) => bound}
384 0
385 IS.empty
386
387 (* A path is a number of field projections of a variable. *)
388 type path = int * string list
389 structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK))
390 structure PS = BinarySetFn(PK)
391
392 val pathOfExp =
393 let
394 fun readFields acc exp =
395 acc
396 <\obind\>
397 (fn fs =>
398 case #1 exp of
399 ERel n => SOME (n, fs)
400 | EField (exp, f) => readFields (SOME (f::fs)) exp
401 | _ => NONE)
402 in
403 readFields (SOME [])
404 end
405
406 fun expOfPath (n, fs) =
407 List.foldl (fn (f, exp) => (EField (exp, f), dummyLoc)) (ERel n, dummyLoc) fs
408
409 fun freePaths'' bound exp paths =
410 case pathOfExp (exp, dummyLoc) of
411 NONE => paths
412 | SOME (n, fs) => if n < bound then paths else PS.add (paths, (n - bound, fs))
413
414 (* ASK: nicer way? :( *)
415 fun freePaths' bound exp =
416 case #1 exp of
417 EPrim _ => id
418 | e as ERel _ => freePaths'' bound e
419 | ENamed _ => id
420 | ECon (_, _, data) => (case data of NONE => id | SOME e => freePaths' bound e)
421 | ENone _ => id
422 | ESome (_, e) => freePaths' bound e
423 | EFfi _ => id
424 | EFfiApp (_, _, args) =>
425 List.foldl (fn ((e, _), acc) => freePaths' bound e o acc) id args
426 | EApp (e1, e2) => freePaths' bound e1 o freePaths' bound e2
427 | EAbs (_, _, _, e) => freePaths' (bound + 1) e
428 | EUnop (_, e) => freePaths' bound e
429 | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2
430 | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields
431 | e as EField _ => freePaths'' bound e
432 | ECase (e, cases, _) =>
433 List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc)
434 (freePaths' bound e)
435 cases
436 | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2
437 | EError (e, _) => freePaths' bound e
438 | EReturnBlob {blob, mimeType = e, ...} =>
439 freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e)
440 | ERedirect (e, _) => freePaths' bound e
441 | EWrite e => freePaths' bound e
442 | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2
443 | ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2
444 | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es
445 | EQuery {query = e1, body = e2, initial = e3, ...} =>
446 freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3
447 | EDml (e, _) => freePaths' bound e
448 | ENextval e => freePaths' bound e
449 | ESetval (e1, e2) => freePaths' bound e1 o freePaths' bound e2
450 | EUnurlify (e, _, _) => freePaths' bound e
451 | EJavaScript (_, e) => freePaths' bound e
452 | ESignalReturn e => freePaths' bound e
453 | ESignalBind (e1, e2) => freePaths' bound e1 o freePaths' bound e2
454 | ESignalSource e => freePaths' bound e
455 | EServerCall (e, _, _, _) => freePaths' bound e
456 | ERecv (e, _) => freePaths' bound e
457 | ESleep e => freePaths' bound e
458 | ESpawn e => freePaths' bound e
459
460 fun freePaths exp = freePaths' 0 exp PS.empty
461
462 datatype unbind = Known of exp | Unknowns of int
463
464 datatype cacheArg = AsIs of exp | Urlify of exp
465
466 structure InvalInfo :> sig
467 type t
468 type state = {tableToIndices : SIMM.multimap,
469 indexToInvalInfo : (t * int) IntBinaryMap.map,
470 ffiInfo : {index : int, params : int} list,
471 index : int}
472 val empty : t
473 val singleton : Sql.query -> t
474 val query : t -> Sql.query
475 val orderArgs : t * Mono.exp -> cacheArg list option
476 val unbind : t * unbind -> t option
477 val union : t * t -> t
478 val updateState : t * int * state -> state
479 end = struct
480
481 (* Variable, field projections, possible wrapped sqlification FFI call. *)
482 type sqlArg = path * (string * string * typ) option
483
484 type subst = sqlArg IM.map
485
486 (* TODO: store free variables as well? *)
487 type t = (Sql.query * subst) list
488
489 type state = {tableToIndices : SIMM.multimap,
490 indexToInvalInfo : (t * int) IntBinaryMap.map,
491 ffiInfo : {index : int, params : int} list,
492 index : int}
493
494 structure AK = PairKeyFn(
495 structure I = PK
496 structure J = OptionKeyFn(TripleKeyFn(
497 structure I = SK
498 structure J = SK
499 structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end)))
500 structure AS = BinarySetFn(AK)
501 structure AM = BinaryMapFn(AK)
502
503 (* Traversal Utilities *)
504 (* TODO: get rid of unused ones. *)
505
506 (* Need lift', etc. because we don't have rank-2 polymorphism. This should
507 probably use a functor (an ML one, not Haskell) but works for now. *)
508 fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f =
509 let
510 val rec tr =
511 fn Sql.SqNot se => lift Sql.SqNot (tr se)
512 | Sql.Binop (r, se1, se2) =>
513 lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2)
514 | Sql.SqKnown se => lift Sql.SqKnown (tr se)
515 | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e')
516 | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se)
517 | se => pure se
518 in
519 tr
520 end
521
522 fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f =
523 let
524 val rec tr =
525 fn Sql.Table t => pure''' (Sql.Table t)
526 | Sql.Join (jt, fi1, fi2, se) =>
527 lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse))
528 (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se)
529 | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s))
530 (traverseQuery ops f q)
531 in
532 tr
533 end
534
535 and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f =
536 let
537 val rec seqList =
538 fn [] => pure'' []
539 | (x::xs) => lift2''' op:: (x, seqList xs)
540 val rec tr =
541 fn Sql.Query1 q =>
542 (* TODO: make sure we don't need to traverse [#Select q]. *)
543 lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q,
544 From = trfrom,
545 Where = trwher})
546 (seqList (map (traverseFitem ops f) (#From q)),
547 case #Where q of
548 NONE => pure' NONE
549 | SOME se => lift'' SOME (traverseSqexp ops f se))
550 | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2)
551 in
552 tr
553 end
554
555 (* Include unused tuple elements in argument for convenience of using same
556 argument as [traverseQuery]. *)
557 fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f =
558 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v)))
559 (pure IM.empty)
560
561 fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f =
562 let
563 fun mp ((n, fields), sqlify) =
564 lift (fn ((n', fields'), sqlify') =>
565 let
566 fun wrap sq = ((n', fields' @ fields), sq)
567 in
568 case (fields', sqlify', fields, sqlify) of
569 (_, NONE, _, NONE) => wrap NONE
570 | (_, NONE, _, sq as SOME _) => wrap sq
571 (* Last case should suffice because we don't
572 project from a sqlified value (which is a
573 string). *)
574 | (_, sq as SOME _, [], NONE) => wrap sq
575 | _ => raise Fail "Sqlcache: traverseSubst"
576 end)
577 (f n)
578 in
579 traverseIM ops (fn (_, v) => mp v)
580 end
581
582 fun monoidOps plus zero =
583 (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero,
584 fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x,
585 fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus)
586
587 val optionOps = (SOME, SOME, SOME, SOME,
588 omap, omap, omap, omap,
589 omap2, omap2, omap2, omap2, omap2, omap2)
590
591 fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero)
592 val omapQuery = traverseQuery optionOps
593 fun foldMapIM plus zero = traverseIM (monoidOps plus zero)
594 fun omapIM f = traverseIM optionOps f
595 fun foldMapSubst plus zero = traverseSubst (monoidOps plus zero)
596 fun omapSubst f = traverseSubst optionOps f
597
598 val varsOfQuery = foldMapQuery IS.union
599 IS.empty
600 (fn e' => freeVars (e', dummyLoc))
601
602 fun varsOfSubst subst = foldMapSubst IS.union IS.empty IS.singleton subst
603
604 val varsOfList =
605 fn [] => IS.empty
606 | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs)
607
608 (* Signature Implementation *)
609
610 val empty = []
611
612 fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE)))
613 IM.empty
614 (varsOfQuery q))]
615
616 val union = op@
617
618 fun sqlArgsSet (q, subst) =
619 IM.foldl AS.add' AS.empty subst
620
621 fun sqlArgsMap (qs : t) =
622 let
623 val args =
624 List.foldl (fn ((q, subst), acc) =>
625 IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst)
626 AM.empty
627 qs
628 val countRef = ref (~1)
629 fun count () = (countRef := !countRef + 1; !countRef)
630 in
631 (* Maps each arg to a different consecutive integer, starting from 0. *)
632 AM.map count args
633 end
634
635 fun expOfArg (path, sqlify) =
636 let
637 val exp = expOfPath path
638 in
639 case sqlify of
640 NONE => exp
641 | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc)
642 end
643
644 fun orderArgs (qs : t, exp) =
645 let
646 val paths = freePaths exp
647 fun erel n = (ERel n, dummyLoc)
648 val argsMap = sqlArgsMap qs
649 val args = map (expOfArg o #1) (AM.listItemsi argsMap)
650 val invalPaths = List.foldl PS.union PS.empty (map freePaths args)
651 (* TODO: make sure these variables are okay to remove from the argument list. *)
652 val pureArgs = PS.difference (paths, invalPaths)
653 val shouldCache =
654 case getHeuristic () of
655 Smart =>
656 (case (qs, PS.numItems pureArgs) of
657 ((q::qs), 0) =>
658 let
659 val args = sqlArgsSet q
660 val argss = map sqlArgsSet qs
661 fun test (args, acc) =
662 acc
663 <\obind\>
664 (fn args' =>
665 let
666 val both = AS.union (args, args')
667 in
668 (AS.numItems args = AS.numItems both
669 orelse AS.numItems args' = AS.numItems both)
670 <\oguard\>
671 (fn _ => SOME both)
672 end)
673 in
674 case List.foldl test (SOME args) argss of
675 NONE => false
676 | SOME _ => true
677 end
678 | _ => false)
679 | Always => true
680 | Never => (case qs of [_] => PS.numItems pureArgs = 0 | _ => false)
681 | NoPureAll => (case qs of [] => false | _ => true)
682 | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0)
683 | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0
684 in
685 (* Put arguments we might invalidate by first. *)
686 if shouldCache
687 then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs))
688 else NONE
689 end
690
691 (* As a kludge, we rename the variables in the query to correspond to the
692 argument of the cache they're part of. *)
693 fun query (qs : t) =
694 let
695 val argsMap = sqlArgsMap qs
696 fun substitute subst =
697 fn ERel n => IM.find (subst, n)
698 <\obind\>
699 (fn arg =>
700 AM.find (argsMap, arg)
701 <\obind\>
702 (fn n' => SOME (ERel n')))
703 | _ => raise Fail "Sqlcache: query (a)"
704 in
705 case (map #1 qs) of
706 (q :: qs) =>
707 let
708 val q = List.foldl Sql.Union q qs
709 val ns = IS.listItems (varsOfQuery q)
710 val rename =
711 fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns)
712 | _ => raise Fail "Sqlcache: query (b)"
713 in
714 case omapQuery rename q of
715 SOME q => q
716 (* We should never get NONE because indexOf should never fail. *)
717 | NONE => raise Fail "Sqlcache: query (c)"
718 end
719 (* We should never reach this case because [updateState] won't
720 put anything in the state if there are no queries. *)
721 | [] => raise Fail "Sqlcache: query (d)"
722 end
723
724 val argOfExp =
725 let
726 fun doFields acc exp =
727 acc
728 <\obind\>
729 (fn (fs, sqlify) =>
730 case #1 exp of
731 ERel n => SOME (n, fs, sqlify)
732 | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp
733 | _ => NONE)
734 in
735 fn (EFfiApp ("Basis", x, [(exp, typ)]), _) =>
736 if String.isPrefix "sqlify" x
737 then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp)
738 else NONE
739 | exp => omap (fn path => (path, NONE)) (pathOfExp exp)
740 end
741
742 val unbind1 =
743 fn Known e =>
744 let
745 val replacement = argOfExp e
746 in
747 omapSubst (fn 0 => replacement
748 | n => SOME ((n-1, []), NONE))
749 end
750 | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE))
751
752 fun unbind (qs, ub) =
753 case ub of
754 (* Shortcut if nothing's changing. *)
755 Unknowns 0 => SOME qs
756 | _ => osequence (map (fn (q, subst) => unbind1 ub subst
757 <\obind\>
758 (fn subst' => SOME (q, subst'))) qs)
759
760 fun updateState (qs, numArgs, state as {index, ...} : state) =
761 {tableToIndices = List.foldr (fn ((q, _), acc) =>
762 SS.foldl (fn (tab, acc) =>
763 SIMM.insert (acc, tab, index))
764 acc
765 (tablesOfQuery q))
766 (#tableToIndices state)
767 qs,
768 indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)),
769 ffiInfo = {index = index, params = numArgs} :: #ffiInfo state,
770 index = index + 1}
771
772 end
773
774 structure UF = UnionFindFn(AtomExpKey)
775
776 val rec sqexpToFormula =
777 fn Sql.SqTrue => Combo (Conj, [])
778 | Sql.SqFalse => Combo (Disj, [])
779 | Sql.SqNot e => Negate (sqexpToFormula e)
780 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
781 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
782 [sqexpToFormula p1, sqexpToFormula p2])
783 | e as Sql.Field f => Atom (Sql.Eq, e, Sql.SqTrue)
784 (* ASK: any other sqexps that can be props? *)
785 | Sql.SqConst prim =>
786 (case prim of
787 (Prim.String (Prim.Normal, s)) =>
788 if s = #trueString (Settings.currentDbms ())
789 then Combo (Conj, [])
790 else if s = #falseString (Settings.currentDbms ())
791 then Combo (Disj, [])
792 else raise Fail "Sqlcache: sqexpToFormula (SqConst a)"
793 | _ => raise Fail "Sqlcache: sqexpToFormula (SqConst b)")
794 | Sql.Computed _ => raise Fail "Sqlcache: sqexpToFormula (Computed)"
795 | Sql.SqKnown _ => raise Fail "Sqlcache: sqexpToFormula (SqKnown)"
796 | Sql.Inj _ => raise Fail "Sqlcache: sqexpToFormula (Inj)"
797 | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)"
798 | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)"
799 | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)"
800
801 fun mapSqexpFields f =
802 fn Sql.Field (t, v) => f (t, v)
803 | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e)
804 | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2)
805 | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e)
806 | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e)
807 | e => e
808
809 fun renameTables tablePairs =
810 let
811 fun rename table =
812 case List.find (fn (_, t) => table = t) tablePairs of
813 NONE => table
814 | SOME (realTable, _) => realTable
815 in
816 mapSqexpFields (fn (t, f) => Sql.Field (rename t, f))
817 end
818
819 structure FlattenQuery = struct
820
821 datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map
822
823 fun applySubst substTable =
824 let
825 fun substitute (table, field) =
826 case SM.find (substTable, table) of
827 NONE => Sql.Field (table, field)
828 | SOME (RenameTable realTable) => Sql.Field (realTable, field)
829 | SOME (SubstituteExp substField) =>
830 case SM.find (substField, field) of
831 NONE => raise Fail "Sqlcache: applySubst"
832 | SOME se => se
833 in
834 mapSqexpFields substitute
835 end
836
837 fun addToSubst (substTable, table, substField) =
838 SM.insert (substTable,
839 table,
840 case substField of
841 RenameTable _ => substField
842 | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst))
843
844 fun newSubst (t, s) = addToSubst (SM.empty, t, s)
845
846 datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp
847
848 type queryFlat = {Select : sitem' list, Where : Sql.sqexp}
849
850 val sitemsToSubst =
851 List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se)
852 | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst")
853 SM.empty
854
855 fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2)
856
857 fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2)
858
859 val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list =
860 fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))]
861 | Sql.Nested (q, s) =>
862 let
863 val qfs = flattenQuery q
864 in
865 map (fn (qf, subst) =>
866 (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf)))))
867 qfs
868 end
869 | Sql.Join (jt, fi1, fi2, se) =>
870 concatMap (fn ((wher1, subst1)) =>
871 map (fn (wher2, subst2) =>
872 let
873 val subst = unionSubst (subst1, subst2)
874 in
875 (* ON clause becomes part of the accumulated WHERE. *)
876 (sqlAnd (sqlAnd (wher1, wher2), applySubst subst se), subst)
877 end)
878 (flattenFitem fi2))
879 (flattenFitem fi1)
880
881 and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list =
882 fn Sql.Query1 q =>
883 let
884 val fifss = cartesianProduct (map flattenFitem (#From q))
885 in
886 map (fn fifs =>
887 let
888 val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst))
889 SM.empty
890 fifs
891 val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc))
892 (case #Where q of
893 NONE => Sql.SqTrue
894 | SOME wher => wher)
895 fifs
896 in
897 (* ASK: do we actually need to pass the substitution through here? *)
898 (* We use the substitution later, but it's not clear we
899 need any of its currently present fields again. *)
900 ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s)
901 | Sql.SqField tf =>
902 Unnamed (applySubst subst (Sql.Field tf)))
903 (#Select q),
904 Where = applySubst subst wher},
905 subst)
906 end)
907 fifss
908 end
909 | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2)
910
911 end
912
913 val flattenQuery = map #1 o FlattenQuery.flattenQuery
914
915 fun queryFlatToFormula marker {Select = sitems, Where = wher} =
916 let
917 val fWhere = sqexpToFormula wher
918 in
919 case marker of
920 NONE => fWhere
921 | SOME markFields =>
922 let
923 val fWhereMarked = mapFormulaExps markFields fWhere
924 val toSqexp =
925 fn FlattenQuery.Named (se, _) => se
926 | FlattenQuery.Unnamed se => se
927 fun ineq se = Atom (Sql.Ne, se, markFields se)
928 val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems)
929 in
930 (Combo (Conj,
931 [fWhere,
932 Combo (Disj,
933 [Negate fWhereMarked,
934 Combo (Conj, [fWhereMarked, fIneqs])])]))
935 end
936 end
937
938 fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q))
939
940 fun valsToFormula (markLeft, markRight) (table, vals) =
941 Combo (Conj,
942 map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v))
943 vals)
944
945 (* TODO: verify logic for insertion and deletion. *)
946 val rec dmlToFormulaMarker =
947 fn Sql.Insert (table, vals) => (valsToFormula (id, id) (table, vals), NONE)
948 | Sql.Delete (table, wher) => (sqexpToFormula (renameTables [(table, "T")] wher), NONE)
949 | Sql.Update (table, vals, wher) =>
950 let
951 val fWhere = sqexpToFormula (renameTables [(table, "T")] wher)
952 fun fVals marks = valsToFormula marks (table, vals)
953 val modifiedFields = SS.addList (SS.empty, map #1 vals)
954 (* TODO: don't use field name hack. *)
955 val markFields =
956 mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v)
957 then Sql.Field (t, v ^ "'")
958 else Sql.Field (t, v))
959 val mark = mapFormulaExps markFields
960 in
961 ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]),
962 Combo (Conj, [fVals (markFields, id), fWhere])])),
963 SOME markFields)
964 end
965
966 fun pairToFormulas (query, dml) =
967 let
968 val (fDml, marker) = dmlToFormulaMarker dml
969 in
970 (queryToFormula marker query, fDml)
971 end
972
973 structure ConflictMaps = struct
974
975 structure TK = TripleKeyFn(structure I = CmpKey
976 structure J = AtomOptionKey
977 structure K = AtomOptionKey)
978
979 structure TS : ORD_SET = BinarySetFn(TK)
980
981 val toKnownEquality =
982 (* [NONE] here means unkown. Anything that isn't a comparison between two
983 knowns shouldn't be used, and simply dropping unused terms is okay in
984 disjunctive normal form. *)
985 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
986 | _ => NONE
987
988 fun equivClasses atoms : atomExp list list option =
989 let
990 val uf = List.foldl UF.union' UF.empty (List.mapPartial toKnownEquality atoms)
991 val contradiction =
992 fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt)
993 andalso UF.together (uf, ae1, ae2)
994 (* If we don't know one side of the comparision, not a contradiction. *)
995 | _ => false
996 in
997 not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf))
998 end
999
1000 fun addToEqs (eqs, n, e) =
1001 case IM.find (eqs, n) of
1002 (* Comparing to a constant is probably better than comparing to a
1003 variable? Checking that existing constants match a new ones is
1004 handled by [accumulateEqs]. *)
1005 SOME (Prim _) => eqs
1006 | _ => IM.insert (eqs, n, e)
1007
1008 val accumulateEqs =
1009 (* [NONE] means we have a contradiction. *)
1010 fn (_, NONE) => NONE
1011 | ((Prim p1, Prim p2), eqso) =>
1012 (case Prim.compare (p1, p2) of
1013 EQUAL => eqso
1014 | _ => NONE)
1015 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
1016 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
1017 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
1018 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
1019 (* TODO: deal with equalities between [DmlRel]s and [Prim]s.
1020 This would involve guarding the invalidation with a check for the
1021 relevant comparisons. *)
1022 | (_, eqso) => eqso
1023
1024 val eqsOfClass : atomExp list -> atomExp IM.map option =
1025 List.foldl accumulateEqs (SOME IM.empty)
1026 o chooseTwos
1027
1028 fun toAtomExps rel (cmp, e1, e2) =
1029 let
1030 val qa =
1031 (* Here [NONE] means unkown. *)
1032 fn Sql.SqConst p => SOME (Prim p)
1033 | Sql.Field tf => SOME (Field tf)
1034 | Sql.Inj (EPrim p, _) => SOME (Prim p)
1035 | Sql.Inj (ERel n, _) => SOME (rel n)
1036 (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
1037 becomes Sql.Unmodeled, which becomes NONE here. *)
1038 | _ => NONE
1039 in
1040 (cmp, qa e1, qa e2)
1041 end
1042
1043 val negateCmp =
1044 fn Sql.Eq => Sql.Ne
1045 | Sql.Ne => Sql.Eq
1046 | Sql.Lt => Sql.Ge
1047 | Sql.Le => Sql.Gt
1048 | Sql.Gt => Sql.Le
1049 | Sql.Ge => Sql.Lt
1050
1051 fun normalizeAtom (negating, (cmp, e1, e2)) =
1052 (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with
1053 simplification, where we put the triples in sets. *)
1054 case (if negating then negateCmp cmp else cmp) of
1055 Sql.Eq => (case AtomOptionKey.compare (e1, e2) of
1056 LESS => (Sql.Eq, e2, e1)
1057 | _ => (Sql.Eq, e1, e2))
1058 | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of
1059 LESS => (Sql.Ne, e2, e1)
1060 | _ => (Sql.Ne, e1, e2))
1061 | Sql.Lt => (Sql.Lt, e1, e2)
1062 | Sql.Le => (Sql.Le, e1, e2)
1063 | Sql.Gt => (Sql.Lt, e2, e1)
1064 | Sql.Ge => (Sql.Le, e2, e1)
1065
1066 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
1067 (Sql.cmp * atomExp option * atomExp option) formula =
1068 mapFormula (toAtomExps QueryArg)
1069
1070 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
1071 (Sql.cmp * atomExp option * atomExp option) formula =
1072 mapFormula (toAtomExps DmlRel)
1073
1074 (* No eqs should have key conflicts because no variable is in two
1075 equivalence classes. *)
1076 val mergeEqs : (atomExp IntBinaryMap.map option list
1077 -> atomExp IntBinaryMap.map option) =
1078 List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs")))
1079 (SOME IM.empty)
1080
1081 val simplify =
1082 map TS.listItems
1083 o removeRedundant (fn (x, y) => TS.isSubset (y, x))
1084 o map (fn xs => TS.addList (TS.empty, xs))
1085
1086 fun dnf (fQuery, fDml) =
1087 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
1088
1089 val conflictMaps =
1090 List.mapPartial (mergeEqs o map eqsOfClass)
1091 o List.mapPartial equivClasses
1092 o dnf
1093
1094 end
1095
1096 val conflictMaps = ConflictMaps.conflictMaps
1097
1098
1099 (*************************************)
1100 (* Program Instrumentation Utilities *)
1101 (*************************************)
1102
1103 val {check, store, flush, lock, ...} = getCache ()
1104
1105 val dummyTyp = (TRecord [], dummyLoc)
1106
1107 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
1108
1109 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
1110
1111 val sequence =
1112 fn (exp :: exps) =>
1113 let
1114 val loc = dummyLoc
1115 in
1116 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
1117 end
1118 | _ => raise Fail "Sqlcache: sequence"
1119
1120 (* Always increments negative indices as a hack we use later. *)
1121 fun incRels inc =
1122 MonoUtil.Exp.mapB
1123 {typ = fn t' => t',
1124 exp = fn bound =>
1125 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
1126 | e' => e'),
1127 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
1128 0
1129
1130 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
1131 let
1132 fun doVal env ((x, n, t, exp, s), state) =
1133 let
1134 val (exp, state) = doTopLevelExp env exp state
1135 in
1136 ((x, n, t, exp, s), state)
1137 end
1138 fun doDecl' env (decl', state) =
1139 case decl' of
1140 DVal v =>
1141 let
1142 val (v, state) = doVal env (v, state)
1143 in
1144 (DVal v, state)
1145 end
1146 | DValRec vs =>
1147 let
1148 val (vs, state) = ListUtil.foldlMap (doVal env) state vs
1149 in
1150 (DValRec vs, state)
1151 end
1152 | _ => (decl', state)
1153 fun doDecl (decl as (decl', loc), (env, state)) =
1154 let
1155 val env = MonoEnv.declBinds env decl
1156 val (decl', state) = doDecl' env (decl', state)
1157 in
1158 ((decl', loc), (env, state))
1159 end
1160 val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
1161 in
1162 ((decls, sideInfo), state)
1163 end
1164
1165 fun fileAllMapfoldB doExp file start =
1166 case MonoUtil.File.mapfoldB
1167 {typ = Search.return2,
1168 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
1169 decl = fn _ => Search.return2,
1170 bind = doBind}
1171 MonoEnv.empty file start of
1172 Search.Continue x => x
1173 | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB"
1174
1175 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
1176
1177 (* TODO: make this a bit prettier.... *)
1178 (* TODO: factour out identical subexpressions to the same variable.... *)
1179 val simplifySql =
1180 let
1181 fun factorOutNontrivial text =
1182 let
1183 val loc = dummyLoc
1184 val strcat =
1185 fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1
1186 | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2
1187 | (e1, e2) => (EStrcat (e1, e2), loc)
1188 val chunks = Sql.chunkify text
1189 val (newText, newVariables) =
1190 (* Important that this is foldr (to oppose foldl below). *)
1191 List.foldr
1192 (fn (chunk, (qText, newVars)) =>
1193 (* Variable bound to the head of newVars will have the lowest index. *)
1194 case chunk of
1195 (* EPrim should always be a string in this case. *)
1196 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
1197 | Sql.Exp e =>
1198 let
1199 val n = length newVars
1200 in
1201 (* This is the (n+1)th new variable, so there are
1202 already n new variables bound, so we increment
1203 indices by n. *)
1204 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
1205 end
1206 | Sql.String s => (strcat (stringExp s, qText), newVars))
1207 (stringExp "", [])
1208 chunks
1209 fun wrapLets e' =
1210 (* Important that this is foldl (to oppose foldr above). *)
1211 List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc)))
1212 e'
1213 newVariables
1214 val numArgs = length newVariables
1215 in
1216 (newText, wrapLets, numArgs)
1217 end
1218 fun doExp exp' =
1219 let
1220 val text = case exp' of
1221 EQuery {query = text, ...} => text
1222 | EDml (text, _) => text
1223 | _ => raise Fail "Sqlcache: simplifySql (a)"
1224 val (newText, wrapLets, numArgs) = factorOutNontrivial text
1225 val newExp' = case exp' of
1226 EQuery q => EQuery {query = newText,
1227 exps = #exps q,
1228 tables = #tables q,
1229 state = #state q,
1230 body = #body q,
1231 initial = #initial q}
1232 | EDml (_, failureMode) => EDml (newText, failureMode)
1233 | _ => raise Fail "Sqlcache: simplifySql (b)"
1234 in
1235 (* Increment once for each new variable just made. This is
1236 where we use the negative De Bruijn indices hack. *)
1237 (* TODO: please don't use that hack. As anyone could have
1238 predicted, it was incomprehensible a year later.... *)
1239 wrapLets (#1 (incRels numArgs (newExp', dummyLoc)))
1240 end
1241 in
1242 fileMap (fn exp' => case exp' of
1243 EQuery _ => doExp exp'
1244 | EDml _ => doExp exp'
1245 | _ => exp')
1246 end
1247
1248
1249 (**********************)
1250 (* Mono Type Checking *)
1251 (**********************)
1252
1253 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
1254 fn EPrim p => SOME (TFfi ("Basis", case p of
1255 Prim.Int _ => "int"
1256 | Prim.Float _ => "double"
1257 | Prim.String _ => "string"
1258 | Prim.Char _ => "char"),
1259 dummyLoc)
1260 | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
1261 | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
1262 (* ASK: okay to make a new [ref] each time? *)
1263 | ECon (dk, PConVar nCon, _) =>
1264 let
1265 val (_, _, nData) = MonoEnv.lookupConstructor env nCon
1266 val (_, cs) = MonoEnv.lookupDatatype env nData
1267 in
1268 SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
1269 end
1270 | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
1271 | ENone t => SOME (TOption t, dummyLoc)
1272 | ESome (t, _) => SOME (TOption t, dummyLoc)
1273 | EFfi _ => NONE
1274 | EFfiApp _ => NONE
1275 | EApp (e1, e2) => (case typOfExp env e1 of
1276 SOME (TFun (_, t), _) => SOME t
1277 | _ => NONE)
1278 | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
1279 (* ASK: is this right? *)
1280 | EUnop (unop, e) => (case unop of
1281 "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
1282 | "-" => typOfExp env e
1283 | _ => NONE)
1284 (* ASK: how should this (and other "=> NONE" cases) work? *)
1285 | EBinop _ => NONE
1286 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
1287 | EField (e, s) => (case typOfExp env e of
1288 SOME (TRecord fields, _) =>
1289 omap #2 (List.find (fn (s', _) => s = s') fields)
1290 | _ => NONE)
1291 | ECase (_, _, {result, ...}) => SOME result
1292 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
1293 | EWrite _ => SOME (TRecord [], dummyLoc)
1294 | ESeq (_, e) => typOfExp env e
1295 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
1296 | EClosure _ => NONE
1297 | EUnurlify (_, t, _) => SOME t
1298 | EQuery {state, ...} => SOME state
1299 | e => NONE
1300
1301 and typOfExp env (e', loc) = typOfExp' env e'
1302
1303
1304 (***********)
1305 (* Caching *)
1306 (***********)
1307
1308 type state = InvalInfo.state
1309
1310 datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp
1311
1312 val isImpure =
1313 fn Cachable _ => false
1314 | Impure _ => true
1315
1316 val runSubexp : subexp * state -> exp * state =
1317 fn (Cachable (_, f), state) => f state
1318 | (Impure e, state) => (e, state)
1319
1320 val invalInfoOfSubexp =
1321 fn Cachable (invalInfo, _) => invalInfo
1322 | Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp"
1323
1324 fun cacheWrap (env, exp, typ, args, index) =
1325 let
1326 val loc = dummyLoc
1327 val rel0 = (ERel 0, loc)
1328 in
1329 case MonoFooify.urlify env (rel0, typ) of
1330 NONE => NONE
1331 | SOME urlified =>
1332 let
1333 (* We ensure before this step that all arguments aren't effectful.
1334 by turning them into local variables as needed. *)
1335 val argsInc = map (incRels 1) args
1336 val check = (check (index, args), loc)
1337 val store = (store (index, argsInc, urlified), loc)
1338 in
1339 SOME (ECase (check,
1340 [((PNone stringTyp, loc),
1341 (ELet ("q", typ, exp, (ESeq (store, rel0), loc)), loc)),
1342 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
1343 (* Boolean is false because we're not unurlifying from a cookie. *)
1344 (EUnurlify (rel0, typ, false), loc))],
1345 {disc = (TOption stringTyp, loc), result = typ}))
1346 end
1347 end
1348
1349 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
1350
1351 (* TODO: pick a number. *)
1352 val sizeWorthCaching = 5
1353
1354 val worthCaching =
1355 fn EQuery _ => true
1356 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
1357
1358 fun cacheExp (env, exp', invalInfo, state : state) =
1359 case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of
1360 NONE => NONE
1361 | SOME (TFun _, _) => NONE
1362 | SOME typ =>
1363 InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
1364 <\obind\>
1365 (fn args =>
1366 List.foldr (fn (arg, acc) =>
1367 acc
1368 <\obind\>
1369 (fn args' =>
1370 (case arg of
1371 AsIs exp => SOME exp
1372 | Urlify exp =>
1373 typOfExp env exp
1374 <\obind\>
1375 (fn typ => (MonoFooify.urlify env (exp, typ))))
1376 <\obind\>
1377 (fn arg' => SOME (arg' :: args'))))
1378 (SOME [])
1379 args
1380 <\obind\>
1381 (fn args' =>
1382 cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
1383 <\obind\>
1384 (fn cachedExp =>
1385 SOME (cachedExp,
1386 InvalInfo.updateState (invalInfo, length args', state)))))
1387
1388 fun cacheQuery (effs, env, q) : subexp =
1389 let
1390 (* We use dummyTyp here. I think this is okay because databases don't
1391 store (effectful) functions, but perhaps there's some pathalogical
1392 corner case missing.... *)
1393 fun safe bound =
1394 not
1395 o effectful effs
1396 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
1397 bound
1398 env)
1399 val {query = queryText, initial, body, ...} = q
1400 val attempt =
1401 (* Ziv misses Haskell's do notation.... *)
1402 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
1403 <\oguard\>
1404 (fn _ =>
1405 Sql.parse Sql.query queryText
1406 <\obind\>
1407 (fn queryParsed =>
1408 let
1409 val invalInfo = InvalInfo.singleton queryParsed
1410 fun mkExp state =
1411 case cacheExp (env, EQuery q, invalInfo, state) of
1412 NONE => ((EQuery q, dummyLoc), state)
1413 | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state)
1414 in
1415 SOME (Cachable (invalInfo, mkExp))
1416 end))
1417 in
1418 case attempt of
1419 NONE => Impure (EQuery q, dummyLoc)
1420 | SOME subexp => subexp
1421 end
1422
1423 fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) =
1424 let
1425 fun wrapBindN (f : exp list -> exp')
1426 (args : ((MonoEnv.env * exp) * unbind) list) =
1427 let
1428 val (subexps, state) =
1429 ListUtil.foldlMap (cacheTree effs)
1430 state
1431 (map #1 args)
1432 fun mkExp state = mapFst (fn exps => (f exps, loc))
1433 (ListUtil.foldlMap runSubexp state subexps)
1434 val attempt =
1435 if List.exists isImpure subexps
1436 then NONE
1437 else (List.foldl (omap2 InvalInfo.union)
1438 (SOME InvalInfo.empty)
1439 (ListPair.map
1440 (fn (subexp, (_, unbinds)) =>
1441 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds))
1442 (subexps, args)))
1443 <\obind\>
1444 (fn invalInfo =>
1445 SOME (Cachable (invalInfo,
1446 fn state =>
1447 case cacheExp (env,
1448 f (map (#2 o #1) args),
1449 invalInfo,
1450 state) of
1451 NONE => mkExp state
1452 | SOME (e', state) => ((e', loc), state)),
1453 state))
1454 in
1455 case attempt of
1456 SOME (subexp, state) => (subexp, state)
1457 | NONE => mapFst Impure (mkExp state)
1458 end
1459 fun wrapBind1 f arg =
1460 wrapBindN (fn [arg] => f arg
1461 | _ => raise Fail "Sqlcache: cacheTree (a)") [arg]
1462 fun wrapBind2 f (arg1, arg2) =
1463 wrapBindN (fn [arg1, arg2] => f (arg1, arg2)
1464 | _ => raise Fail "Sqlcache: cacheTree (b)") [arg1, arg2]
1465 fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es)
1466 fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0)
1467 fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0))
1468 in
1469 case exp' of
1470 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
1471 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
1472 | EFfiApp (s1, s2, args) =>
1473 if ffiEffectful (s1, s2)
1474 then (Impure exp, state)
1475 else wrapN (fn es =>
1476 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
1477 (map #1 args)
1478 | EApp (e1, e2) => wrap2 EApp (e1, e2)
1479 | EAbs (s, t1, t2, e) =>
1480 wrapBind1 (fn e => EAbs (s, t1, t2, e))
1481 ((MonoEnv.pushERel env s t1 NONE, e), Unknowns 1)
1482 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
1483 | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
1484 | ERecord fields =>
1485 wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
1486 (map #2 fields)
1487 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
1488 | ECase (e, cases, {disc, result}) =>
1489 wrapBindN (fn (e::es) =>
1490 ECase (e,
1491 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
1492 {disc = disc, result = result})
1493 | _ => raise Fail "Sqlcache: cacheTree (c)")
1494 (((env, e), Unknowns 0)
1495 :: map (fn (p, e) =>
1496 ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p)))
1497 cases)
1498 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
1499 (* We record page writes, so they're cachable. *)
1500 | EWrite e => wrap1 EWrite e
1501 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
1502 | ELet (s, t, e1, e2) =>
1503 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
1504 (((env, e1), Unknowns 0),
1505 ((MonoEnv.pushERel env s t (SOME e1), e2), Known e1))
1506 (* ASK: | EClosure (n, es) => ? *)
1507 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
1508 | EQuery q => (cacheQuery (effs, env, q), state)
1509 | _ => (if effectful effs env exp
1510 then Impure exp
1511 else Cachable (InvalInfo.empty,
1512 fn state =>
1513 case cacheExp (env, exp', InvalInfo.empty, state) of
1514 NONE => ((exp', loc), state)
1515 | SOME (exp', state) => ((exp', loc), state)),
1516 state)
1517 end
1518
1519 fun addCaching file =
1520 let
1521 val effs = effectfulDecls file
1522 fun doTopLevelExp env exp state = runSubexp (cacheTree effs ((env, exp), state))
1523 in
1524 (fileTopLevelMapfoldB doTopLevelExp
1525 file
1526 {tableToIndices = SIMM.empty,
1527 indexToInvalInfo = IM.empty,
1528 ffiInfo = [],
1529 index = 0},
1530 effs)
1531 end
1532
1533
1534 (************)
1535 (* Flushing *)
1536 (************)
1537
1538 structure Invalidations = struct
1539
1540 val loc = dummyLoc
1541
1542 val optionAtomExpToExp =
1543 fn NONE => (ENone stringTyp, loc)
1544 | SOME e => (ESome (stringTyp,
1545 (case e of
1546 DmlRel n => ERel n
1547 | Prim p => EPrim p
1548 (* TODO: make new type containing only these two. *)
1549 | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp",
1550 loc)),
1551 loc)
1552
1553 fun eqsToInvalidation numArgs eqs =
1554 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
1555
1556 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
1557 represents unknown, which means a wider invalidation. *)
1558 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
1559 fn ([], []) => true
1560 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
1561 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
1562 EQUAL => madeRedundantBy (xs, ys)
1563 | _ => false)
1564 | _ => false
1565
1566 fun invalidations ((invalInfo, numArgs), dml) =
1567 let
1568 val query = InvalInfo.query invalInfo
1569 in
1570 (map (map optionAtomExpToExp)
1571 o removeRedundant madeRedundantBy
1572 o map (eqsToInvalidation numArgs)
1573 o conflictMaps)
1574 (pairToFormulas (query, dml))
1575 end
1576
1577 end
1578
1579 val invalidations = Invalidations.invalidations
1580
1581 fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) =
1582 let
1583 val flushes = List.concat
1584 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
1585 val doExp =
1586 fn dmlExp as EDml (dmlText, failureMode) =>
1587 let
1588 val inval =
1589 case Sql.parse Sql.dml dmlText of
1590 SOME dmlParsed =>
1591 SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of
1592 SOME invalInfo =>
1593 (i, invalidations (invalInfo, dmlParsed))
1594 (* TODO: fail more gracefully. *)
1595 (* This probably means invalidating everything.... *)
1596 | NONE => raise Fail "Sqlcache: addFlushing (a)"))
1597 (SIMM.findList (tableToIndices, tableOfDml dmlParsed)))
1598 | NONE => NONE
1599 in
1600 case inval of
1601 (* TODO: fail more gracefully. *)
1602 NONE => raise Fail "Sqlcache: addFlushing (b)"
1603 | SOME invs => sequence (flushes invs @ [dmlExp])
1604 end
1605 | e' => e'
1606 val file = fileMap doExp file
1607
1608 in
1609 ffiInfoRef := ffiInfo;
1610 file
1611 end
1612
1613
1614 (***********)
1615 (* Locking *)
1616 (***********)
1617
1618 (* TODO: do this less evilly by not relying on specific FFI names, please? *)
1619 fun locksNeeded (lockMap : {store : IIMM.multimap, flush : IIMM.multimap}) =
1620 MonoUtil.Exp.fold
1621 {typ = #2,
1622 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
1623 (case Int.fromString (String.extract (x, 5, NONE)) of
1624 NONE => state
1625 | SOME index =>
1626 if String.isPrefix "flush" x
1627 then {store = store, flush = IS.add (flush, index)}
1628 else if String.isPrefix "store" x
1629 then {store = IS.add (store, index), flush = flush}
1630 else state)
1631 | (ENamed n, {store, flush}) =>
1632 {store = IS.union (store, IIMM.findSet (#store lockMap, n)),
1633 flush = IS.union (flush, IIMM.findSet (#flush lockMap, n))}
1634 | (_, state) => state}
1635 {store = IS.empty, flush = IS.empty}
1636
1637 fun lockMapOfFile file =
1638 transitiveAnalysis
1639 (fn ((_, name, _, e, _), state) =>
1640 let
1641 val locks = locksNeeded state e
1642 in
1643 {store = IIMM.insertSet (#store state, name, #store locks),
1644 flush = IIMM.insertSet (#flush state, name, #flush locks)}
1645 end)
1646 {store = IIMM.empty, flush = IIMM.empty}
1647 file
1648
1649 fun exports (decls, _) =
1650 List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n)
1651 | (_, ns) => ns)
1652 IS.empty
1653 decls
1654
1655 fun wrapLocks (locks, (exp', loc)) =
1656 case exp' of
1657 EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc)
1658 | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc)
1659
1660 fun addLocking file =
1661 let
1662 val lockMap = lockMapOfFile file
1663 fun lockList {store, flush} =
1664 let
1665 val ls = map (fn i => (i, true)) (IS.listItems flush)
1666 @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush)))
1667 in
1668 ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls
1669 end
1670 fun locksOfName n =
1671 lockList {flush = IIMM.findSet (#flush lockMap, n),
1672 store = IIMM.findSet (#store lockMap, n)}
1673 val locksOfExp = lockList o locksNeeded lockMap
1674 val expts = exports file
1675 fun doVal (v as (x, n, t, exp, s)) =
1676 if IS.member (expts, n)
1677 then (x, n, t, wrapLocks ((locksOfName n), exp), s)
1678 else v
1679 val doDecl =
1680 fn (DVal v, loc) => (DVal (doVal v), loc)
1681 | (DValRec vs, loc) => (DValRec (map doVal vs), loc)
1682 | (DTask (exp1, exp2), loc) => (DTask (exp1, wrapLocks (locksOfExp exp2, exp2)), loc)
1683 | decl => decl
1684 in
1685 mapFst (map doDecl) file
1686 end
1687
1688
1689 (************************)
1690 (* Compiler Entry Point *)
1691 (************************)
1692
1693 val inlineSql =
1694 let
1695 val doExp =
1696 (* TODO: EQuery, too? *)
1697 (* ASK: should this live in [MonoOpt]? *)
1698 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
1699 let
1700 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
1701 in
1702 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
1703 end
1704 | e => e
1705 in
1706 fileMap doExp
1707 end
1708
1709 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
1710 let
1711 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
1712 in
1713 (datatypes @ newDecls @ others, sideInfo)
1714 end
1715
1716 val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql
1717
1718 fun go file =
1719 let
1720 (* TODO: do something nicer than [Sql] being in one of two modes. *)
1721 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
1722 val file = go' file
1723 (* Important that this happens after [MonoFooify.urlify] calls! *)
1724 val fmDecls = MonoFooify.getNewFmDecls ()
1725 val () = Sql.sqlcacheMode := false
1726 in
1727 insertAfterDatatypes (file, rev fmDecls)
1728 end
1729
1730 end