Mercurial > urweb

comparison src/sqlcache.sml @ 2262:34ad83d9b729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author Ziv Scully <ziv@mit.edu>
date Wed, 07 Oct 2015 08:58:08 -0400
parents f81f1930c5d6
children bbcf9ba9b39a
comparison
equal deleted inserted replaced
2261:f81f1930c5d6 2262:34ad83d9b729
51 fun setCache c = cache := c 51 fun setCache c = cache := c
52 fun getCache () = !cache 52 fun getCache () = !cache
53 53
54 (* Used to have type context for local variables in MonoUtil functions. *) 54 (* Used to have type context for local variables in MonoUtil functions. *)
55 val doBind = 55 val doBind =
56 fn (env, MonoUtil.Exp.RelE (s, t)) => MonoEnv.pushERel env s t NONE 56 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
57 | (env, _) => env 57 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
58 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
58 59
59 60
60 (*******************) 61 (*******************)
61 (* Effect Analysis *) 62 (* Effect Analysis *)
62 (*******************) 63 (*******************)
497 498
498 fun cacheWrap (env, exp, resultTyp, args, i) = 499 fun cacheWrap (env, exp, resultTyp, args, i) =
499 let 500 let
500 val loc = dummyLoc 501 val loc = dummyLoc
501 val rel0 = (ERel 0, loc) 502 val rel0 = (ERel 0, loc)
502 (* DEBUG *)
503 val () = print (Int.toString i ^ "\n")
504 in 503 in
505 case MonoFooify.urlify env (rel0, resultTyp) of 504 case MonoFooify.urlify env (rel0, resultTyp) of
506 NONE => NONE 505 NONE => NONE
507 | SOME urlified => 506 | SOME urlified =>
508 let 507 let
522 (EUnurlify (rel0, resultTyp, false), loc))], 521 (EUnurlify (rel0, resultTyp, false), loc))],
523 {disc = (TOption stringTyp, loc), result = resultTyp})) 522 {disc = (TOption stringTyp, loc), result = resultTyp}))
524 end 523 end
525 end 524 end
526 525
527 fun fileMapfoldB doExp file start = 526 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
527 let
528 fun doVal env ((x, n, t, exp, s), state) =
529 let
530 val (exp, state) = doTopLevelExp env exp state
531 in
532 ((x, n, t, exp, s), state)
533 end
534 fun doDecl' env (decl', state) =
535 case decl' of
536 DVal v =>
537 let
538 val (v, state) = doVal env (v, state)
539 in
540 (DVal v, state)
541 end
542 | DValRec vs =>
543 let
544 val (vs, state) = ListUtil.foldlMap (doVal env) state vs
545 in
546 (DValRec vs, state)
547 end
548 | _ => (decl', state)
549 fun doDecl (decl as (decl', loc), (env, state)) =
550 let
551 val env = MonoEnv.declBinds env decl
552 val (decl', state) = doDecl' env (decl', state)
553 in
554 ((decl', loc), (env, state))
555 end
556 val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
557 in
558 ((decls, sideInfo), state)
559 end
560
561 fun fileAllMapfoldB doExp file start =
528 case MonoUtil.File.mapfoldB 562 case MonoUtil.File.mapfoldB
529 {typ = Search.return2, 563 {typ = Search.return2,
530 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), 564 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
531 decl = fn _ => Search.return2, 565 decl = fn _ => Search.return2,
532 bind = doBind} 566 bind = doBind}
533 MonoEnv.empty file start of 567 MonoEnv.empty file start of
534 Search.Continue x => x 568 Search.Continue x => x
535 | Search.Return _ => raise Match 569 | Search.Return _ => raise Match
536 570
537 fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) 571 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
538 572
539 fun factorOutNontrivial text = 573 fun factorOutNontrivial text =
540 let 574 let
541 val loc = dummyLoc 575 val loc = dummyLoc
542 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) 576 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
621 (* TODO: just use a reference for current index.... *) 655 (* TODO: just use a reference for current index.... *)
622 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) 656 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
623 end 657 end
624 | e' => (e', queryInfo) 658 | e' => (e', queryInfo)
625 in 659 in
626 (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp) 660 (fileAllMapfoldB (fn env => fn exp => fn state => doExp env state exp)
627 file 661 file
628 (SIMM.empty, IM.empty, 0), 662 (SIMM.empty, IM.empty, 0),
629 effs) 663 effs)
630 end 664 end
631 665
673 end 707 end
674 708
675 val invalidations = Invalidations.invalidations 709 val invalidations = Invalidations.invalidations
676 710
677 (* DEBUG *) 711 (* DEBUG *)
678 val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] 712 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
679 val gunk' : exp list ref = ref [] 713 (* val gunk' : exp list ref = ref [] *)
680 714
681 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = 715 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
682 let 716 let
683 val flushes = List.concat 717 val flushes = List.concat
684 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) 718 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
685 val doExp = 719 val doExp =
686 fn EDml (origDmlText, failureMode) => 720 fn EDml (origDmlText, failureMode) =>
687 let 721 let
688 (* DEBUG *) 722 (* DEBUG *)
689 val () = gunk' := origDmlText :: !gunk' 723 (* val () = gunk' := origDmlText :: !gunk' *)
690 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText 724 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
691 val dmlText = incRels numArgs newDmlText 725 val dmlText = incRels numArgs newDmlText
692 val dmlExp = EDml (dmlText, failureMode) 726 val dmlExp = EDml (dmlText, failureMode)
693 (* DEBUG *) 727 (* DEBUG *)
694 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) 728 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
695 val inval = 729 val inval =
696 case Sql.parse Sql.dml dmlText of 730 case Sql.parse Sql.dml dmlText of
697 SOME dmlParsed => 731 SOME dmlParsed =>
698 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of 732 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
699 SOME queryNumArgs => 733 SOME queryNumArgs =>
700 (* DEBUG *) 734 (* DEBUG *)
701 (gunk := (queryNumArgs, dmlParsed) :: !gunk; 735 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
702 (i, invalidations (queryNumArgs, dmlParsed))) 736 (i, invalidations (queryNumArgs, dmlParsed)))
703 (* TODO: fail more gracefully. *) 737 (* TODO: fail more gracefully. *)
704 | NONE => raise Match)) 738 | NONE => raise Match))
705 (SIMM.findList (tableToIndices, tableDml dmlParsed))) 739 (SIMM.findList (tableToIndices, tableDml dmlParsed)))
706 | NONE => NONE 740 | NONE => NONE
711 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) 745 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
712 end 746 end
713 | e' => e' 747 | e' => e'
714 in 748 in
715 (* DEBUG *) 749 (* DEBUG *)
716 gunk := []; 750 (* gunk := []; *)
717 (fileMap doExp file, index, effs) 751 (fileMap doExp file, index, effs)
718 end 752 end
719 753
720 val inlineSql = 754 val inlineSql =
721 let 755 let
955 | SOME e' => e', 989 | SOME e' => e',
956 loc)), 990 loc)),
957 index + 1) 991 index + 1)
958 end 992 end
959 993
960 fun addPure ((decls, sideInfo), indexStart, effs) = 994 fun addPure (file, indexStart, effs) =
961 let 995 let
962 fun doVal env ((x, n, t, exp, s), index) = 996 fun doTopLevelExp env exp index =
963 let 997 let
964 val (subexp, index) = pureCache effs ((env, exp), index) 998 val (subexp, index) = pureCache effs ((env, exp), index)
965 in 999 in
966 ((x, n, t, expOfSubexp subexp, s), index) 1000 (expOfSubexp subexp, index)
967 end 1001 end
968 fun doDecl' env (decl', index) = 1002 in
969 case decl' of 1003 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart)
970 DVal v => 1004 end
971 let 1005
972 val (v, index) = doVal env (v, index) 1006 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
973 in 1007 let
974 (DVal v, index) 1008 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
975 end 1009 in
976 | DValRec vs => 1010 (datatypes @ newDecls @ others, sideInfo)
977 let 1011 end
978 val (vs, index) = ListUtil.foldlMap (doVal env) index vs 1012
979 in 1013 val go' = addPure o addFlushing o addChecking o inlineSql
980 (DValRec vs, index)
981 end
982 | _ => (decl', index)
983 fun doDecl (decl as (decl', loc), (revDecls, env, index)) =
984 let
985 val env = MonoEnv.declBinds env decl
986 val (decl', index) = doDecl' env (decl', index)
987 (* Important that this happens after [MonoFooify.urlify] calls! *)
988 val fmDecls = MonoFooify.getNewFmDecls ()
989 in
990 ((decl', loc) :: (fmDecls @ revDecls), env, index)
991 end
992 in
993 (rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo)
994 end
995
996 val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *)
997 1014
998 fun go file = 1015 fun go file =
999 let 1016 let
1000 (* TODO: do something nicer than [Sql] being in one of two modes. *) 1017 (* TODO: do something nicer than [Sql] being in one of two modes. *)
1001 val () = (resetFfiInfo (); Sql.sqlcacheMode := true) 1018 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
1002 val file' = go' file 1019 val file = go' file
1020 (* Important that this happens after [MonoFooify.urlify] calls! *)
1021 val fmDecls = MonoFooify.getNewFmDecls ()
1003 val () = Sql.sqlcacheMode := false 1022 val () = Sql.sqlcacheMode := false
1004 in 1023 in
1005 file' 1024 insertAfterDatatypes (file, rev fmDecls)
1006 end 1025 end
1007 1026
1008 end 1027 end