Mercurial > urweb

annotate src/toy_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 6951a645ccdf
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