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@2231
|
98 string "if (cacheQuery",
|
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@2231
|
119 string "uw_write(ctx, cacheWrite",
|
ziv@2231
|
120 string i,
|
ziv@2231
|
121 string ");",
|
ziv@2231
|
122 newline,
|
ziv@2231
|
123 string "return cacheQuery",
|
ziv@2231
|
124 string i,
|
ziv@2231
|
125 string ";",
|
ziv@2231
|
126 newline,
|
ziv@2231
|
127 string "} };",
|
ziv@2231
|
128 newline,
|
ziv@2231
|
129 string "static uw_unit uw_Sqlcache_store",
|
ziv@2231
|
130 string i,
|
ziv@2231
|
131 string "(uw_context ctx, uw_Basis_string s",
|
ziv@2231
|
132 string args,
|
ziv@2231
|
133 string ") {",
|
ziv@2231
|
134 newline,
|
ziv@2231
|
135 string "free(cacheQuery",
|
ziv@2231
|
136 string i,
|
ziv@2231
|
137 string "); free(cacheWrite",
|
ziv@2231
|
138 string i,
|
ziv@2231
|
139 string ");",
|
ziv@2231
|
140 newline,
|
ziv@2231
|
141 string frees,
|
ziv@2231
|
142 newline,
|
ziv@2231
|
143 string "cacheQuery",
|
ziv@2231
|
144 string i,
|
ziv@2231
|
145 string " = strdup(s); cacheWrite",
|
ziv@2231
|
146 string i,
|
ziv@2231
|
147 string " = uw_recordingRead(ctx);",
|
ziv@2231
|
148 newline,
|
ziv@2231
|
149 string sets,
|
ziv@2231
|
150 newline,
|
ziv@2231
|
151 string "puts(\"SQLCACHE: store ",
|
ziv@2231
|
152 string i,
|
ziv@2231
|
153 string ".\");",
|
ziv@2231
|
154 newline,
|
ziv@2231
|
155 string "return uw_unit_v;",
|
ziv@2231
|
156 newline,
|
ziv@2231
|
157 string "};",
|
ziv@2231
|
158 newline,
|
ziv@2231
|
159 string "static uw_unit uw_Sqlcache_flush",
|
ziv@2231
|
160 string i,
|
ziv@2231
|
161 string "(uw_context ctx",
|
ziv@2231
|
162 string args,
|
ziv@2231
|
163 string ") {",
|
ziv@2231
|
164 newline,
|
ziv@2231
|
165 string "if (cacheQuery",
|
ziv@2231
|
166 string i,
|
ziv@2231
|
167 string " != NULL",
|
ziv@2231
|
168 string eqsNull,
|
ziv@2231
|
169 string ") {",
|
ziv@2231
|
170 newline,
|
ziv@2231
|
171 string "free(cacheQuery",
|
ziv@2231
|
172 string i,
|
ziv@2231
|
173 string ");",
|
ziv@2231
|
174 newline,
|
ziv@2231
|
175 string "cacheQuery",
|
ziv@2231
|
176 string i,
|
ziv@2231
|
177 string " = NULL;",
|
ziv@2231
|
178 newline,
|
ziv@2231
|
179 string "puts(\"SQLCACHE: flush ",
|
ziv@2231
|
180 string i,
|
ziv@2231
|
181 string ".\");}",
|
ziv@2231
|
182 newline,
|
ziv@2231
|
183 string "else { puts(\"SQLCACHE: keep ",
|
ziv@2231
|
184 string i,
|
ziv@2231
|
185 string ".\"); } return uw_unit_v;",
|
ziv@2231
|
186 newline,
|
ziv@2231
|
187 string "};",
|
ziv@2231
|
188 newline,
|
ziv@2231
|
189 newline]
|
ziv@2231
|
190 end
|
ziv@2231
|
191
|
ziv@2231
|
192 val setupGlobal = string "/* No global setup for toy cache. */"
|
ziv@2231
|
193
|
ziv@2233
|
194
|
ziv@2233
|
195 (* Bundled up. *)
|
ziv@2233
|
196
|
ziv@2233
|
197 val cache = {check = check, store = store, flush = flush,
|
ziv@2233
|
198 setupQuery = setupQuery, setupGlobal = setupGlobal}
|
ziv@2233
|
199
|
ziv@2231
|
200 end
|