Mercurial > urweb

comparison src/sqlcache.sml @ 2265:a647a1560628

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Hard-code Sqlcache module (in Ur/Web) as effectful and reorder sqlcache.sml.
author Ziv Scully <ziv@mit.edu>
date Wed, 14 Oct 2015 00:07:00 -0400
parents bbcf9ba9b39a
children afd12c75e0d6
comparison
equal deleted inserted replaced
2264:bbcf9ba9b39a 2265:a647a1560628
13 then raise Fail "Can't iterate function negative number of times." 13 then raise Fail "Can't iterate function negative number of times."
14 else if n = 0 14 else if n = 0
15 then x 15 then x
16 else iterate f (n-1) (f x) 16 else iterate f (n-1) (f x)
17 17
18 (* Filled in by [cacheWrap] during [Sqlcache]. *) 18 (* Filled in by [cacheWrap]. *)
19 val ffiInfo : {index : int, params : int} list ref = ref [] 19 val ffiInfo : {index : int, params : int} list ref = ref []
20 20
21 fun resetFfiInfo () = ffiInfo := [] 21 fun resetFfiInfo () = ffiInfo := []
22 22
23 fun getFfiInfo () = !ffiInfo 23 fun getFfiInfo () = !ffiInfo
39 "urlifyFloat_w", 39 "urlifyFloat_w",
40 "urlifyString_w", 40 "urlifyString_w",
41 "urlifyBool_w", 41 "urlifyBool_w",
42 "urlifyChannel_w"] 42 "urlifyChannel_w"]
43 in 43 in
44 (* ASK: nicer way than using [Settings.addEffectful] for each Sqlcache 44 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
45 function? Right now they're all always effectful. *)
46 fn (m, f) => Settings.isEffectful (m, f) 45 fn (m, f) => Settings.isEffectful (m, f)
47 andalso not (m = "Basis" andalso SS.member (okayWrites, f)) 46 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
48 end 47 end
49 48
50 val cache = ref LruCache.cache 49 val cache = ref LruCache.cache
454 fn Sql.Insert (tab, _) => tab 453 fn Sql.Insert (tab, _) => tab
455 | Sql.Delete (tab, _) => tab 454 | Sql.Delete (tab, _) => tab
456 | Sql.Update (tab, _, _) => tab 455 | Sql.Update (tab, _, _) => tab
457 456
458 457
459 (***************************) 458 (*************************************)
460 (* Program Instrumentation *) 459 (* Program Instrumentation Utilities *)
461 (***************************) 460 (*************************************)
462 461
463 val varName = 462 val varName =
464 let 463 let
465 val varNumber = ref 0 464 val varNumber = ref 0
466 in 465 in
493 exp = fn bound => 492 exp = fn bound =>
494 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) 493 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
495 | e' => e'), 494 | e' => e'),
496 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 495 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
497 0 496 0
498
499 fun cacheWrap (env, exp, resultTyp, args, i) =
500 let
501 val loc = dummyLoc
502 val rel0 = (ERel 0, loc)
503 in
504 case MonoFooify.urlify env (rel0, resultTyp) of
505 NONE => NONE
506 | SOME urlified =>
507 let
508 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
509 (* We ensure before this step that all arguments aren't effectful.
510 by turning them into local variables as needed. *)
511 val argsInc = map (incRels 1) args
512 val check = (check (i, args), loc)
513 val store = (store (i, argsInc, urlified), loc)
514 in
515 SOME (ECase
516 (check,
517 [((PNone stringTyp, loc),
518 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
519 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
520 (* Boolean is false because we're not unurlifying from a cookie. *)
521 (EUnurlify (rel0, resultTyp, false), loc))],
522 {disc = (TOption stringTyp, loc), result = resultTyp}))
523 end
524 end
525 497
526 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = 498 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
527 let 499 let
528 fun doVal env ((x, n, t, exp, s), state) = 500 fun doVal env ((x, n, t, exp, s), state) =
529 let 501 let
567 MonoEnv.empty file start of 539 MonoEnv.empty file start of
568 Search.Continue x => x 540 Search.Continue x => x
569 | Search.Return _ => raise Match 541 | Search.Return _ => raise Match
570 542
571 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) 543 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
572
573 fun factorOutNontrivial text =
574 let
575 val loc = dummyLoc
576 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
577 val chunks = Sql.chunkify text
578 val (newText, newVariables) =
579 (* Important that this is foldr (to oppose foldl below). *)
580 List.foldr
581 (fn (chunk, (qText, newVars)) =>
582 (* Variable bound to the head of newBs will have the lowest index. *)
583 case chunk of
584 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
585 | Sql.Exp e =>
586 let
587 val n = length newVars
588 in
589 (* This is the (n+1)th new variable, so there are
590 already n new variables bound, so we increment
591 indices by n. *)
592 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
593 end
594 | Sql.String s => (strcat (stringExp s, qText), newVars))
595 (stringExp "", [])
596 chunks
597 fun wrapLets e' =
598 (* Important that this is foldl (to oppose foldr above). *)
599 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
600 e'
601 newVariables
602 val numArgs = length newVariables
603 in
604 (newText, wrapLets, numArgs)
605 end
606
607 fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
608 fn e' as EQuery {query = origQueryText,
609 state = resultTyp,
610 initial, body, tables, exps} =>
611 let
612 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
613 (* Increment once for each new variable just made. *)
614 val queryExp = incRels numArgs
615 (EQuery {query = newQueryText,
616 state = resultTyp,
617 initial = initial,
618 body = body,
619 tables = tables,
620 exps = exps},
621 dummyLoc)
622 (* DEBUG *)
623 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
624 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
625 fun bind x f = Option.mapPartial f x
626 fun guard b x = if b then x else NONE
627 (* We use dummyTyp here. I think this is okay because databases don't
628 store (effectful) functions, but perhaps there's some pathalogical
629 corner case missing.... *)
630 fun safe bound =
631 not
632 o effectful effs
633 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
634 bound
635 env)
636 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
637 val attempt =
638 (* Ziv misses Haskell's do notation.... *)
639 bind (textOfQuery queryExp) (fn queryText =>
640 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
641 bind (Sql.parse Sql.query queryText) (fn queryParsed =>
642 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
643 SOME (wrapLets cachedExp,
644 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
645 tableToIndices
646 (tablesQuery queryParsed),
647 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
648 index + 1))))))
649 in
650 case attempt of
651 SOME pair => pair
652 (* We have to increment index conservatively. *)
653 (* TODO: just use a reference for current index.... *)
654 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
655 end
656 | e' => (e', queryInfo)
657
658 fun addChecking file =
659 let
660 val effs = effectfulDecls file
661 in
662 (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
663 file
664 (SIMM.empty, IM.empty, 0),
665 effs)
666 end
667
668 structure Invalidations = struct
669
670 val loc = dummyLoc
671
672 val optionAtomExpToExp =
673 fn NONE => (ENone stringTyp, loc)
674 | SOME e => (ESome (stringTyp,
675 (case e of
676 DmlRel n => ERel n
677 | Prim p => EPrim p
678 (* TODO: make new type containing only these two. *)
679 | _ => raise Match,
680 loc)),
681 loc)
682
683 fun eqsToInvalidation numArgs eqs =
684 let
685 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
686 in
687 inv (numArgs - 1)
688 end
689
690 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
691 represents unknown, which means a wider invalidation. *)
692 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
693 fn ([], []) => true
694 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
695 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
696 EQUAL => madeRedundantBy (xs, ys)
697 | _ => false)
698 | _ => false
699
700 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
701
702 fun invalidations ((query, numArgs), dml) =
703 (map (map optionAtomExpToExp)
704 o removeRedundant madeRedundantBy
705 o map (eqsToInvalidation numArgs)
706 o eqss)
707 (query, dml)
708
709 end
710
711 val invalidations = Invalidations.invalidations
712
713 (* DEBUG *)
714 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
715 (* val gunk' : exp list ref = ref [] *)
716
717 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
718 let
719 val flushes = List.concat
720 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
721 val doExp =
722 fn EDml (origDmlText, failureMode) =>
723 let
724 (* DEBUG *)
725 (* val () = gunk' := origDmlText :: !gunk' *)
726 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
727 val dmlText = incRels numArgs newDmlText
728 val dmlExp = EDml (dmlText, failureMode)
729 (* DEBUG *)
730 val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText))
731 val inval =
732 case Sql.parse Sql.dml dmlText of
733 SOME dmlParsed =>
734 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
735 SOME queryNumArgs =>
736 (* DEBUG *)
737 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
738 (i, invalidations (queryNumArgs, dmlParsed)))
739 (* TODO: fail more gracefully. *)
740 | NONE => raise Match))
741 (SIMM.findList (tableToIndices, tableDml dmlParsed)))
742 | NONE => NONE
743 in
744 case inval of
745 (* TODO: fail more gracefully. *)
746 NONE => raise Match
747 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
748 end
749 | e' => e'
750 in
751 (* DEBUG *)
752 (* gunk := []; *)
753 (fileMap doExp file, index, effs)
754 end
755
756 val inlineSql =
757 let
758 val doExp =
759 (* TODO: EQuery, too? *)
760 (* ASK: should this live in [MonoOpt]? *)
761 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
762 let
763 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
764 in
765 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
766 end
767 | e => e
768 in
769 fileMap doExp
770 end
771 544
772 545
773 (**********************) 546 (**********************)
774 (* Mono Type Checking *) 547 (* Mono Type Checking *)
775 (**********************) 548 (**********************)
827 600
828 601
829 (*******************************) 602 (*******************************)
830 (* Caching Pure Subexpressions *) 603 (* Caching Pure Subexpressions *)
831 (*******************************) 604 (*******************************)
605
606 fun cacheWrap (env, exp, resultTyp, args, i) =
607 let
608 val loc = dummyLoc
609 val rel0 = (ERel 0, loc)
610 in
611 case MonoFooify.urlify env (rel0, resultTyp) of
612 NONE => NONE
613 | SOME urlified =>
614 let
615 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
616 (* We ensure before this step that all arguments aren't effectful.
617 by turning them into local variables as needed. *)
618 val argsInc = map (incRels 1) args
619 val check = (check (i, args), loc)
620 val store = (store (i, argsInc, urlified), loc)
621 in
622 SOME (ECase
623 (check,
624 [((PNone stringTyp, loc),
625 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
626 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
627 (* Boolean is false because we're not unurlifying from a cookie. *)
628 (EUnurlify (rel0, resultTyp, false), loc))],
629 {disc = (TOption stringTyp, loc), result = resultTyp}))
630 end
631 end
832 632
833 val freeVars = 633 val freeVars =
834 IS.listItems 634 IS.listItems
835 o MonoUtil.Exp.foldB 635 o MonoUtil.Exp.foldB
836 {typ = #2, 636 {typ = #2,
1003 end 803 end
1004 in 804 in
1005 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) 805 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart)
1006 end 806 end
1007 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
907
908
909 (************)
910 (* Flushing *)
911 (************)
912
913 structure Invalidations = struct
914
915 val loc = dummyLoc
916
917 val optionAtomExpToExp =
918 fn NONE => (ENone stringTyp, loc)
919 | SOME e => (ESome (stringTyp,
920 (case e of
921 DmlRel n => ERel n
922 | Prim p => EPrim p
923 (* TODO: make new type containing only these two. *)
924 | _ => raise Match,
925 loc)),
926 loc)
927
928 fun eqsToInvalidation numArgs eqs =
929 let
930 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
931 in
932 inv (numArgs - 1)
933 end
934
935 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
936 represents unknown, which means a wider invalidation. *)
937 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
938 fn ([], []) => true
939 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
940 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
941 EQUAL => madeRedundantBy (xs, ys)
942 | _ => false)
943 | _ => false
944
945 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
946
947 fun invalidations ((query, numArgs), dml) =
948 (map (map optionAtomExpToExp)
949 o removeRedundant madeRedundantBy
950 o map (eqsToInvalidation numArgs)
951 o eqss)
952 (query, dml)
953
954 end
955
956 val invalidations = Invalidations.invalidations
957
958 (* DEBUG *)
959 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
960 (* val gunk' : exp list ref = ref [] *)
961
962 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
963 let
964 val flushes = List.concat
965 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
966 val doExp =
967 fn EDml (origDmlText, failureMode) =>
968 let
969 (* DEBUG *)
970 (* val () = gunk' := origDmlText :: !gunk' *)
971 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
972 val dmlText = incRels numArgs newDmlText
973 val dmlExp = EDml (dmlText, failureMode)
974 (* DEBUG *)
975 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
976 val inval =
977 case Sql.parse Sql.dml dmlText of
978 SOME dmlParsed =>
979 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
980 SOME queryNumArgs =>
981 (* DEBUG *)
982 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
983 (i, invalidations (queryNumArgs, dmlParsed)))
984 (* TODO: fail more gracefully. *)
985 | NONE => raise Match))
986 (SIMM.findList (tableToIndices, tableDml dmlParsed)))
987 | NONE => NONE
988 in
989 case inval of
990 (* TODO: fail more gracefully. *)
991 NONE => raise Match
992 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
993 end
994 | e' => e'
995 in
996 (* DEBUG *)
997 (* gunk := []; *)
998 (fileMap doExp file, index, effs)
999 end
1000
1001
1002 (***************)
1003 (* Entry point *)
1004 (***************)
1005
1006 val inlineSql =
1007 let
1008 val doExp =
1009 (* TODO: EQuery, too? *)
1010 (* ASK: should this live in [MonoOpt]? *)
1011 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
1012 let
1013 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
1014 in
1015 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
1016 end
1017 | e => e
1018 in
1019 fileMap doExp
1020 end
1021
1008 fun insertAfterDatatypes ((decls, sideInfo), newDecls) = 1022 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
1009 let 1023 let
1010 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls 1024 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
1011 in 1025 in
1012 (datatypes @ newDecls @ others, sideInfo) 1026 (datatypes @ newDecls @ others, sideInfo)