Mercurial > urweb

comparison src/sqlcache.sml @ 2269:f7bc7c11a656

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make SQL caches use more of the pure caching machinery, but it's brittle.
author Ziv Scully <ziv@mit.edu>
date Thu, 15 Oct 2015 00:52:04 -0400
parents bc1ef958d801
children 85f91c7452b0
comparison
equal deleted inserted replaced
2268:bc1ef958d801 2269:f7bc7c11a656
673 | EWrite _ => SOME (TRecord [], dummyLoc) 673 | EWrite _ => SOME (TRecord [], dummyLoc)
674 | ESeq (_, e) => typOfExp env e 674 | ESeq (_, e) => typOfExp env e
675 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 675 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
676 | EClosure _ => NONE 676 | EClosure _ => NONE
677 | EUnurlify (_, t, _) => SOME t 677 | EUnurlify (_, t, _) => SOME t
678 | EQuery {state, ...} => SOME state
678 | _ => NONE 679 | _ => NONE
679 680
680 and typOfExp env (e', loc) = typOfExp' env e' 681 and typOfExp env (e', loc) = typOfExp' env e'
681 682
682 683
768 | (Impure e, state) => (e, state) 769 | (Impure e, state) => (e, state)
769 770
770 (* TODO: pick a number. *) 771 (* TODO: pick a number. *)
771 val sizeWorthCaching = 5 772 val sizeWorthCaching = 5
772 773
773 fun cacheQuery (effs, env, state, q) : (exp' * state) = 774 val worthCaching =
774 let 775 fn EQuery _ => true
775 val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state 776 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
776 val {query = queryText,
777 state = resultTyp,
778 initial, body, tables, exps} = q
779 val numArgs = maxFreeVar queryText + 1
780 val queryExp = (EQuery q, dummyLoc)
781 (* DEBUG *)
782 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
783 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
784 (* We use dummyTyp here. I think this is okay because databases don't
785 store (effectful) functions, but perhaps there's some pathalogical
786 corner case missing.... *)
787 fun safe bound =
788 not
789 o effectful effs
790 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
791 bound
792 env)
793 val attempt =
794 (* Ziv misses Haskell's do notation.... *)
795 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
796 </oguard/>
797 Sql.parse Sql.query queryText
798 </obind/>
799 (fn queryParsed =>
800 (cacheWrap (env, queryExp, resultTyp, args, state))
801 </obind/>
802 (fn (cachedExp, state) =>
803 SOME (cachedExp,
804 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
805 tableToIndices
806 (tablesQuery queryParsed),
807 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
808 #3 state,
809 #4 state))))
810 in
811 case attempt of
812 SOME pair => pair
813 | NONE => (EQuery q, state)
814 end
815 777
816 fun cachePure (env, exp', state as (_, _, _, index)) = 778 fun cachePure (env, exp', state as (_, _, _, index)) =
817 case (expSize (exp', dummyLoc) > sizeWorthCaching) 779 case (worthCaching exp')
818 </oguard/> 780 </oguard/>
819 typOfExp' env exp' of 781 typOfExp' env exp' of
820 NONE => NONE 782 NONE => NONE
821 | SOME (TFun _, _) => NONE 783 | SOME (TFun _, _) => NONE
822 | SOME typ => 784 | SOME typ =>
825 (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) 787 (MonoFooify.urlify env ((ERel n, dummyLoc), typ))
826 </obind/> 788 </obind/>
827 (fn arg => SOME (arg :: args))) 789 (fn arg => SOME (arg :: args)))
828 (SOME []) 790 (SOME [])
829 (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) 791 (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
830 (freeVars (exp', dummyLoc)))) 792 (ListMergeSort.sort op> (freeVars (exp', dummyLoc)))))
831 </obind/> 793 </obind/>
832 (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state)) 794 (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state))
795
796 fun cacheQuery (effs, env, state, q) : (exp' * state) =
797 let
798 val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state
799 val {query = queryText, initial, body, ...} = q
800 val numArgs = maxFreeVar queryText + 1
801 (* DEBUG *)
802 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
803 (* We use dummyTyp here. I think this is okay because databases don't
804 store (effectful) functions, but perhaps there's some pathalogical
805 corner case missing.... *)
806 fun safe bound =
807 not
808 o effectful effs
809 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
810 bound
811 env)
812 val {state = resultTyp, ...} = q
813 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
814 val attempt =
815 (* Ziv misses Haskell's do notation.... *)
816 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
817 </oguard/>
818 Sql.parse Sql.query queryText
819 </obind/>
820 (fn queryParsed =>
821 (cachePure (env, EQuery q, state))
822 </obind/>
823 (fn (cachedExp, state) =>
824 SOME (cachedExp,
825 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
826 tableToIndices
827 (tablesQuery queryParsed),
828 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
829 #3 state,
830 #4 state))))
831 in
832 case attempt of
833 SOME pair => pair
834 | NONE => (EQuery q, state)
835 end
833 836
834 fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) = 837 fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) =
835 let 838 let
836 fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) = 839 fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) =
837 let 840 let
894 let 897 let
895 val (exp', state) = cacheQuery (effs, env, state, q) 898 val (exp', state) = cacheQuery (effs, env, state, q)
896 in 899 in
897 (Impure (exp', loc), state) 900 (Impure (exp', loc), state)
898 end 901 end
899 | _ => if effectful effs env exp 902 | _ => (if effectful effs env exp
900 then (Impure exp, state) 903 then Impure exp
901 else (Cachable (fn state => 904 else Cachable (fn state =>
902 case cachePure (env, exp', state) of 905 case cachePure (env, exp', state) of
903 NONE => ((exp', loc), state) 906 NONE => ((exp', loc), state)
904 | SOME (exp', state) => ((exp', loc), state)), 907 | SOME (exp', state) => ((exp', loc), state)),
905 state) 908 state)
906 end 909 end
907 910
908 fun addCaching file = 911 fun addCaching file =
909 let 912 let
910 val effs = effectfulDecls file 913 val effs = effectfulDecls file
932 | _ => raise Match, 935 | _ => raise Match,
933 loc)), 936 loc)),
934 loc) 937 loc)
935 938
936 fun eqsToInvalidation numArgs eqs = 939 fun eqsToInvalidation numArgs eqs =
937 let 940 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
938 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
939 in
940 inv (numArgs - 1)
941 end
942 941
943 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here 942 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
944 represents unknown, which means a wider invalidation. *) 943 represents unknown, which means a wider invalidation. *)
945 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = 944 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
946 fn ([], []) => true 945 fn ([], []) => true