Mercurial > urweb

annotate src/toy_cache.sml @ 2257:28a541bd2d23

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use referenced (rather than all) free variables as keys for pure caches.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 14:46:12 -0400
parents af1585e7d645
children 6951a645ccdf
rev   line source
ziv@2233 1 structure ToyCache : sig
ziv@2233 2 val cache : Cache.cache
ziv@2233 3 end = struct
ziv@2233 4
ziv@2231 5
ziv@2231 6 (* Mono *)
ziv@2231 7
ziv@2231 8 open Mono
ziv@2231 9
ziv@2231 10 val dummyLoc = ErrorMsg.dummySpan
ziv@2231 11 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
ziv@2231 12 val optionStringTyp = (TOption stringTyp, dummyLoc)
ziv@2231 13 fun withTyp typ = map (fn exp => (exp, typ))
ziv@2231 14
ziv@2231 15 fun ffiAppCache' (func, index, argTyps) =
ziv@2231 16 EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
ziv@2231 17
ziv@2231 18 fun check (index, keys) =
ziv@2231 19 ffiAppCache' ("check", index, withTyp stringTyp keys)
ziv@2231 20
ziv@2231 21 fun store (index, keys, value) =
ziv@2231 22 ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys)
ziv@2231 23
ziv@2231 24 fun flush (index, keys) =
ziv@2231 25 ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
ziv@2231 26
ziv@2231 27
ziv@2231 28 (* Cjr *)
ziv@2231 29
ziv@2231 30 open Print
ziv@2231 31 open Print.PD
ziv@2231 32
ziv@2231 33 fun setupQuery {index, params} =
ziv@2231 34 let
ziv@2231 35
ziv@2231 36 val i = Int.toString index
ziv@2231 37
ziv@2231 38 fun paramRepeat itemi sep =
ziv@2231 39 let
ziv@2231 40 fun f n =
ziv@2231 41 if n < 0 then ""
ziv@2231 42 else if n = 0 then itemi (Int.toString 0)
ziv@2231 43 else f (n-1) ^ sep ^ itemi (Int.toString n)
ziv@2231 44 in
ziv@2231 45 f (params - 1)
ziv@2231 46 end
ziv@2231 47
ziv@2231 48 fun paramRepeatInit itemi sep =
ziv@2231 49 if params = 0 then "" else sep ^ paramRepeat itemi sep
ziv@2231 50
ziv@2231 51 val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
ziv@2231 52
ziv@2231 53 val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_"
ziv@2231 54 ^ p ^ " = NULL;")
ziv@2231 55 "\n"
ziv@2231 56
ziv@2231 57 val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p
ziv@2231 58 ^ " = strdup(p" ^ p ^ ");")
ziv@2231 59 "\n"
ziv@2231 60
ziv@2231 61 val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");")
ziv@2231 62 "\n"
ziv@2231 63
ziv@2231 64 val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p
ziv@2231 65 ^ ", p" ^ p ^ ")")
ziv@2231 66 " || "
ziv@2231 67
ziv@2231 68 (* Using [!=] instead of [==] to mimic [strcmp]. *)
ziv@2231 69 val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || "
ziv@2231 70 ^ "!strcmp(param" ^ i ^ "_"
ziv@2231 71 ^ p ^ ", p" ^ p ^ "))")
ziv@2231 72 " && "
ziv@2231 73
ziv@2231 74 in
ziv@2231 75 Print.box
ziv@2231 76 [string "static char *cacheQuery",
ziv@2231 77 string i,
ziv@2231 78 string " = NULL;",
ziv@2231 79 newline,
ziv@2231 80 string "static char *cacheWrite",
ziv@2231 81 string i,
ziv@2231 82 string " = NULL;",
ziv@2231 83 newline,
ziv@2231 84 string decls,
ziv@2231 85 newline,
ziv@2231 86 string "static uw_Basis_string uw_Sqlcache_check",
ziv@2231 87 string i,
ziv@2231 88 string "(uw_context ctx",
ziv@2231 89 string args,
ziv@2231 90 string ") {",
ziv@2231 91 newline,
ziv@2231 92 string "if (cacheQuery",
ziv@2231 93 string i,
ziv@2231 94 (* ASK: is returning the pointer okay? Should we duplicate? *)
ziv@2231 95 string " == NULL",
ziv@2231 96 string eqs,
ziv@2231 97 string ") {",
ziv@2231 98 newline,
ziv@2231 99 string "puts(\"SQLCACHE: miss ",
ziv@2231 100 string i,
ziv@2231 101 string ".\");",
ziv@2231 102 newline,
ziv@2231 103 string "uw_recordingStart(ctx);",
ziv@2231 104 newline,
ziv@2231 105 string "return NULL;",
ziv@2231 106 newline,
ziv@2231 107 string "} else {",
ziv@2231 108 newline,
ziv@2231 109 string "puts(\"SQLCACHE: hit ",
ziv@2231 110 string i,
ziv@2231 111 string ".\");",
ziv@2231 112 newline,
ziv@2231 113 string "uw_write(ctx, cacheWrite",
ziv@2231 114 string i,
ziv@2231 115 string ");",
ziv@2231 116 newline,
ziv@2231 117 string "return cacheQuery",
ziv@2231 118 string i,
ziv@2231 119 string ";",
ziv@2231 120 newline,
ziv@2231 121 string "} };",
ziv@2231 122 newline,
ziv@2231 123 string "static uw_unit uw_Sqlcache_store",
ziv@2231 124 string i,
ziv@2231 125 string "(uw_context ctx, uw_Basis_string s",
ziv@2231 126 string args,
ziv@2231 127 string ") {",
ziv@2231 128 newline,
ziv@2231 129 string "free(cacheQuery",
ziv@2231 130 string i,
ziv@2231 131 string "); free(cacheWrite",
ziv@2231 132 string i,
ziv@2231 133 string ");",
ziv@2231 134 newline,
ziv@2231 135 string frees,
ziv@2231 136 newline,
ziv@2231 137 string "cacheQuery",
ziv@2231 138 string i,
ziv@2231 139 string " = strdup(s); cacheWrite",
ziv@2231 140 string i,
ziv@2231 141 string " = uw_recordingRead(ctx);",
ziv@2231 142 newline,
ziv@2231 143 string sets,
ziv@2231 144 newline,
ziv@2231 145 string "puts(\"SQLCACHE: store ",
ziv@2231 146 string i,
ziv@2231 147 string ".\");",
ziv@2231 148 newline,
ziv@2231 149 string "return uw_unit_v;",
ziv@2231 150 newline,
ziv@2231 151 string "};",
ziv@2231 152 newline,
ziv@2231 153 string "static uw_unit uw_Sqlcache_flush",
ziv@2231 154 string i,
ziv@2231 155 string "(uw_context ctx",
ziv@2231 156 string args,
ziv@2231 157 string ") {",
ziv@2231 158 newline,
ziv@2231 159 string "if (cacheQuery",
ziv@2231 160 string i,
ziv@2231 161 string " != NULL",
ziv@2231 162 string eqsNull,
ziv@2231 163 string ") {",
ziv@2231 164 newline,
ziv@2231 165 string "free(cacheQuery",
ziv@2231 166 string i,
ziv@2231 167 string ");",
ziv@2231 168 newline,
ziv@2231 169 string "cacheQuery",
ziv@2231 170 string i,
ziv@2231 171 string " = NULL;",
ziv@2231 172 newline,
ziv@2231 173 string "puts(\"SQLCACHE: flush ",
ziv@2231 174 string i,
ziv@2231 175 string ".\");}",
ziv@2231 176 newline,
ziv@2231 177 string "else { puts(\"SQLCACHE: keep ",
ziv@2231 178 string i,
ziv@2231 179 string ".\"); } return uw_unit_v;",
ziv@2231 180 newline,
ziv@2231 181 string "};",
ziv@2231 182 newline,
ziv@2231 183 newline]
ziv@2231 184 end
ziv@2231 185
ziv@2231 186 val setupGlobal = string "/* No global setup for toy cache. */"
ziv@2231 187
ziv@2233 188
ziv@2233 189 (* Bundled up. *)
ziv@2233 190
ziv@2233 191 val cache = {check = check, store = store, flush = flush,
ziv@2233 192 setupQuery = setupQuery, setupGlobal = setupGlobal}
ziv@2233 193
ziv@2231 194 end