Mercurial > urweb

comparison src/toy_cache.sml @ 2304:6fb9232ade99

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