Mercurial > urweb

annotate src/lru_cache.sml @ 2264:bbcf9ba9b39a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix another mismatch between expunger SQL generation and SQL parser.
author Ziv Scully <ziv@mit.edu>
date Tue, 13 Oct 2015 20:24:37 -0400
parents 34ad83d9b729
children a647a1560628
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@2262 94 (* If the output is null, it means we had too much recursion, so it's a miss. *)
ziv@2262 95 string " if (v && v->output != NULL) {",
ziv@2234 96 newline,
ziv@2234 97 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
ziv@2234 98 newline,
ziv@2234 99 string " uw_write(ctx, v->output);",
ziv@2234 100 newline,
ziv@2234 101 string " return v->result;",
ziv@2234 102 newline,
ziv@2234 103 string " } else {",
ziv@2234 104 newline,
ziv@2234 105 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
ziv@2234 106 newline,
ziv@2234 107 string " uw_recordingStart(ctx);",
ziv@2234 108 newline,
ziv@2234 109 string " return NULL;",
ziv@2234 110 newline,
ziv@2234 111 string " }",
ziv@2234 112 newline,
ziv@2234 113 string "}",
ziv@2234 114 newline,
ziv@2234 115 newline,
ziv@2234 116
ziv@2234 117 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 118 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 119 newline,
ziv@2234 120 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 121 newline,
ziv@2250 122 string (" uw_Sqlcache_CacheValue *v = malloc(sizeof(uw_Sqlcache_CacheValue));"),
ziv@2234 123 newline,
ziv@2234 124 string " v->result = strdup(s);",
ziv@2234 125 newline,
ziv@2234 126 string " v->output = uw_recordingRead(ctx);",
ziv@2234 127 newline,
ziv@2234 128 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
ziv@2234 129 newline,
ziv@2250 130 string (" uw_Sqlcache_store(cache" ^ i ^ ", ks, v);"),
ziv@2234 131 newline,
ziv@2234 132 string " return uw_unit_v;",
ziv@2234 133 newline,
ziv@2234 134 string "}",
ziv@2234 135 newline,
ziv@2234 136 newline,
ziv@2234 137
ziv@2234 138 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 139 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 140 newline,
ziv@2234 141 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 142 newline,
ziv@2250 143 string (" uw_Sqlcache_flush(cache" ^ i ^ ", ks);"),
ziv@2234 144 newline,
ziv@2234 145 string " return uw_unit_v;",
ziv@2234 146 newline,
ziv@2234 147 string "}",
ziv@2234 148 newline,
ziv@2234 149 newline]
ziv@2234 150 end
ziv@2234 151
ziv@2234 152 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 153
ziv@2234 154
ziv@2234 155 (* Bundled up. *)
ziv@2234 156
ziv@2234 157 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 158 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 159 if numKeys args = 0
ziv@2234 160 then implToy args
ziv@2234 161 else implLru args
ziv@2234 162
ziv@2234 163 val cache =
ziv@2234 164 let
ziv@2234 165 val {check = toyCheck,
ziv@2234 166 store = toyStore,
ziv@2234 167 flush = toyFlush,
ziv@2234 168 setupQuery = toySetupQuery,
ziv@2234 169 ...} = ToyCache.cache
ziv@2234 170 in
ziv@2234 171 {check = toyIfNoKeys (length o #2) check toyCheck,
ziv@2234 172 store = toyIfNoKeys (length o #2) store toyStore,
ziv@2234 173 flush = toyIfNoKeys (length o #2) flush toyFlush,
ziv@2234 174 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
ziv@2234 175 setupGlobal = setupGlobal}
ziv@2234 176 end
ziv@2234 177
ziv@2234 178 end