Mercurial > urweb

annotate src/lru_cache.sml @ 2262:34ad83d9b729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author Ziv Scully <ziv@mit.edu>
date Wed, 07 Oct 2015 08:58:08 -0400
parents b1ba35ce2613
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