Mercurial > urweb
comparison src/sqlcache.sml @ 2248:e09c3dc102ef
Rewrite effectfulness analysis using MonoUtil.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Sat, 15 Aug 2015 23:08:37 -0700 |
parents | e4a7e3cd6f11 |
children | c275bbc41194 |
comparison
equal
deleted
inserted
replaced
2247:565da55a4e18 | 2248:e09c3dc102ef |
---|---|
41 | 41 |
42 val cache = ref LruCache.cache | 42 val cache = ref LruCache.cache |
43 fun setCache c = cache := c | 43 fun setCache c = cache := c |
44 fun getCache () = !cache | 44 fun getCache () = !cache |
45 | 45 |
46 | 46 (* Used to have type context for local variables in MonoUtil functions. *) |
47 (* Effect analysis. *) | 47 val doBind = |
48 fn (ctx, MonoUtil.Exp.RelE (_, t)) => t :: ctx | |
49 | (ctx, _) => ctx | |
50 | |
51 | |
52 (*******************) | |
53 (* Effect Analysis *) | |
54 (*******************) | |
48 | 55 |
49 (* Makes an exception for [EWrite] (which is recorded when caching). *) | 56 (* Makes an exception for [EWrite] (which is recorded when caching). *) |
50 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool = | 57 fun effectful (effs : IS.set) = |
51 (* If result is true, expression is definitely effectful. If result is | 58 let |
52 false, then expression is definitely not effectful if effs is fully | 59 val isFunction = |
53 populated. The intended pattern is to use this a number of times equal | 60 fn (TFun _, _) => true |
54 to the number of declarations in a file, Bellman-Ford style. *) | 61 | _ => false |
55 (* TODO: make incrementing of the number of bound variables cleaner, | 62 fun doExp (ctx, e) = |
56 probably by using [MonoUtil] instead of all this. *) | 63 case e of |
57 let | 64 EPrim _ => false |
58 (* DEBUG: remove printing when done. *) | 65 (* For now: variables of function type might be effectful, but |
59 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true | 66 others are fully evaluated and are therefore not effectful. *) |
60 val rec eff' = | 67 | ERel n => isFunction (List.nth (ctx, n)) |
61 (* ASK: is there a better way? *) | 68 | ENamed n => IS.member (effs, n) |
62 fn EPrim _ => false | 69 | EFfi (m, f) => ffiEffectful (m, f) |
63 (* We don't know if local functions have effects when applied. *) | 70 | EFfiApp (m, f, _) => ffiEffectful (m, f) |
64 | ERel idx => if inFunction andalso idx >= bound | 71 (* These aren't effectful unless a subexpression is. *) |
65 then tru ("rel" ^ Int.toString idx) else false | 72 | ECon _ => false |
66 | ENamed name => if IS.member (effs, name) then tru "named" else false | 73 | ENone _ => false |
67 | ECon (_, _, NONE) => false | 74 | ESome _ => false |
68 | ECon (_, _, SOME e) => eff e | 75 | EApp _ => false |
69 | ENone _ => false | 76 | EAbs _ => false |
70 | ESome (_, e) => eff e | 77 | EUnop _ => false |
71 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false | 78 | EBinop _ => false |
72 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false | 79 | ERecord _ => false |
73 (* ASK: we're calling functions effectful if they have effects when | 80 | EField _ => false |
74 applied or if the function expressions themselves have effects. | 81 | ECase _ => false |
75 Is that okay? *) | 82 | EStrcat _ => false |
76 (* This is okay because the values we ultimately care about aren't | 83 (* EWrite is a special exception because we record writes when caching. *) |
77 functions, and this is a conservative approximation, anyway. *) | 84 | EWrite _ => false |
78 | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg | 85 | ESeq _ => false |
79 | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e | 86 | ELet _ => false |
80 | EUnop (_, e) => eff e | 87 (* ASK: what should we do about closures? *) |
81 | EBinop (_, _, e1, e2) => eff e1 orelse eff e2 | 88 | EClosure _ => false |
82 | ERecord xs => List.exists (fn (_, e, _) => eff e) xs | 89 | EUnurlify _ => false |
83 | EField (e, _) => eff e | 90 (* Everything else is some sort of effect. We could flip this and |
84 (* If any case could be effectful, consider it effectful. *) | 91 explicitly list bits of Mono that are effectful, but this is |
85 | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs | 92 conservatively robust to future changes (however unlikely). *) |
86 | EStrcat (e1, e2) => eff e1 orelse eff e2 | 93 | _ => true |
87 (* ASK: how should we treat these three? *) | 94 in |
88 | EError _ => tru "error" | 95 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind} |
89 | EReturnBlob _ => tru "blob" | |
90 | ERedirect _ => tru "redirect" | |
91 (* EWrite is a special exception because we record writes when caching. *) | |
92 | EWrite _ => false | |
93 | ESeq (e1, e2) => eff e1 orelse eff e2 | |
94 (* TODO: keep context of which local variables aren't effectful? Only | |
95 makes a difference for function expressions, though. *) | |
96 | ELet (_, _, eBind, eBody) => eff eBind orelse | |
97 effectful doPrint effs inFunction (bound+1) eBody | |
98 | EClosure (_, es) => List.exists eff es | |
99 (* TODO: deal with EQuery. *) | |
100 | EQuery _ => tru "query" | |
101 | EDml _ => tru "dml" | |
102 | ENextval _ => tru "nextval" | |
103 | ESetval _ => tru "setval" | |
104 | EUnurlify (e, _, _) => eff e | |
105 (* ASK: how should we treat this? *) | |
106 | EJavaScript _ => tru "javascript" | |
107 (* ASK: these are all effectful, right? *) | |
108 | ESignalReturn _ => tru "signalreturn" | |
109 | ESignalBind _ => tru "signalbind" | |
110 | ESignalSource _ => tru "signalsource" | |
111 | EServerCall _ => tru "servercall" | |
112 | ERecv _ => tru "recv" | |
113 | ESleep _ => tru "sleep" | |
114 | ESpawn _ => tru "spawn" | |
115 and eff = fn (e', _) => eff' e' | |
116 in | |
117 eff | |
118 end | 96 end |
119 | 97 |
120 (* TODO: test this. *) | 98 (* TODO: test this. *) |
121 val effectfulMap = | 99 fun effectfulDecls (decls, _) = |
122 let | 100 let |
123 fun doVal ((_, name, _, e, _), effMap) = | 101 fun doVal ((_, name, _, e, _), effs) = |
124 if effectful false effMap false 0 e | 102 if effectful effs [] e |
125 then IS.add (effMap, name) | 103 then IS.add (effs, name) |
126 else effMap | 104 else effs |
127 val doDecl = | 105 val doDecl = |
128 fn (DVal v, effMap) => doVal (v, effMap) | 106 fn ((DVal v, _), effs) => doVal (v, effs) |
129 (* Repeat the list of declarations a number of times equal to its size. *) | 107 (* Repeat the list of declarations a number of times equal to its size, |
130 | (DValRec vs, effMap) => | 108 making sure effectfulness propagates everywhere it should. This is |
131 List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs)) | 109 analagous to the Bellman-Ford algorithm. *) |
110 | ((DValRec vs, _), effs) => | |
111 List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs)) | |
132 (* ASK: any other cases? *) | 112 (* ASK: any other cases? *) |
133 | (_, effMap) => effMap | 113 | (_, effs) => effs |
134 in | 114 in |
135 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty | 115 List.foldl doDecl IS.empty decls |
136 end | 116 end |
137 | 117 |
138 | 118 |
139 (* Boolean formula normalization. *) | 119 (*********************************) |
120 (* Boolean Formula Normalization *) | |
121 (*********************************) | |
140 | 122 |
141 datatype junctionType = Conj | Disj | 123 datatype junctionType = Conj | Disj |
142 | 124 |
143 datatype 'atom formula = | 125 datatype 'atom formula = |
144 Atom of 'atom | 126 Atom of 'atom |
209 fn Atom x => Atom (mf x) | 191 fn Atom x => Atom (mf x) |
210 | Negate f => Negate (mapFormula mf f) | 192 | Negate f => Negate (mapFormula mf f) |
211 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs) | 193 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs) |
212 | 194 |
213 | 195 |
214 (* SQL analysis. *) | 196 (****************) |
197 (* SQL Analysis *) | |
198 (****************) | |
215 | 199 |
216 structure CmpKey = struct | 200 structure CmpKey = struct |
217 | 201 |
218 type ord_key = Sql.cmp | 202 type ord_key = Sql.cmp |
219 | 203 |
462 fn Sql.Insert (tab, _) => tab | 446 fn Sql.Insert (tab, _) => tab |
463 | Sql.Delete (tab, _) => tab | 447 | Sql.Delete (tab, _) => tab |
464 | Sql.Update (tab, _, _) => tab | 448 | Sql.Update (tab, _, _) => tab |
465 | 449 |
466 | 450 |
467 (* Program instrumentation. *) | 451 (***************************) |
452 (* Program Instrumentation *) | |
453 (***************************) | |
468 | 454 |
469 val varName = | 455 val varName = |
470 let | 456 let |
471 val varNumber = ref 0 | 457 val varNumber = ref 0 |
472 in | 458 in |
474 end | 460 end |
475 | 461 |
476 val {check, store, flush, ...} = getCache () | 462 val {check, store, flush, ...} = getCache () |
477 | 463 |
478 val dummyLoc = ErrorMsg.dummySpan | 464 val dummyLoc = ErrorMsg.dummySpan |
465 | |
466 val dummyTyp = (TRecord [], dummyLoc) | |
479 | 467 |
480 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) | 468 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) |
481 | 469 |
482 val stringTyp = (TFfi ("Basis", "string"), dummyLoc) | 470 val stringTyp = (TFfi ("Basis", "string"), dummyLoc) |
483 | 471 |
488 in | 476 in |
489 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps | 477 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps |
490 end | 478 end |
491 | _ => raise Match | 479 | _ => raise Match |
492 | 480 |
493 (* Always increments negative indices because that's what we need later. *) | 481 (* Always increments negative indices as a hack we use later. *) |
494 fun incRelsBound bound inc = | 482 fun incRels inc = |
495 MonoUtil.Exp.mapB | 483 MonoUtil.Exp.mapB |
496 {typ = fn x => x, | 484 {typ = fn t' => t', |
497 exp = fn level => | 485 exp = fn bound => |
498 (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n) | 486 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) |
499 | x => x), | 487 | e' => e'), |
500 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level} | 488 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} |
501 bound | 489 0 |
502 | |
503 val incRels = incRelsBound 0 | |
504 | 490 |
505 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = | 491 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = |
506 let | 492 let |
507 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | 493 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo |
508 val loc = dummyLoc | 494 val loc = dummyLoc |
521 (EUnurlify (rel0, resultTyp, false), loc))], | 507 (EUnurlify (rel0, resultTyp, false), loc))], |
522 {disc = stringTyp, result = resultTyp}) | 508 {disc = stringTyp, result = resultTyp}) |
523 end | 509 end |
524 | 510 |
525 fun fileMapfold doExp file start = | 511 fun fileMapfold doExp file start = |
526 case MonoUtil.File.mapfold {typ = Search.return2, | 512 case MonoUtil.File.mapfoldB |
527 exp = fn x => (fn s => Search.Continue (doExp x s)), | 513 {typ = Search.return2, |
528 decl = Search.return2} file start of | 514 exp = fn ctx => fn e' => fn s => Search.Continue (doExp ctx e' s), |
515 decl = fn _ => Search.return2, | |
516 bind = doBind} | |
517 [] file start of | |
529 Search.Continue x => x | 518 Search.Continue x => x |
530 | Search.Return _ => raise Match | 519 | Search.Return _ => raise Match |
531 | 520 |
532 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) | 521 fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ()) |
533 | 522 |
534 fun factorOutNontrivial text = | 523 fun factorOutNontrivial text = |
535 let | 524 let |
536 val loc = dummyLoc | 525 val loc = dummyLoc |
537 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) | 526 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) |
565 (newText, wrapLets, numArgs) | 554 (newText, wrapLets, numArgs) |
566 end | 555 end |
567 | 556 |
568 fun addChecking file = | 557 fun addChecking file = |
569 let | 558 let |
570 fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = | 559 fun doExp ctx (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = |
571 fn e' as EQuery {query = origQueryText, | 560 fn e' as EQuery {query = origQueryText, |
572 sqlcacheInfo = urlifiedRel0, | 561 sqlcacheInfo = urlifiedRel0, |
573 state = resultTyp, | 562 state = resultTyp, |
574 initial, body, tables, exps} => | 563 initial, body, tables, exps} => |
575 let | 564 let |
588 (* DEBUG *) | 577 (* DEBUG *) |
589 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) | 578 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) |
590 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) | 579 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) |
591 fun bind x f = Option.mapPartial f x | 580 fun bind x f = Option.mapPartial f x |
592 fun guard b x = if b then x else NONE | 581 fun guard b x = if b then x else NONE |
593 (* DEBUG: set first boolean argument to true to turn on printing. *) | 582 val effs = effectfulDecls file |
594 fun safe bound = not o effectful true (effectfulMap file) false bound | 583 (* We use dummyTyp here. I think this is okay because databases |
584 don't store (effectful) functions, but there could be some | |
585 corner case I missed. *) | |
586 fun safe bound = | |
587 not o effectful effs (List.tabulate (bound, fn _ => dummyTyp) @ ctx) | |
595 val attempt = | 588 val attempt = |
596 (* Ziv misses Haskell's do notation.... *) | 589 (* Ziv misses Haskell's do notation.... *) |
597 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | 590 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( |
598 bind (Sql.parse Sql.query queryText) (fn queryParsed => | 591 bind (Sql.parse Sql.query queryText) (fn queryParsed => |
599 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), | 592 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), |
607 SOME pair => pair | 600 SOME pair => pair |
608 | NONE => (e', queryInfo) | 601 | NONE => (e', queryInfo) |
609 end | 602 end |
610 | e' => (e', queryInfo) | 603 | e' => (e', queryInfo) |
611 in | 604 in |
612 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) | 605 fileMapfold (fn ctx => fn exp => fn state => doExp ctx state exp) |
606 file | |
607 (SIMM.empty, IM.empty, 0) | |
613 end | 608 end |
614 | 609 |
615 structure Invalidations = struct | 610 structure Invalidations = struct |
616 | 611 |
617 val loc = dummyLoc | 612 val loc = dummyLoc |