Mercurial > urweb

comparison src/sqlcache.sml @ 2250:c275bbc41194

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start work on pure expression caching.
author Ziv Scully <ziv@mit.edu>
date Sun, 13 Sep 2015 16:02:45 -0400
parents e09c3dc102ef
children 25874084bf1f
comparison
equal deleted inserted replaced
2249:c05851bf7861 2250:c275bbc41194
1 structure Sqlcache (* DEBUG: add back :> SQLCACHE. *) = struct 1 structure Sqlcache :> SQLCACHE = struct
2 2
3 open Mono 3 open Mono
4 4
5 structure IS = IntBinarySet 5 structure IS = IntBinarySet
6 structure IM = IntBinaryMap 6 structure IM = IntBinaryMap
7 structure SK = struct type ord_key = string val compare = String.compare end 7 structure SK = struct type ord_key = string val compare = String.compare end
8 structure SS = BinarySetFn(SK) 8 structure SS = BinarySetFn(SK)
9 structure SM = BinaryMapFn(SK) 9 structure SM = BinaryMapFn(SK)
10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) 10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
11
12 fun iterate f n x = if n < 0
13 then raise Fail "Can't iterate function negative number of times."
14 else if n = 0
15 then x
16 else iterate f (n-1) (f x)
11 17
12 (* Filled in by [cacheWrap] during [Sqlcache]. *) 18 (* Filled in by [cacheWrap] during [Sqlcache]. *)
13 val ffiInfo : {index : int, params : int} list ref = ref [] 19 val ffiInfo : {index : int, params : int} list ref = ref []
14 20
15 fun resetFfiInfo () = ffiInfo := [] 21 fun resetFfiInfo () = ffiInfo := []
34 "urlifyString_w", 40 "urlifyString_w",
35 "urlifyBool_w", 41 "urlifyBool_w",
36 "urlifyChannel_w"] 42 "urlifyChannel_w"]
37 in 43 in
38 fn (m, f) => Settings.isEffectful (m, f) 44 fn (m, f) => Settings.isEffectful (m, f)
39 andalso not (m = "Basis" andalso SS.member (fs, f)) 45 orelse not (m = "Basis" andalso SS.member (fs, f))
40 end 46 end
41 47
42 val cache = ref LruCache.cache 48 val cache = ref LruCache.cache
43 fun setCache c = cache := c 49 fun setCache c = cache := c
44 fun getCache () = !cache 50 fun getCache () = !cache
45 51
46 (* Used to have type context for local variables in MonoUtil functions. *) 52 (* Used to have type context for local variables in MonoUtil functions. *)
47 val doBind = 53 val doBind =
48 fn (ctx, MonoUtil.Exp.RelE (_, t)) => t :: ctx 54 fn (env, MonoUtil.Exp.RelE (s, t)) => MonoEnv.pushERel env s t NONE
49 | (ctx, _) => ctx 55 | (env, _) => env
50 56
51 57
52 (*******************) 58 (*******************)
53 (* Effect Analysis *) 59 (* Effect Analysis *)
54 (*******************) 60 (*******************)
57 fun effectful (effs : IS.set) = 63 fun effectful (effs : IS.set) =
58 let 64 let
59 val isFunction = 65 val isFunction =
60 fn (TFun _, _) => true 66 fn (TFun _, _) => true
61 | _ => false 67 | _ => false
62 fun doExp (ctx, e) = 68 fun doExp (env, e) =
63 case e of 69 case e of
64 EPrim _ => false 70 EPrim _ => false
65 (* For now: variables of function type might be effectful, but 71 (* For now: variables of function type might be effectful, but
66 others are fully evaluated and are therefore not effectful. *) 72 others are fully evaluated and are therefore not effectful. *)
67 | ERel n => isFunction (List.nth (ctx, n)) 73 | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
68 | ENamed n => IS.member (effs, n) 74 | ENamed n => IS.member (effs, n)
69 | EFfi (m, f) => ffiEffectful (m, f) 75 | EFfi (m, f) => ffiEffectful (m, f)
70 | EFfiApp (m, f, _) => ffiEffectful (m, f) 76 | EFfiApp (m, f, _) => ffiEffectful (m, f)
71 (* These aren't effectful unless a subexpression is. *) 77 (* These aren't effectful unless a subexpression is. *)
72 | ECon _ => false 78 | ECon _ => false
82 | EStrcat _ => false 88 | EStrcat _ => false
83 (* EWrite is a special exception because we record writes when caching. *) 89 (* EWrite is a special exception because we record writes when caching. *)
84 | EWrite _ => false 90 | EWrite _ => false
85 | ESeq _ => false 91 | ESeq _ => false
86 | ELet _ => false 92 | ELet _ => false
93 | EUnurlify _ => false
87 (* ASK: what should we do about closures? *) 94 (* ASK: what should we do about closures? *)
88 | EClosure _ => false
89 | EUnurlify _ => false
90 (* Everything else is some sort of effect. We could flip this and 95 (* Everything else is some sort of effect. We could flip this and
91 explicitly list bits of Mono that are effectful, but this is 96 explicitly list bits of Mono that are effectful, but this is
92 conservatively robust to future changes (however unlikely). *) 97 conservatively robust to future changes (however unlikely). *)
93 | _ => true 98 | _ => true
94 in 99 in
97 102
98 (* TODO: test this. *) 103 (* TODO: test this. *)
99 fun effectfulDecls (decls, _) = 104 fun effectfulDecls (decls, _) =
100 let 105 let
101 fun doVal ((_, name, _, e, _), effs) = 106 fun doVal ((_, name, _, e, _), effs) =
102 if effectful effs [] e 107 if effectful effs MonoEnv.empty e
103 then IS.add (effs, name) 108 then IS.add (effs, name)
104 else effs 109 else effs
105 val doDecl = 110 val doDecl =
106 fn ((DVal v, _), effs) => doVal (v, effs) 111 fn ((DVal v, _), effs) => doVal (v, effs)
107 (* Repeat the list of declarations a number of times equal to its size, 112 (* Repeat the list of declarations a number of times equal to its size,
360 mapFormula (toAtomExps QueryArg) 365 mapFormula (toAtomExps QueryArg)
361 366
362 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> 367 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
363 (Sql.cmp * atomExp option * atomExp option) formula = 368 (Sql.cmp * atomExp option * atomExp option) formula =
364 mapFormula (toAtomExps DmlRel) 369 mapFormula (toAtomExps DmlRel)
370
365 (* No eqs should have key conflicts because no variable is in two 371 (* No eqs should have key conflicts because no variable is in two
366 equivalence classes, so the [#1] could be [#2]. *) 372 equivalence classes, so the [#1] could be [#2]. *)
367
368 val mergeEqs : (atomExp IntBinaryMap.map option list 373 val mergeEqs : (atomExp IntBinaryMap.map option list
369 -> atomExp IntBinaryMap.map option) = 374 -> atomExp IntBinaryMap.map option) =
370 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE) 375 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
371 (SOME IM.empty) 376 (SOME IM.empty)
372 377
509 end 514 end
510 515
511 fun fileMapfold doExp file start = 516 fun fileMapfold doExp file start =
512 case MonoUtil.File.mapfoldB 517 case MonoUtil.File.mapfoldB
513 {typ = Search.return2, 518 {typ = Search.return2,
514 exp = fn ctx => fn e' => fn s => Search.Continue (doExp ctx e' s), 519 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
515 decl = fn _ => Search.return2, 520 decl = fn _ => Search.return2,
516 bind = doBind} 521 bind = doBind}
517 [] file start of 522 MonoEnv.empty file start of
518 Search.Continue x => x 523 Search.Continue x => x
519 | Search.Return _ => raise Match 524 | Search.Return _ => raise Match
520 525
521 fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ()) 526 fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ())
522 527
554 (newText, wrapLets, numArgs) 559 (newText, wrapLets, numArgs)
555 end 560 end
556 561
557 fun addChecking file = 562 fun addChecking file =
558 let 563 let
559 fun doExp ctx (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = 564 fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
560 fn e' as EQuery {query = origQueryText, 565 fn e' as EQuery {query = origQueryText,
566 (* ASK: could this get messed up by inlining? *)
561 sqlcacheInfo = urlifiedRel0, 567 sqlcacheInfo = urlifiedRel0,
562 state = resultTyp, 568 state = resultTyp,
563 initial, body, tables, exps} => 569 initial, body, tables, exps} =>
564 let 570 let
565 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText 571 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
579 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) 585 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
580 fun bind x f = Option.mapPartial f x 586 fun bind x f = Option.mapPartial f x
581 fun guard b x = if b then x else NONE 587 fun guard b x = if b then x else NONE
582 val effs = effectfulDecls file 588 val effs = effectfulDecls file
583 (* We use dummyTyp here. I think this is okay because databases 589 (* We use dummyTyp here. I think this is okay because databases
584 don't store (effectful) functions, but there could be some 590 don't store (effectful) functions, but perhaps there's some
585 corner case I missed. *) 591 pathalogical corner case missing.... *)
586 fun safe bound = 592 fun safe bound =
587 not o effectful effs (List.tabulate (bound, fn _ => dummyTyp) @ ctx) 593 not
594 o effectful effs
595 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
596 bound
597 env)
588 val attempt = 598 val attempt =
589 (* Ziv misses Haskell's do notation.... *) 599 (* Ziv misses Haskell's do notation.... *)
590 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( 600 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
591 bind (Sql.parse Sql.query queryText) (fn queryParsed => 601 bind (Sql.parse Sql.query queryText) (fn queryParsed =>
592 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), 602 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)),
600 SOME pair => pair 610 SOME pair => pair
601 | NONE => (e', queryInfo) 611 | NONE => (e', queryInfo)
602 end 612 end
603 | e' => (e', queryInfo) 613 | e' => (e', queryInfo)
604 in 614 in
605 fileMapfold (fn ctx => fn exp => fn state => doExp ctx state exp) 615 fileMapfold (fn env => fn exp => fn state => doExp env state exp)
606 file 616 file
607 (SIMM.empty, IM.empty, 0) 617 (SIMM.empty, IM.empty, 0)
608 end 618 end
609 619
610 structure Invalidations = struct 620 structure Invalidations = struct
714 val () = Sql.sqlcacheMode := false 724 val () = Sql.sqlcacheMode := false
715 in 725 in
716 file' 726 file'
717 end 727 end
718 728
729
730 (**********************)
731 (* Mono Type Checking *)
732 (**********************)
733
734 val typOfPrim =
735 fn Prim.Int _ => TFfi ("Basis", "int")
736 | Prim.Float _ => TFfi ("Basis", "int")
737
738 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
739 fn EPrim p => SOME (TFfi ("Basis", case p of
740 Prim.Int _ => "int"
741 | Prim.Float _ => "double"
742 | Prim.String _ => "string"
743 | Prim.Char _ => "char"),
744 dummyLoc)
745 | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
746 | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
747 (* ASK: okay to make a new [ref] each time? *)
748 | ECon (dk, PConVar nCon, _) =>
749 let
750 val (_, _, nData) = MonoEnv.lookupConstructor env nCon
751 val (_, cs) = MonoEnv.lookupDatatype env nData
752 in
753 SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
754 end
755 | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
756 | ENone t => SOME (TOption t, dummyLoc)
757 | ESome (t, _) => SOME (TOption t, dummyLoc)
758 | EFfi _ => NONE
759 | EFfiApp _ => NONE
760 | EApp (e1, e2) => (case typOfExp env e1 of
761 SOME (TFun (_, t), _) => SOME t
762 | _ => NONE)
763 | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
764 (* ASK: is this right? *)
765 | EUnop (unop, e) => (case unop of
766 "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
767 | "-" => typOfExp env e
768 | _ => NONE)
769 (* ASK: how should this (and other "=> NONE" cases) work? *)
770 | EBinop _ => NONE
771 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
772 | EField (e, s) => (case typOfExp env e of
773 SOME (TRecord fields, _) =>
774 (case List.find (fn (s', _) => s = s') fields of
775 SOME (_, t) => SOME t
776 | _ => NONE)
777 | _ => NONE)
778 | ECase (_, _, {result, ...}) => SOME result
779 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
780 | EWrite _ => SOME (TRecord [], dummyLoc)
781 | ESeq (_, e) => typOfExp env e
782 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
783 | EClosure _ => NONE
784 | EUnurlify (_, t, _) => SOME t
785
786 and typOfExp env (e', loc) = typOfExp' env e'
787
788
789 (*******************************)
790 (* Caching Pure Subexpressions *)
791 (*******************************)
792
793 datatype subexp = Pure of unit -> exp | Impure of exp
794
795 val isImpure =
796 fn Pure _ => false
797 | Impure _ => true
798
799 val expOfSubexp =
800 fn Pure f => f ()
801 | Impure e => e
802
803 val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO"
804
805 fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp =
806 let
807 fun wrapBindN f (args : (MonoEnv.env * exp) list) =
808 let
809 val subexps = map (fn (env, exp) => pureCache effs env exp) args
810 in
811 if List.exists isImpure subexps
812 then Impure (f (map expOfSubexp subexps), loc)
813 else Pure (fn () => (makeCache env (f (map #2 args)), loc))
814 end
815 fun wrapBind1 f arg =
816 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
817 fun wrapBind2 f (arg1, arg2) =
818 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
819 fun wrapN f es = wrapBindN f (map (fn e => (env, e)) es)
820 fun wrap1 f e = wrapBind1 f (env, e)
821 fun wrap2 f (e1, e2) = wrapBind2 f ((env, e1), (env, e2))
822 in
823 case exp' of
824 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
825 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
826 | EFfiApp (s1, s2, args) =>
827 wrapN (fn es => EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
828 (map #1 args)
829 | EApp (e1, e2) => wrap2 EApp (e1, e2)
830 | EAbs (s, t1, t2, e) =>
831 wrapBind1 (fn e => EAbs (s, t1, t2, e))
832 (MonoEnv.pushERel env s t1 NONE, e)
833 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
834 | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
835 | ERecord fields =>
836 wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
837 (map #2 fields)
838 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
839 | ECase (e, cases, {disc, result}) =>
840 wrapBindN (fn (e::es) =>
841 ECase (e,
842 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
843 {disc = disc, result = result}))
844 ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases)
845 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
846 (* We record page writes, so they're cachable. *)
847 | EWrite e => wrap1 EWrite e
848 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
849 | ELet (s, t, e1, e2) =>
850 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
851 ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
852 (* ASK: | EClosure (n, es) => ? *)
853 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
854 | _ => if effectful effs env exp
855 then Impure exp
856 else Pure (fn () => (makeCache env exp', loc))
857 end
858
719 end 859 end