Mercurial > urweb
comparison src/sqlcache.sml @ 2269:f7bc7c11a656
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 |