Mercurial > urweb

annotate src/lru_cache.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 c275bbc41194
children 34ad83d9b729
rev   line source
ziv@2234 1 structure LruCache : sig
ziv@2234 2 val cache : Cache.cache
ziv@2234 3 end = struct
ziv@2234 4
ziv@2234 5
ziv@2234 6 (* Mono *)
ziv@2234 7
ziv@2234 8 open Mono
ziv@2234 9
ziv@2234 10 val dummyLoc = ErrorMsg.dummySpan
ziv@2234 11 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
ziv@2234 12 val optionStringTyp = (TOption stringTyp, dummyLoc)
ziv@2234 13 fun withTyp typ = map (fn exp => (exp, typ))
ziv@2234 14
ziv@2234 15 fun ffiAppCache' (func, index, argTyps) =
ziv@2258 16 let
ziv@2258 17 val m = "Sqlcache"
ziv@2258 18 val f = func ^ Int.toString index
ziv@2258 19 in
ziv@2258 20 Settings.addEffectful (m, f);
ziv@2258 21 EFfiApp (m, f, argTyps)
ziv@2258 22 end
ziv@2234 23
ziv@2234 24 fun check (index, keys) =
ziv@2234 25 ffiAppCache' ("check", index, withTyp stringTyp keys)
ziv@2234 26
ziv@2234 27 fun store (index, keys, value) =
ziv@2234 28 ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys)
ziv@2234 29
ziv@2234 30 fun flush (index, keys) =
ziv@2234 31 ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
ziv@2234 32
ziv@2234 33
ziv@2234 34 (* Cjr *)
ziv@2234 35
ziv@2234 36 open Print
ziv@2234 37 open Print.PD
ziv@2234 38
ziv@2234 39 fun setupQuery {index, params} =
ziv@2234 40 let
ziv@2234 41
ziv@2234 42 val i = Int.toString index
ziv@2234 43
ziv@2234 44 fun paramRepeat itemi sep =
ziv@2234 45 let
ziv@2234 46 fun f n =
ziv@2234 47 if n < 0 then ""
ziv@2234 48 else if n = 0 then itemi (Int.toString 0)
ziv@2234 49 else f (n-1) ^ sep ^ itemi (Int.toString n)
ziv@2234 50 in
ziv@2234 51 f (params - 1)
ziv@2234 52 end
ziv@2234 53
ziv@2234 54 fun paramRepeatRev itemi sep =
ziv@2234 55 let
ziv@2234 56 fun f n =
ziv@2234 57 if n < 0 then ""
ziv@2234 58 else if n = 0 then itemi (Int.toString 0)
ziv@2234 59 else itemi (Int.toString n) ^ sep ^ f (n-1)
ziv@2234 60 in
ziv@2234 61 f (params - 1)
ziv@2234 62 end
ziv@2234 63
ziv@2234 64 fun paramRepeatInit itemi sep =
ziv@2234 65 if params = 0 then "" else sep ^ paramRepeat itemi sep
ziv@2234 66
ziv@2234 67 val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
ziv@2234 68
ziv@2234 69 val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
ziv@2234 70
ziv@2234 71 in
ziv@2234 72 Print.box
ziv@2250 73 [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
ziv@2234 74 newline,
ziv@2234 75 string " .table = NULL,",
ziv@2234 76 newline,
ziv@2234 77 string " .timeInvalid = 0,",
ziv@2234 78 newline,
ziv@2234 79 string " .lru = NULL,",
ziv@2234 80 newline,
ziv@2234 81 string (" .height = " ^ Int.toString (params - 1) ^ "};"),
ziv@2234 82 newline,
ziv@2250 83 string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
ziv@2234 84 newline,
ziv@2234 85 newline,
ziv@2234 86
ziv@2234 87 string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
ziv@2234 88 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 89 newline,
ziv@2234 90 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 91 newline,
ziv@2250 92 string (" uw_Sqlcache_CacheValue *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"),
ziv@2234 93 newline,
ziv@2234 94 string " if (v) {",
ziv@2234 95 newline,
ziv@2234 96 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
ziv@2234 97 newline,
ziv@2234 98 string " uw_write(ctx, v->output);",
ziv@2234 99 newline,
ziv@2234 100 string " return v->result;",
ziv@2234 101 newline,
ziv@2234 102 string " } else {",
ziv@2234 103 newline,
ziv@2234 104 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
ziv@2234 105 newline,
ziv@2234 106 string " uw_recordingStart(ctx);",
ziv@2234 107 newline,
ziv@2234 108 string " return NULL;",
ziv@2234 109 newline,
ziv@2234 110 string " }",
ziv@2234 111 newline,
ziv@2234 112 string "}",
ziv@2234 113 newline,
ziv@2234 114 newline,
ziv@2234 115
ziv@2234 116 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 117 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 118 newline,
ziv@2234 119 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 120 newline,
ziv@2250 121 string (" uw_Sqlcache_CacheValue *v = malloc(sizeof(uw_Sqlcache_CacheValue));"),
ziv@2234 122 newline,
ziv@2234 123 string " v->result = strdup(s);",
ziv@2234 124 newline,
ziv@2234 125 string " v->output = uw_recordingRead(ctx);",
ziv@2234 126 newline,
ziv@2234 127 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
ziv@2234 128 newline,
ziv@2250 129 string (" uw_Sqlcache_store(cache" ^ i ^ ", ks, v);"),
ziv@2234 130 newline,
ziv@2234 131 string " return uw_unit_v;",
ziv@2234 132 newline,
ziv@2234 133 string "}",
ziv@2234 134 newline,
ziv@2234 135 newline,
ziv@2234 136
ziv@2234 137 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 138 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 139 newline,
ziv@2234 140 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 141 newline,
ziv@2250 142 string (" uw_Sqlcache_flush(cache" ^ i ^ ", ks);"),
ziv@2234 143 newline,
ziv@2234 144 string " return uw_unit_v;",
ziv@2234 145 newline,
ziv@2234 146 string "}",
ziv@2234 147 newline,
ziv@2234 148 newline]
ziv@2234 149 end
ziv@2234 150
ziv@2234 151 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 152
ziv@2234 153
ziv@2234 154 (* Bundled up. *)
ziv@2234 155
ziv@2234 156 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 157 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 158 if numKeys args = 0
ziv@2234 159 then implToy args
ziv@2234 160 else implLru args
ziv@2234 161
ziv@2234 162 val cache =
ziv@2234 163 let
ziv@2234 164 val {check = toyCheck,
ziv@2234 165 store = toyStore,
ziv@2234 166 flush = toyFlush,
ziv@2234 167 setupQuery = toySetupQuery,
ziv@2234 168 ...} = ToyCache.cache
ziv@2234 169 in
ziv@2234 170 {check = toyIfNoKeys (length o #2) check toyCheck,
ziv@2234 171 store = toyIfNoKeys (length o #2) store toyStore,
ziv@2234 172 flush = toyIfNoKeys (length o #2) flush toyFlush,
ziv@2234 173 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
ziv@2234 174 setupGlobal = setupGlobal}
ziv@2234 175 end
ziv@2234 176
ziv@2234 177 end