Mercurial > urweb

annotate src/lru_cache.sml @ 2282:19b233bb3176

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make cache flushes safe for transactions (not sure about LRU bump on read).
author Ziv Scully <ziv@mit.edu>
date Thu, 12 Nov 2015 09:47:20 -0500
parents 75cb60a7f6f1
children 472b4504aef2
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@2234 65 in
ziv@2234 66 Print.box
ziv@2250 67 [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
ziv@2234 68 newline,
ziv@2234 69 string " .table = NULL,",
ziv@2234 70 newline,
ziv@2281 71 string (" .numKeys = " ^ Int.toString params ^ ","),
ziv@2281 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@2281 86 string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"),
ziv@2234 87 newline,
ziv@2262 88 (* If the output is null, it means we had too much recursion, so it's a miss. *)
ziv@2262 89 string " if (v && v->output != NULL) {",
ziv@2234 90 newline,
ziv@2234 91 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
ziv@2234 92 newline,
ziv@2234 93 string " uw_write(ctx, v->output);",
ziv@2234 94 newline,
ziv@2234 95 string " return v->result;",
ziv@2234 96 newline,
ziv@2234 97 string " } else {",
ziv@2234 98 newline,
ziv@2234 99 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
ziv@2234 100 newline,
ziv@2234 101 string " uw_recordingStart(ctx);",
ziv@2234 102 newline,
ziv@2234 103 string " return NULL;",
ziv@2234 104 newline,
ziv@2234 105 string " }",
ziv@2234 106 newline,
ziv@2234 107 string "}",
ziv@2234 108 newline,
ziv@2234 109 newline,
ziv@2234 110
ziv@2234 111 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 112 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 113 newline,
ziv@2234 114 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 115 newline,
ziv@2279 116 string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"),
ziv@2234 117 newline,
ziv@2234 118 string " v->result = strdup(s);",
ziv@2234 119 newline,
ziv@2234 120 string " v->output = uw_recordingRead(ctx);",
ziv@2234 121 newline,
ziv@2234 122 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
ziv@2234 123 newline,
ziv@2281 124 string (" uw_Sqlcache_store(cache" ^ i ^ ", ks, v);"),
ziv@2234 125 newline,
ziv@2234 126 string " return uw_unit_v;",
ziv@2234 127 newline,
ziv@2234 128 string "}",
ziv@2234 129 newline,
ziv@2234 130 newline,
ziv@2234 131
ziv@2234 132 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 133 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 134 newline,
ziv@2234 135 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 136 newline,
ziv@2281 137 string (" uw_Sqlcache_flush(cache" ^ i ^ ", ks);"),
ziv@2234 138 newline,
ziv@2234 139 string " return uw_unit_v;",
ziv@2234 140 newline,
ziv@2234 141 string "}",
ziv@2234 142 newline,
ziv@2234 143 newline]
ziv@2234 144 end
ziv@2234 145
ziv@2234 146 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 147
ziv@2234 148
ziv@2234 149 (* Bundled up. *)
ziv@2234 150
ziv@2234 151 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 152 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 153 if numKeys args = 0
ziv@2234 154 then implToy args
ziv@2234 155 else implLru args
ziv@2234 156
ziv@2234 157 val cache =
ziv@2234 158 let
ziv@2234 159 val {check = toyCheck,
ziv@2234 160 store = toyStore,
ziv@2234 161 flush = toyFlush,
ziv@2234 162 setupQuery = toySetupQuery,
ziv@2234 163 ...} = ToyCache.cache
ziv@2234 164 in
ziv@2234 165 {check = toyIfNoKeys (length o #2) check toyCheck,
ziv@2234 166 store = toyIfNoKeys (length o #2) store toyStore,
ziv@2234 167 flush = toyIfNoKeys (length o #2) flush toyFlush,
ziv@2234 168 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
ziv@2234 169 setupGlobal = setupGlobal}
ziv@2234 170 end
ziv@2234 171
ziv@2234 172 end