Mercurial > urweb

comparison src/sqlcache.sml @ 2248:e09c3dc102ef

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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