Mercurial > urweb

comparison src/sqlcache.sml @ 2266:afd12c75e0d6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Do SQL and pure caching in the same pass.
author Ziv Scully <ziv@mit.edu>
date Wed, 14 Oct 2015 15:45:04 -0400
parents a647a1560628
children e5b7b066bf1b
comparison
equal deleted inserted replaced
2265:a647a1560628 2266:afd12c75e0d6
54 val doBind = 54 val doBind =
55 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE 55 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
56 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s 56 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
57 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs 57 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
58 58
59 (***********************)
60 (* General Combinators *)
61 (***********************)
62
63 (* From the MLton wiki. *)
64 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
65 infix 3 \> fun f \> y = f y (* Left application *)
66 infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *)
67 infixr 3 </ fun x </ f = f x (* Right application *)
68
69 (* Option monad. *)
70 fun obind (x, f) = Option.mapPartial f x
71 fun oguard (b, x) = if b then x else NONE
59 72
60 (*******************) 73 (*******************)
61 (* Effect Analysis *) 74 (* Effect Analysis *)
62 (*******************) 75 (*******************)
63 76
540 Search.Continue x => x 553 Search.Continue x => x
541 | Search.Return _ => raise Match 554 | Search.Return _ => raise Match
542 555
543 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) 556 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
544 557
558 (* Takes a text expression and returns
559 newText: a new expression with any subexpressions that do computation
560 replaced with variables,
561 wrapLets: a function that wraps its argument expression with lets binding
562 those variables to their corresponding computations, and
563 numArgs: the number of such bindings.
564 The De Bruijn indices work out for [wrapLets (incRels numArgs newText)], but
565 the intention is that newText might be augmented. *)
566 fun factorOutNontrivial text =
567 let
568 val loc = dummyLoc
569 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
570 val chunks = Sql.chunkify text
571 val (newText, newVariables) =
572 (* Important that this is foldr (to oppose foldl below). *)
573 List.foldr
574 (fn (chunk, (qText, newVars)) =>
575 (* Variable bound to the head of newVars will have the lowest index. *)
576 case chunk of
577 (* EPrim should always be a string in this case. *)
578 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
579 | Sql.Exp e =>
580 let
581 val n = length newVars
582 in
583 (* This is the (n+1)th new variable, so there are
584 already n new variables bound, so we increment
585 indices by n. *)
586 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
587 end
588 | Sql.String s => (strcat (stringExp s, qText), newVars))
589 (stringExp "", [])
590 chunks
591 fun wrapLets e' =
592 (* Important that this is foldl (to oppose foldr above). *)
593 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
594 e'
595 newVariables
596 val numArgs = length newVariables
597 in
598 (newText, wrapLets, numArgs)
599 end
600
545 601
546 (**********************) 602 (**********************)
547 (* Mono Type Checking *) 603 (* Mono Type Checking *)
548 (**********************) 604 (**********************)
549 605
597 | _ => NONE 653 | _ => NONE
598 654
599 and typOfExp env (e', loc) = typOfExp' env e' 655 and typOfExp env (e', loc) = typOfExp' env e'
600 656
601 657
602 (*******************************) 658 (***********)
603 (* Caching Pure Subexpressions *) 659 (* Caching *)
604 (*******************************) 660 (***********)
605 661
606 fun cacheWrap (env, exp, resultTyp, args, i) = 662 fun cacheWrap (env, exp, resultTyp, args, i) =
607 let 663 let
608 val loc = dummyLoc 664 val loc = dummyLoc
609 val rel0 = (ERel 0, loc) 665 val rel0 = (ERel 0, loc)
642 0 698 0
643 IS.empty 699 IS.empty
644 700
645 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 701 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
646 702
647 structure InvalidationInfo :> sig
648 type t
649 val empty : t
650 val fromList : int list -> t
651 val toList : t -> int list
652 val union : t * t -> t
653 val unbind : t * int -> t option
654 end = struct
655
656 (* Keep track of the minimum explicitly. NONE is the empty set. *)
657 type t = (int * IS.set) option
658
659 val fromList =
660 List.foldl
661 (fn (n, NONE) => SOME (n, IS.singleton n)
662 | (n', SOME (n, ns)) => SOME (Int.min (n, n'), IS.add (ns, n')))
663 NONE
664
665 val empty = fromList []
666
667 val toList =
668 fn NONE => []
669 | SOME (_, ns) => IS.listItems ns
670
671 val union =
672 fn (SOME (n1, ns1), SOME (n2, ns2)) => SOME (Int.min (n1, n2), IS.union (ns1, ns2))
673 | (NONE, info) => info
674 | (info, NONE) => info
675
676 val unbind =
677 fn (SOME (n, ns), unbound) =>
678 let
679 val n = n - unbound
680 in
681 if n < 0
682 then NONE
683 else SOME (SOME (n, IS.map (fn n => n - unbound) ns))
684 end
685 | _ => SOME NONE
686
687 end
688
689 val unionUnbind =
690 List.foldl
691 (fn (_, NONE) => NONE
692 | ((info, unbound), SOME infoAcc) =>
693 case InvalidationInfo.unbind (info, unbound) of
694 NONE => NONE
695 | SOME info => SOME (InvalidationInfo.union (info, infoAcc)))
696 (SOME InvalidationInfo.empty)
697
698 datatype subexp = Pure of unit -> exp | Impure of exp 703 datatype subexp = Pure of unit -> exp | Impure of exp
699 704
700 val isImpure = 705 val isImpure =
701 fn Pure _ => false 706 fn Pure _ => false
702 | Impure _ => true 707 | Impure _ => true
706 | Impure e => e 711 | Impure e => e
707 712
708 (* TODO: pick a number. *) 713 (* TODO: pick a number. *)
709 val sizeWorthCaching = 5 714 val sizeWorthCaching = 5
710 715
711 fun makeCache (env, exp', index) = 716 type state = (SIMM.multimap * (Sql.query * int) IntBinaryMap.map * int)
717
718 fun incIndex (x, y, index) = (x, y, index+1)
719
720 fun cacheQuery effs env (state as (tableToIndices, indexToQueryNumArgs, index)) =
721 fn q as {query = origQueryText,
722 state = resultTyp,
723 initial, body, tables, exps} =>
724 let
725 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
726 (* Increment once for each new variable just made. This is where we
727 use the negative De Bruijn indices hack. *)
728 (* TODO: please don't use that hack. As anyone could have predicted, it
729 was incomprehensible a year later.... *)
730 val queryExp = incRels numArgs
731 (EQuery {query = newQueryText,
732 state = resultTyp,
733 initial = initial,
734 body = body,
735 tables = tables,
736 exps = exps},
737 dummyLoc)
738 (* DEBUG *)
739 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
740 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
741 (* We use dummyTyp here. I think this is okay because databases don't
742 store (effectful) functions, but perhaps there's some pathalogical
743 corner case missing.... *)
744 fun safe bound =
745 not
746 o effectful effs
747 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
748 bound
749 env)
750 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
751 val attempt =
752 (* Ziv misses Haskell's do notation.... *)
753 textOfQuery queryExp
754 <\obind\>
755 (fn queryText =>
756 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
757 <\oguard\>
758 Sql.parse Sql.query queryText
759 <\obind\>
760 (fn queryParsed =>
761 (cacheWrap (env, queryExp, resultTyp, args, index))
762 <\obind\>
763 (fn cachedExp =>
764 SOME (wrapLets cachedExp,
765 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
766 tableToIndices
767 (tablesQuery queryParsed),
768 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
769 index + 1)))))
770 in
771 case attempt of
772 SOME pair => pair
773 (* Even in this case, we have to increment index to avoid some bug,
774 but I forget exactly what it is or why this helps. *)
775 (* TODO: just use a reference for current index.... *)
776 | NONE => (EQuery q, incIndex state)
777 end
778
779 fun cachePure (env, exp', (_, _, index)) =
712 case typOfExp' env exp' of 780 case typOfExp' env exp' of
713 NONE => NONE 781 NONE => NONE
714 | SOME (TFun _, _) => NONE 782 | SOME (TFun _, _) => NONE
715 | SOME typ => 783 | SOME typ =>
716 if expSize (exp', dummyLoc) < sizeWorthCaching 784 (expSize (exp', dummyLoc) < sizeWorthCaching)
717 then NONE 785 </oguard/>
718 else case List.foldr (fn ((_, _), NONE) => NONE 786 (List.foldr (fn (_, NONE) => NONE
719 | ((n, typ), SOME args) => 787 | ((n, typ), SOME args) =>
720 case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of 788 (MonoFooify.urlify env ((ERel n, dummyLoc), typ))
721 NONE => NONE 789 </obind/>
722 | SOME arg => SOME (arg :: args)) 790 (fn arg => SOME (arg :: args)))
723 (SOME []) 791 (SOME [])
724 (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) 792 (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
725 (freeVars (exp', dummyLoc))) of 793 (freeVars (exp', dummyLoc))))
726 NONE => NONE 794 </obind/>
727 | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) 795 (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, index))
728 796
729 fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int = 797 fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) : subexp * state =
730 let 798 let
731 fun wrapBindN f (args : (MonoEnv.env * exp) list) = 799 fun wrapBindN f (args : (MonoEnv.env * exp) list) =
732 let 800 let
733 val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args 801 val (subexps, state) = ListUtil.foldlMap (cache effs) state args
734 fun mkExp () = (f (map expOfSubexp subexps), loc) 802 fun mkExp () = (f (map expOfSubexp subexps), loc)
735 in 803 in
736 if List.exists isImpure subexps 804 if List.exists isImpure subexps
737 then (Impure (mkExp ()), index) 805 then (Impure (mkExp ()), state)
738 else (Pure (fn () => case makeCache (env, f (map #2 args), index) of 806 else (Pure (fn () => case cachePure (env, f (map #2 args), state) of
739 NONE => mkExp () 807 NONE => mkExp ()
740 | SOME e' => (e', loc)), 808 | SOME e' => (e', loc)),
741 (* Conservatively increment index. *) 809 (* Conservatively increment index. *)
742 index + 1) 810 incIndex state)
743 end 811 end
744 fun wrapBind1 f arg = 812 fun wrapBind1 f arg =
745 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] 813 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
746 fun wrapBind2 f (arg1, arg2) = 814 fun wrapBind2 f (arg1, arg2) =
747 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2] 815 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
752 case exp' of 820 case exp' of
753 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e 821 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
754 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e 822 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
755 | EFfiApp (s1, s2, args) => 823 | EFfiApp (s1, s2, args) =>
756 if ffiEffectful (s1, s2) 824 if ffiEffectful (s1, s2)
757 then (Impure exp, index) 825 then (Impure exp, state)
758 else wrapN (fn es => 826 else wrapN (fn es =>
759 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args))) 827 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
760 (map #1 args) 828 (map #1 args)
761 | EApp (e1, e2) => wrap2 EApp (e1, e2) 829 | EApp (e1, e2) => wrap2 EApp (e1, e2)
762 | EAbs (s, t1, t2, e) => 830 | EAbs (s, t1, t2, e) =>
782 | ELet (s, t, e1, e2) => 850 | ELet (s, t, e1, e2) =>
783 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2)) 851 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
784 ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2)) 852 ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
785 (* ASK: | EClosure (n, es) => ? *) 853 (* ASK: | EClosure (n, es) => ? *)
786 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e 854 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
855 | EQuery q =>
856 let
857 val (exp', state) = cacheQuery effs env state q
858 in
859 (Impure (exp', loc), state)
860 end
787 | _ => if effectful effs env exp 861 | _ => if effectful effs env exp
788 then (Impure exp, index) 862 then (Impure exp, state)
789 else (Pure (fn () => (case makeCache (env, exp', index) of 863 else (Pure (fn () => (case cachePure (env, exp', state) of
790 NONE => exp' 864 NONE => exp'
791 | SOME e' => e', 865 | SOME e' => e',
792 loc)), 866 loc)),
793 index + 1) 867 incIndex state)
794 end 868 end
795 869
796 fun addPure (file, indexStart, effs) = 870 fun addCaching file =
797 let 871 let
798 fun doTopLevelExp env exp index = 872 val effs = effectfulDecls file
873 fun doTopLevelExp env exp state =
799 let 874 let
800 val (subexp, index) = pureCache effs ((env, exp), index) 875 val (subexp, state) = cache effs ((env, exp), state)
801 in 876 in
802 (expOfSubexp subexp, index) 877 (expOfSubexp subexp, state)
803 end 878 end
804 in 879 in
805 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) 880 ((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, 0)), effs)
806 end
807
808
809 (***********************)
810 (* Caching SQL Queries *)
811 (***********************)
812
813 fun factorOutNontrivial text =
814 let
815 val loc = dummyLoc
816 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
817 val chunks = Sql.chunkify text
818 val (newText, newVariables) =
819 (* Important that this is foldr (to oppose foldl below). *)
820 List.foldr
821 (fn (chunk, (qText, newVars)) =>
822 (* Variable bound to the head of newBs will have the lowest index. *)
823 case chunk of
824 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
825 | Sql.Exp e =>
826 let
827 val n = length newVars
828 in
829 (* This is the (n+1)th new variable, so there are
830 already n new variables bound, so we increment
831 indices by n. *)
832 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
833 end
834 | Sql.String s => (strcat (stringExp s, qText), newVars))
835 (stringExp "", [])
836 chunks
837 fun wrapLets e' =
838 (* Important that this is foldl (to oppose foldr above). *)
839 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
840 e'
841 newVariables
842 val numArgs = length newVariables
843 in
844 (newText, wrapLets, numArgs)
845 end
846
847 fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
848 fn e' as EQuery {query = origQueryText,
849 state = resultTyp,
850 initial, body, tables, exps} =>
851 let
852 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
853 (* Increment once for each new variable just made. *)
854 val queryExp = incRels numArgs
855 (EQuery {query = newQueryText,
856 state = resultTyp,
857 initial = initial,
858 body = body,
859 tables = tables,
860 exps = exps},
861 dummyLoc)
862 (* DEBUG *)
863 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
864 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
865 fun bind x f = Option.mapPartial f x
866 fun guard b x = if b then x else NONE
867 (* We use dummyTyp here. I think this is okay because databases don't
868 store (effectful) functions, but perhaps there's some pathalogical
869 corner case missing.... *)
870 fun safe bound =
871 not
872 o effectful effs
873 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
874 bound
875 env)
876 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
877 val attempt =
878 (* Ziv misses Haskell's do notation.... *)
879 bind (textOfQuery queryExp) (fn queryText =>
880 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
881 bind (Sql.parse Sql.query queryText) (fn queryParsed =>
882 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
883 SOME (wrapLets cachedExp,
884 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
885 tableToIndices
886 (tablesQuery queryParsed),
887 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
888 index + 1))))))
889 in
890 case attempt of
891 SOME pair => pair
892 (* We have to increment index conservatively. *)
893 (* TODO: just use a reference for current index.... *)
894 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
895 end
896 | e' => (e', queryInfo)
897
898 fun addChecking file =
899 let
900 val effs = effectfulDecls file
901 in
902 (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
903 file
904 (SIMM.empty, IM.empty, 0),
905 effs)
906 end 881 end
907 882
908 883
909 (************) 884 (************)
910 (* Flushing *) 885 (* Flushing *)
993 end 968 end
994 | e' => e' 969 | e' => e'
995 in 970 in
996 (* DEBUG *) 971 (* DEBUG *)
997 (* gunk := []; *) 972 (* gunk := []; *)
998 (fileMap doExp file, index, effs) 973 fileMap doExp file
999 end 974 end
1000 975
1001 976
1002 (***************) 977 (***************)
1003 (* Entry point *) 978 (* Entry point *)
1024 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls 999 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
1025 in 1000 in
1026 (datatypes @ newDecls @ others, sideInfo) 1001 (datatypes @ newDecls @ others, sideInfo)
1027 end 1002 end
1028 1003
1029 val go' = addPure o addFlushing o addChecking o inlineSql 1004 val go' = addFlushing o addCaching o inlineSql
1030 1005
1031 fun go file = 1006 fun go file =
1032 let 1007 let
1033 (* TODO: do something nicer than [Sql] being in one of two modes. *) 1008 (* TODO: do something nicer than [Sql] being in one of two modes. *)
1034 val () = (resetFfiInfo (); Sql.sqlcacheMode := true) 1009 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)