Mercurial > urweb

annotate src/lru_cache.sml @ 2307:6ae9a2784a45

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Return to working version mode
author Adam Chlipala <adam@chlipala.net>
date Sun, 20 Dec 2015 14:39:50 -0500
parents 6e580e319077
children
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@2286 27 fun lock (index, write) =
ziv@2286 28 ffiAppCache' ((if write then "w" else "r") ^ "lock", index, [])
ziv@2286 29
ziv@2234 30
ziv@2234 31 (* Cjr *)
ziv@2234 32
ziv@2234 33 open Print
ziv@2234 34 open Print.PD
ziv@2234 35
ziv@2234 36 fun setupQuery {index, params} =
ziv@2234 37 let
ziv@2234 38
ziv@2234 39 val i = Int.toString index
ziv@2234 40
ziv@2234 41 fun paramRepeat itemi sep =
ziv@2234 42 let
ziv@2234 43 fun f n =
ziv@2234 44 if n < 0 then ""
ziv@2234 45 else if n = 0 then itemi (Int.toString 0)
ziv@2234 46 else f (n-1) ^ sep ^ itemi (Int.toString n)
ziv@2234 47 in
ziv@2234 48 f (params - 1)
ziv@2234 49 end
ziv@2234 50
ziv@2234 51 fun paramRepeatRev itemi sep =
ziv@2234 52 let
ziv@2234 53 fun f n =
ziv@2234 54 if n < 0 then ""
ziv@2234 55 else if n = 0 then itemi (Int.toString 0)
ziv@2234 56 else itemi (Int.toString n) ^ sep ^ f (n-1)
ziv@2234 57 in
ziv@2234 58 f (params - 1)
ziv@2234 59 end
ziv@2234 60
ziv@2234 61 fun paramRepeatInit itemi sep =
ziv@2234 62 if params = 0 then "" else sep ^ paramRepeat itemi sep
ziv@2234 63
ziv@2234 64 val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
ziv@2234 65
ziv@2234 66 val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
ziv@2234 67
adam@2298 68 val argNums = List.tabulate (params, fn i => "p" ^ Int.toString i)
ziv@2234 69 in
ziv@2234 70 Print.box
ziv@2250 71 [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
ziv@2285 72 newline,
ziv@2288 73 string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,",
ziv@2288 74 newline,
ziv@2288 75 string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,",
ziv@2234 76 newline,
ziv@2234 77 string " .table = NULL,",
ziv@2234 78 newline,
ziv@2281 79 string (" .numKeys = " ^ Int.toString params ^ ","),
ziv@2281 80 newline,
ziv@2234 81 string " .timeInvalid = 0,",
ziv@2234 82 newline,
ziv@2279 83 string " .timeNow = 0};",
ziv@2234 84 newline,
ziv@2250 85 string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
ziv@2234 86 newline,
ziv@2234 87 newline,
ziv@2234 88
ziv@2288 89 string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"),
ziv@2288 90 newline,
ziv@2288 91 string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"),
ziv@2288 92 newline,
ziv@2288 93 string "}",
ziv@2288 94 newline,
ziv@2288 95 newline,
ziv@2288 96
ziv@2288 97 string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"),
ziv@2288 98 newline,
ziv@2288 99 string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"),
ziv@2288 100 newline,
ziv@2288 101 string "}",
ziv@2288 102 newline,
ziv@2288 103 newline,
ziv@2288 104
ziv@2234 105 string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
ziv@2234 106 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 107 newline,
ziv@2234 108 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 109 newline,
ziv@2285 110 string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"),
ziv@2234 111 newline,
ziv@2262 112 (* If the output is null, it means we had too much recursion, so it's a miss. *)
ziv@2262 113 string " if (v && v->output != NULL) {",
ziv@2234 114 newline,
adam@2296 115 (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
adam@2296 116 newline,*)
ziv@2234 117 string " uw_write(ctx, v->output);",
ziv@2234 118 newline,
ziv@2234 119 string " return v->result;",
ziv@2234 120 newline,
ziv@2234 121 string " } else {",
ziv@2234 122 newline,
adam@2298 123 (*string (" printf(\"SQLCACHE: miss " ^ i ^ " " ^ String.concatWith ", " (List.tabulate (params, fn _ => "%s")) ^ ".\\n\""),
adam@2298 124 (case argNums of
adam@2298 125 [] => Print.box []
adam@2298 126 | _ => Print.box [string ", ",
adam@2298 127 p_list string argNums]),
adam@2298 128 string ");",
adam@2296 129 newline,*)
ziv@2234 130 string " uw_recordingStart(ctx);",
ziv@2234 131 newline,
ziv@2234 132 string " return NULL;",
ziv@2234 133 newline,
ziv@2234 134 string " }",
ziv@2234 135 newline,
ziv@2234 136 string "}",
ziv@2234 137 newline,
ziv@2234 138 newline,
ziv@2234 139
ziv@2234 140 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 141 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 142 newline,
ziv@2234 143 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 144 newline,
adam@2297 145 string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"),
ziv@2234 146 newline,
ziv@2234 147 string " v->result = strdup(s);",
ziv@2234 148 newline,
ziv@2234 149 string " v->output = uw_recordingRead(ctx);",
ziv@2234 150 newline,
adam@2296 151 (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
adam@2296 152 newline,*)
ziv@2285 153 string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"),
ziv@2234 154 newline,
ziv@2234 155 string " return uw_unit_v;",
ziv@2234 156 newline,
ziv@2234 157 string "}",
ziv@2234 158 newline,
ziv@2234 159 newline,
ziv@2234 160
ziv@2234 161 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 162 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 163 newline,
ziv@2234 164 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 165 newline,
ziv@2284 166 string (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"),
ziv@2234 167 newline,
adam@2298 168 (*string (" puts(\"SQLCACHE: flushed " ^ i ^ ".\");"),
adam@2298 169 newline,*)
ziv@2234 170 string " return uw_unit_v;",
ziv@2234 171 newline,
ziv@2234 172 string "}",
ziv@2234 173 newline,
ziv@2234 174 newline]
ziv@2234 175 end
ziv@2234 176
ziv@2234 177 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 178
ziv@2234 179
ziv@2234 180 (* Bundled up. *)
ziv@2234 181
ziv@2234 182 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 183 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 184 if numKeys args = 0
ziv@2234 185 then implToy args
ziv@2234 186 else implLru args
ziv@2234 187
ziv@2234 188 val cache =
ziv@2286 189 (* let *)
ziv@2286 190 (* val {check = toyCheck, *)
ziv@2286 191 (* store = toyStore, *)
ziv@2286 192 (* flush = toyFlush, *)
ziv@2286 193 (* setupQuery = toySetupQuery, *)
ziv@2286 194 (* ...} = ToyCache.cache *)
ziv@2286 195 (* in *)
ziv@2286 196 (* {check = toyIfNoKeys (length o #2) check toyCheck, *)
ziv@2286 197 (* store = toyIfNoKeys (length o #2) store toyStore, *)
ziv@2286 198 (* flush = toyIfNoKeys (length o #2) flush toyFlush, *)
ziv@2286 199 {check = check, store = store, flush = flush, lock = lock,
ziv@2286 200 setupQuery = setupQuery, setupGlobal = setupGlobal}
ziv@2286 201 (* end *)
ziv@2234 202
ziv@2234 203 end