Mercurial > urweb

annotate src/toy_cache.sml @ 2264:bbcf9ba9b39a

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