Mercurial > urweb

annotate src/lru_cache.sml @ 2279:32a407902d3b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Rewrite LRU cache. Now uses one big hash table and is less buggy.
author Ziv Scully <ziv@mit.edu>
date Wed, 11 Nov 2015 20:01:48 -0500
parents a647a1560628
children 75cb60a7f6f1
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@2265 16 EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
ziv@2234 17
ziv@2234 18 fun check (index, keys) =
ziv@2234 19 ffiAppCache' ("check", index, withTyp stringTyp keys)
ziv@2234 20
ziv@2234 21 fun store (index, keys, value) =
ziv@2234 22 ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys)
ziv@2234 23
ziv@2234 24 fun flush (index, keys) =
ziv@2234 25 ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
ziv@2234 26
ziv@2234 27
ziv@2234 28 (* Cjr *)
ziv@2234 29
ziv@2234 30 open Print
ziv@2234 31 open Print.PD
ziv@2234 32
ziv@2234 33 fun setupQuery {index, params} =
ziv@2234 34 let
ziv@2234 35
ziv@2234 36 val i = Int.toString index
ziv@2234 37
ziv@2234 38 fun paramRepeat itemi sep =
ziv@2234 39 let
ziv@2234 40 fun f n =
ziv@2234 41 if n < 0 then ""
ziv@2234 42 else if n = 0 then itemi (Int.toString 0)
ziv@2234 43 else f (n-1) ^ sep ^ itemi (Int.toString n)
ziv@2234 44 in
ziv@2234 45 f (params - 1)
ziv@2234 46 end
ziv@2234 47
ziv@2234 48 fun paramRepeatRev itemi sep =
ziv@2234 49 let
ziv@2234 50 fun f n =
ziv@2234 51 if n < 0 then ""
ziv@2234 52 else if n = 0 then itemi (Int.toString 0)
ziv@2234 53 else itemi (Int.toString n) ^ sep ^ f (n-1)
ziv@2234 54 in
ziv@2234 55 f (params - 1)
ziv@2234 56 end
ziv@2234 57
ziv@2234 58 fun paramRepeatInit itemi sep =
ziv@2234 59 if params = 0 then "" else sep ^ paramRepeat itemi sep
ziv@2234 60
ziv@2234 61 val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
ziv@2234 62
ziv@2234 63 val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
ziv@2234 64
ziv@2279 65 val numArgs = Int.toString params
ziv@2279 66
ziv@2234 67 in
ziv@2234 68 Print.box
ziv@2250 69 [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
ziv@2234 70 newline,
ziv@2234 71 string " .table = NULL,",
ziv@2234 72 newline,
ziv@2234 73 string " .timeInvalid = 0,",
ziv@2234 74 newline,
ziv@2279 75 string " .timeNow = 0};",
ziv@2234 76 newline,
ziv@2250 77 string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
ziv@2234 78 newline,
ziv@2234 79 newline,
ziv@2234 80
ziv@2234 81 string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
ziv@2234 82 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 83 newline,
ziv@2234 84 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 85 newline,
ziv@2279 86 string " uw_Sqlcache_Value *v = ",
ziv@2279 87 string ("uw_Sqlcache_check(cache" ^ i ^ ", ks, " ^ numArgs ^ ");"),
ziv@2234 88 newline,
ziv@2262 89 (* If the output is null, it means we had too much recursion, so it's a miss. *)
ziv@2262 90 string " if (v && v->output != NULL) {",
ziv@2234 91 newline,
ziv@2234 92 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
ziv@2234 93 newline,
ziv@2234 94 string " uw_write(ctx, v->output);",
ziv@2234 95 newline,
ziv@2234 96 string " return v->result;",
ziv@2234 97 newline,
ziv@2234 98 string " } else {",
ziv@2234 99 newline,
ziv@2234 100 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
ziv@2234 101 newline,
ziv@2234 102 string " uw_recordingStart(ctx);",
ziv@2234 103 newline,
ziv@2234 104 string " return NULL;",
ziv@2234 105 newline,
ziv@2234 106 string " }",
ziv@2234 107 newline,
ziv@2234 108 string "}",
ziv@2234 109 newline,
ziv@2234 110 newline,
ziv@2234 111
ziv@2234 112 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 113 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 114 newline,
ziv@2234 115 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 116 newline,
ziv@2279 117 string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"),
ziv@2234 118 newline,
ziv@2234 119 string " v->result = strdup(s);",
ziv@2234 120 newline,
ziv@2234 121 string " v->output = uw_recordingRead(ctx);",
ziv@2234 122 newline,
ziv@2234 123 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
ziv@2234 124 newline,
ziv@2279 125 string (" uw_Sqlcache_store(cache" ^ i ^ ", ks, " ^ numArgs ^ ", v);"),
ziv@2234 126 newline,
ziv@2234 127 string " return uw_unit_v;",
ziv@2234 128 newline,
ziv@2234 129 string "}",
ziv@2234 130 newline,
ziv@2234 131 newline,
ziv@2234 132
ziv@2234 133 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 134 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 135 newline,
ziv@2234 136 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 137 newline,
ziv@2279 138 string (" uw_Sqlcache_flush(cache" ^ i ^ ", ks, " ^ numArgs ^ ");"),
ziv@2234 139 newline,
ziv@2234 140 string " return uw_unit_v;",
ziv@2234 141 newline,
ziv@2234 142 string "}",
ziv@2234 143 newline,
ziv@2234 144 newline]
ziv@2234 145 end
ziv@2234 146
ziv@2234 147 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 148
ziv@2234 149
ziv@2234 150 (* Bundled up. *)
ziv@2234 151
ziv@2234 152 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 153 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 154 if numKeys args = 0
ziv@2234 155 then implToy args
ziv@2234 156 else implLru args
ziv@2234 157
ziv@2234 158 val cache =
ziv@2234 159 let
ziv@2234 160 val {check = toyCheck,
ziv@2234 161 store = toyStore,
ziv@2234 162 flush = toyFlush,
ziv@2234 163 setupQuery = toySetupQuery,
ziv@2234 164 ...} = ToyCache.cache
ziv@2234 165 in
ziv@2234 166 {check = toyIfNoKeys (length o #2) check toyCheck,
ziv@2234 167 store = toyIfNoKeys (length o #2) store toyStore,
ziv@2234 168 flush = toyIfNoKeys (length o #2) flush toyFlush,
ziv@2234 169 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
ziv@2234 170 setupGlobal = setupGlobal}
ziv@2234 171 end
ziv@2234 172
ziv@2234 173 end