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