Mercurial > urweb

annotate src/lru_cache.sml @ 2234:2f7ed04332a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Progress on LRU cache but still more known bugs to fix.
author Ziv Scully <ziv@mit.edu>
date Sun, 28 Jun 2015 12:46:51 -0700
parents
children 88cc0f44c940
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@2234 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@2234 67 [string ("static Cache cacheStruct" ^ i ^ " = {"),
ziv@2234 68 newline,
ziv@2234 69 string " .table = NULL,",
ziv@2234 70 newline,
ziv@2234 71 string " .timeInvalid = 0,",
ziv@2234 72 newline,
ziv@2234 73 string " .lru = NULL,",
ziv@2234 74 newline,
ziv@2234 75 string (" .height = " ^ Int.toString (params - 1) ^ "};"),
ziv@2234 76 newline,
ziv@2234 77 string ("static 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@2234 86 string (" CacheValue *v = check(cache" ^ i ^ ", ks);"),
ziv@2234 87 newline,
ziv@2234 88 string " if (v) {",
ziv@2234 89 newline,
ziv@2234 90 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
ziv@2234 91 newline,
ziv@2234 92 string " uw_write(ctx, v->output);",
ziv@2234 93 newline,
ziv@2234 94 string " return v->result;",
ziv@2234 95 newline,
ziv@2234 96 string " } else {",
ziv@2234 97 newline,
ziv@2234 98 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
ziv@2234 99 newline,
ziv@2234 100 string " uw_recordingStart(ctx);",
ziv@2234 101 newline,
ziv@2234 102 string " return NULL;",
ziv@2234 103 newline,
ziv@2234 104 string " }",
ziv@2234 105 newline,
ziv@2234 106 string "}",
ziv@2234 107 newline,
ziv@2234 108 newline,
ziv@2234 109
ziv@2234 110 string ("static uw_unit uw_Sqlcache_store" ^ i),
ziv@2234 111 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
ziv@2234 112 newline,
ziv@2234 113 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 114 newline,
ziv@2234 115 string (" CacheValue *v = malloc(sizeof(CacheValue));"),
ziv@2234 116 newline,
ziv@2234 117 string " v->result = strdup(s);",
ziv@2234 118 newline,
ziv@2234 119 string " v->output = uw_recordingRead(ctx);",
ziv@2234 120 newline,
ziv@2234 121 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
ziv@2234 122 newline,
ziv@2234 123 string (" store(cache" ^ i ^ ", ks, v);"),
ziv@2234 124 newline,
ziv@2234 125 string " return uw_unit_v;",
ziv@2234 126 newline,
ziv@2234 127 string "}",
ziv@2234 128 newline,
ziv@2234 129 newline,
ziv@2234 130
ziv@2234 131 string ("static uw_unit uw_Sqlcache_flush" ^ i),
ziv@2234 132 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
ziv@2234 133 newline,
ziv@2234 134 string (" char *ks[] = {" ^ revArgs ^ "};"),
ziv@2234 135 newline,
ziv@2234 136 string (" flush(cache" ^ i ^ ", ks);"),
ziv@2234 137 newline,
ziv@2234 138 string " return uw_unit_v;",
ziv@2234 139 newline,
ziv@2234 140 string "}",
ziv@2234 141 newline,
ziv@2234 142 newline]
ziv@2234 143 end
ziv@2234 144
ziv@2234 145 val setupGlobal = string "/* No global setup for LRU cache. */"
ziv@2234 146
ziv@2234 147
ziv@2234 148 (* Bundled up. *)
ziv@2234 149
ziv@2234 150 (* For now, use the toy implementation if there are no arguments. *)
ziv@2234 151 fun toyIfNoKeys numKeys implLru implToy args =
ziv@2234 152 if numKeys args = 0
ziv@2234 153 then implToy args
ziv@2234 154 else implLru args
ziv@2234 155
ziv@2234 156 val cache =
ziv@2234 157 let
ziv@2234 158 val {check = toyCheck,
ziv@2234 159 store = toyStore,
ziv@2234 160 flush = toyFlush,
ziv@2234 161 setupQuery = toySetupQuery,
ziv@2234 162 ...} = ToyCache.cache
ziv@2234 163 in
ziv@2234 164 {check = toyIfNoKeys (length o #2) check toyCheck,
ziv@2234 165 store = toyIfNoKeys (length o #2) store toyStore,
ziv@2234 166 flush = toyIfNoKeys (length o #2) flush toyFlush,
ziv@2234 167 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
ziv@2234 168 setupGlobal = setupGlobal}
ziv@2234 169 end
ziv@2234 170
ziv@2234 171 end