Mercurial > urweb

comparison src/sqlcache.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents 28a541bd2d23
children 6951a645ccdf
comparison
equal deleted inserted replaced
2257:28a541bd2d23 2258:b1ba35ce2613
24 24
25 (* Some FFIs have writing as their only effect, which the caching records. *) 25 (* Some FFIs have writing as their only effect, which the caching records. *)
26 val ffiEffectful = 26 val ffiEffectful =
27 (* ASK: how can this be less hard-coded? *) 27 (* ASK: how can this be less hard-coded? *)
28 let 28 let
29 val fs = SS.fromList ["htmlifyInt_w", 29 val okayWrites = SS.fromList ["htmlifyInt_w",
30 "htmlifyFloat_w", 30 "htmlifyFloat_w",
31 "htmlifyString_w", 31 "htmlifyString_w",
32 "htmlifyBool_w", 32 "htmlifyBool_w",
33 "htmlifyTime_w", 33 "htmlifyTime_w",
34 "attrifyInt_w", 34 "attrifyInt_w",
35 "attrifyFloat_w", 35 "attrifyFloat_w",
36 "attrifyString_w", 36 "attrifyString_w",
37 "attrifyChar_w", 37 "attrifyChar_w",
38 "urlifyInt_w", 38 "urlifyInt_w",
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 fn (m, f) => Settings.isEffectful (m, f) 44 fn (m, f) => Settings.isEffectful (m, f)
45 orelse not (m = "Basis" andalso SS.member (fs, f)) 45 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
46 end 46 end
47 47
48 val cache = ref LruCache.cache 48 val cache = ref LruCache.cache
49 fun setCache c = cache := c 49 fun setCache c = cache := c
50 fun getCache () = !cache 50 fun getCache () = !cache
546 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) 546 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
547 | Sql.Exp e => 547 | Sql.Exp e =>
548 let 548 let
549 val n = length newVars 549 val n = length newVars
550 in 550 in
551 (* This is the (n + 1)th new variable, so there are 551 (* This is the (n+1)th new variable, so there are
552 already n new variables bound, so we increment 552 already n new variables bound, so we increment
553 indices by n. *) 553 indices by n. *)
554 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) 554 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
555 end 555 end
556 | Sql.String s => (strcat (stringExp s, qText), newVars)) 556 | Sql.String s => (strcat (stringExp s, qText), newVars))
584 tables = tables, 584 tables = tables,
585 exps = exps}, 585 exps = exps},
586 dummyLoc) 586 dummyLoc)
587 val (EQuery {query = queryText, ...}, _) = queryExp 587 val (EQuery {query = queryText, ...}, _) = queryExp
588 (* DEBUG *) 588 (* DEBUG *)
589 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) 589 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
590 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) 590 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
591 fun bind x f = Option.mapPartial f x 591 fun bind x f = Option.mapPartial f x
592 fun guard b x = if b then x else NONE 592 fun guard b x = if b then x else NONE
593 (* We use dummyTyp here. I think this is okay because databases 593 (* We use dummyTyp here. I think this is okay because databases
594 don't store (effectful) functions, but perhaps there's some 594 don't store (effectful) functions, but perhaps there's some
680 let 680 let
681 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText 681 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
682 val dmlText = incRels numArgs newDmlText 682 val dmlText = incRels numArgs newDmlText
683 val dmlExp = EDml (dmlText, failureMode) 683 val dmlExp = EDml (dmlText, failureMode)
684 (* DEBUG *) 684 (* DEBUG *)
685 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) 685 (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) *)
686 val invs = 686 val invs =
687 case Sql.parse Sql.dml dmlText of 687 case Sql.parse Sql.dml dmlText of
688 SOME dmlParsed => 688 SOME dmlParsed =>
689 map (fn i => (case IM.find (indexToQueryNumArgs, i) of 689 map (fn i => (case IM.find (indexToQueryNumArgs, i) of
690 SOME queryNumArgs => 690 SOME queryNumArgs =>
793 | (_, _, vars) => vars, 793 | (_, _, vars) => vars,
794 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 794 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
795 0 795 0
796 IS.empty 796 IS.empty
797 797
798 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
799
798 datatype subexp = Pure of unit -> exp | Impure of exp 800 datatype subexp = Pure of unit -> exp | Impure of exp
799 801
800 val isImpure = 802 val isImpure =
801 fn Pure _ => false 803 fn Pure _ => false
802 | Impure _ => true 804 | Impure _ => true
808 fun makeCache (env, exp', index) = 810 fun makeCache (env, exp', index) =
809 case typOfExp' env exp' of 811 case typOfExp' env exp' of
810 NONE => NONE 812 NONE => NONE
811 | SOME (TFun _, _) => NONE 813 | SOME (TFun _, _) => NONE
812 | SOME typ => 814 | SOME typ =>
813 case List.foldr (fn ((_, _), NONE) => NONE 815 if expSize (exp', dummyLoc) < 5 (* TODO: pick a number. *)
814 | ((n, typ), SOME args) => 816 then NONE
815 case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of 817 else case List.foldr (fn ((_, _), NONE) => NONE
816 NONE => NONE 818 | ((n, typ), SOME args) =>
817 | SOME arg => SOME (arg :: args)) 819 case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of
818 (SOME []) 820 NONE => NONE
819 (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) 821 | SOME arg => SOME (arg :: args))
820 (freeVars (exp', dummyLoc))) of 822 (SOME [])
821 NONE => NONE 823 (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
822 | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) 824 (freeVars (exp', dummyLoc))) of
825 NONE => NONE
826 | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index)
823 827
824 fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int = 828 fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int =
825 let 829 let
826 fun wrapBindN f (args : (MonoEnv.env * exp) list) = 830 fun wrapBindN f (args : (MonoEnv.env * exp) list) =
827 let 831 let
846 in 850 in
847 case exp' of 851 case exp' of
848 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e 852 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
849 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e 853 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
850 | EFfiApp (s1, s2, args) => 854 | EFfiApp (s1, s2, args) =>
851 wrapN (fn es => EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args))) 855 if ffiEffectful (s1, s2)
852 (map #1 args) 856 then (Impure exp, index)
857 else wrapN (fn es =>
858 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
859 (map #1 args)
853 | EApp (e1, e2) => wrap2 EApp (e1, e2) 860 | EApp (e1, e2) => wrap2 EApp (e1, e2)
854 | EAbs (s, t1, t2, e) => 861 | EAbs (s, t1, t2, e) =>
855 wrapBind1 (fn e => EAbs (s, t1, t2, e)) 862 wrapBind1 (fn e => EAbs (s, t1, t2, e))
856 (MonoEnv.pushERel env s t1 NONE, e) 863 (MonoEnv.pushERel env s t1 NONE, e)
857 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e 864 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
916 end 923 end
917 val decls = #1 (ListUtil.foldlMap doDecl index decls) 924 val decls = #1 (ListUtil.foldlMap doDecl index decls)
918 (* Important that this happens after the MonoFooify.urlify calls! *) 925 (* Important that this happens after the MonoFooify.urlify calls! *)
919 val fmDecls = MonoFooify.getNewFmDecls () 926 val fmDecls = MonoFooify.getNewFmDecls ()
920 in 927 in
921 print (Int.toString (length fmDecls));
922 (* ASK: fmDecls before or after? *) 928 (* ASK: fmDecls before or after? *)
923 (fmDecls @ decls, sideInfo) 929 (fmDecls @ decls, sideInfo)
924 end 930 end
925 931
926 val go' = addPure o addFlushing o addChecking o inlineSql 932 val go' = addPure o addFlushing o addChecking o inlineSql