Mercurial > urweb
comparison src/prepare.sml @ 883:467285bb5578
Avoid preparing the same statement twice
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Fri, 17 Jul 2009 13:19:41 -0400 |
parents | b2a175a0f2ef |
children | 217eb87dde31 |
comparison
equal
deleted
inserted
replaced
882:9c1b7e46eed2 | 883:467285bb5578 |
---|---|
28 structure Prepare :> PREPARE = struct | 28 structure Prepare :> PREPARE = struct |
29 | 29 |
30 open Cjr | 30 open Cjr |
31 open Settings | 31 open Settings |
32 | 32 |
33 fun prepString (e, ss, n) = | 33 structure SM = BinaryMapFn(struct |
34 type ord_key = string | |
35 val compare = String.compare | |
36 end) | |
37 | |
38 structure St :> sig | |
39 type t | |
40 val empty : t | |
41 val nameOf : t * string -> t * int | |
42 val list : t -> (string * int) list | |
43 val count : t -> int | |
44 end = struct | |
45 | |
46 type t = {map : int SM.map, list : (string * int) list, count : int} | |
47 | |
48 val empty = {map = SM.empty, list = [], count = 0} | |
49 | |
50 fun nameOf (t as {map, list, count}, s) = | |
51 case SM.find (map, s) of | |
52 NONE => ({map = SM.insert (map, s, count), list = (s, count) :: list, count = count + 1}, count) | |
53 | SOME n => (t, n) | |
54 | |
55 fun list (t : t) = rev (#list t) | |
56 fun count (t : t) = #count t | |
57 | |
58 end | |
59 | |
60 fun prepString (e, st) = | |
34 let | 61 let |
35 fun doOne t = | 62 fun prepString' (e, ss, n) = |
36 SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1) | 63 let |
64 fun doOne t = | |
65 SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1) | |
66 in | |
67 case #1 e of | |
68 EPrim (Prim.String s) => | |
69 SOME (s :: ss, n) | |
70 | EFfiApp ("Basis", "strcat", [e1, e2]) => | |
71 (case prepString' (e1, ss, n) of | |
72 NONE => NONE | |
73 | SOME (ss, n) => prepString' (e2, ss, n)) | |
74 | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int | |
75 | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float | |
76 | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String | |
77 | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool | |
78 | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time | |
79 | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob | |
80 | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel | |
81 | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client | |
82 | |
83 | ECase (e, | |
84 [((PNone _, _), | |
85 (EPrim (Prim.String "NULL"), _)), | |
86 ((PSome (_, (PVar _, _)), _), | |
87 (EFfiApp (m, x, [(ERel 0, _)]), _))], | |
88 _) => prepString' ((EFfiApp (m, x, [e]), #2 e), ss, n) | |
89 | |
90 | ECase (e, | |
91 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), | |
92 (EPrim (Prim.String "TRUE"), _)), | |
93 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), | |
94 (EPrim (Prim.String "FALSE"), _))], | |
95 _) => doOne Bool | |
96 | |
97 | _ => NONE | |
98 end | |
37 in | 99 in |
38 case #1 e of | 100 case prepString' (e, [], 0) of |
39 EPrim (Prim.String s) => | 101 NONE => NONE |
40 SOME (s :: ss, n) | 102 | SOME (ss, n) => |
41 | EFfiApp ("Basis", "strcat", [e1, e2]) => | 103 let |
42 (case prepString (e1, ss, n) of | 104 val s = String.concat (rev ss) |
43 NONE => NONE | 105 val (st, id) = St.nameOf (st, s) |
44 | SOME (ss, n) => prepString (e2, ss, n)) | 106 in |
45 | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int | 107 SOME (id, s, st) |
46 | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float | 108 end |
47 | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String | |
48 | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool | |
49 | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time | |
50 | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob | |
51 | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel | |
52 | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client | |
53 | |
54 | ECase (e, | |
55 [((PNone _, _), | |
56 (EPrim (Prim.String "NULL"), _)), | |
57 ((PSome (_, (PVar _, _)), _), | |
58 (EFfiApp (m, x, [(ERel 0, _)]), _))], | |
59 _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n) | |
60 | |
61 | ECase (e, | |
62 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), | |
63 (EPrim (Prim.String "TRUE"), _)), | |
64 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), | |
65 (EPrim (Prim.String "FALSE"), _))], | |
66 _) => doOne Bool | |
67 | |
68 | _ => NONE | |
69 end | 109 end |
70 | 110 |
71 fun prepExp (e as (_, loc), sns) = | 111 fun prepExp (e as (_, loc), st) = |
72 case #1 e of | 112 case #1 e of |
73 EPrim _ => (e, sns) | 113 EPrim _ => (e, st) |
74 | ERel _ => (e, sns) | 114 | ERel _ => (e, st) |
75 | ENamed _ => (e, sns) | 115 | ENamed _ => (e, st) |
76 | ECon (_, _, NONE) => (e, sns) | 116 | ECon (_, _, NONE) => (e, st) |
77 | ECon (dk, pc, SOME e) => | 117 | ECon (dk, pc, SOME e) => |
78 let | 118 let |
79 val (e, sns) = prepExp (e, sns) | 119 val (e, st) = prepExp (e, st) |
80 in | 120 in |
81 ((ECon (dk, pc, SOME e), loc), sns) | 121 ((ECon (dk, pc, SOME e), loc), st) |
82 end | 122 end |
83 | ENone t => (e, sns) | 123 | ENone t => (e, st) |
84 | ESome (t, e) => | 124 | ESome (t, e) => |
85 let | 125 let |
86 val (e, sns) = prepExp (e, sns) | 126 val (e, st) = prepExp (e, st) |
87 in | 127 in |
88 ((ESome (t, e), loc), sns) | 128 ((ESome (t, e), loc), st) |
89 end | 129 end |
90 | EFfi _ => (e, sns) | 130 | EFfi _ => (e, st) |
91 | EFfiApp (m, x, es) => | 131 | EFfiApp (m, x, es) => |
92 let | 132 let |
93 val (es, sns) = ListUtil.foldlMap prepExp sns es | 133 val (es, st) = ListUtil.foldlMap prepExp st es |
94 in | 134 in |
95 ((EFfiApp (m, x, es), loc), sns) | 135 ((EFfiApp (m, x, es), loc), st) |
96 end | 136 end |
97 | EApp (e1, es) => | 137 | EApp (e1, es) => |
98 let | 138 let |
99 val (e1, sns) = prepExp (e1, sns) | 139 val (e1, st) = prepExp (e1, st) |
100 val (es, sns) = ListUtil.foldlMap prepExp sns es | 140 val (es, st) = ListUtil.foldlMap prepExp st es |
101 in | 141 in |
102 ((EApp (e1, es), loc), sns) | 142 ((EApp (e1, es), loc), st) |
103 end | 143 end |
104 | 144 |
105 | EUnop (s, e1) => | 145 | EUnop (s, e1) => |
106 let | 146 let |
107 val (e1, sns) = prepExp (e1, sns) | 147 val (e1, st) = prepExp (e1, st) |
108 in | 148 in |
109 ((EUnop (s, e1), loc), sns) | 149 ((EUnop (s, e1), loc), st) |
110 end | 150 end |
111 | EBinop (s, e1, e2) => | 151 | EBinop (s, e1, e2) => |
112 let | 152 let |
113 val (e1, sns) = prepExp (e1, sns) | 153 val (e1, st) = prepExp (e1, st) |
114 val (e2, sns) = prepExp (e2, sns) | 154 val (e2, st) = prepExp (e2, st) |
115 in | 155 in |
116 ((EBinop (s, e1, e2), loc), sns) | 156 ((EBinop (s, e1, e2), loc), st) |
117 end | 157 end |
118 | 158 |
119 | ERecord (rn, xes) => | 159 | ERecord (rn, xes) => |
120 let | 160 let |
121 val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) => | 161 val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) => |
122 let | 162 let |
123 val (e, sns) = prepExp (e, sns) | 163 val (e, st) = prepExp (e, st) |
124 in | 164 in |
125 ((x, e), sns) | 165 ((x, e), st) |
126 end) sns xes | 166 end) st xes |
127 in | 167 in |
128 ((ERecord (rn, xes), loc), sns) | 168 ((ERecord (rn, xes), loc), st) |
129 end | 169 end |
130 | EField (e, s) => | 170 | EField (e, s) => |
131 let | 171 let |
132 val (e, sns) = prepExp (e, sns) | 172 val (e, st) = prepExp (e, st) |
133 in | 173 in |
134 ((EField (e, s), loc), sns) | 174 ((EField (e, s), loc), st) |
135 end | 175 end |
136 | 176 |
137 | ECase (e, pes, ts) => | 177 | ECase (e, pes, ts) => |
138 let | 178 let |
139 val (e, sns) = prepExp (e, sns) | 179 val (e, st) = prepExp (e, st) |
140 val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) => | 180 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => |
141 let | 181 let |
142 val (e, sns) = prepExp (e, sns) | 182 val (e, st) = prepExp (e, st) |
143 in | 183 in |
144 ((p, e), sns) | 184 ((p, e), st) |
145 end) sns pes | 185 end) st pes |
146 in | 186 in |
147 ((ECase (e, pes, ts), loc), sns) | 187 ((ECase (e, pes, ts), loc), st) |
148 end | 188 end |
149 | 189 |
150 | EError (e, t) => | 190 | EError (e, t) => |
151 let | 191 let |
152 val (e, sns) = prepExp (e, sns) | 192 val (e, st) = prepExp (e, st) |
153 in | 193 in |
154 ((EError (e, t), loc), sns) | 194 ((EError (e, t), loc), st) |
155 end | 195 end |
156 | 196 |
157 | EReturnBlob {blob, mimeType, t} => | 197 | EReturnBlob {blob, mimeType, t} => |
158 let | 198 let |
159 val (blob, sns) = prepExp (blob, sns) | 199 val (blob, st) = prepExp (blob, st) |
160 val (mimeType, sns) = prepExp (mimeType, sns) | 200 val (mimeType, st) = prepExp (mimeType, st) |
161 in | 201 in |
162 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sns) | 202 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) |
163 end | 203 end |
164 | 204 |
165 | EWrite e => | 205 | EWrite e => |
166 let | 206 let |
167 val (e, sns) = prepExp (e, sns) | 207 val (e, st) = prepExp (e, st) |
168 in | 208 in |
169 ((EWrite e, loc), sns) | 209 ((EWrite e, loc), st) |
170 end | 210 end |
171 | ESeq (e1, e2) => | 211 | ESeq (e1, e2) => |
172 let | 212 let |
173 val (e1, sns) = prepExp (e1, sns) | 213 val (e1, st) = prepExp (e1, st) |
174 val (e2, sns) = prepExp (e2, sns) | 214 val (e2, st) = prepExp (e2, st) |
175 in | 215 in |
176 ((ESeq (e1, e2), loc), sns) | 216 ((ESeq (e1, e2), loc), st) |
177 end | 217 end |
178 | ELet (x, t, e1, e2) => | 218 | ELet (x, t, e1, e2) => |
179 let | 219 let |
180 val (e1, sns) = prepExp (e1, sns) | 220 val (e1, st) = prepExp (e1, st) |
181 val (e2, sns) = prepExp (e2, sns) | 221 val (e2, st) = prepExp (e2, st) |
182 in | 222 in |
183 ((ELet (x, t, e1, e2), loc), sns) | 223 ((ELet (x, t, e1, e2), loc), st) |
184 end | 224 end |
185 | 225 |
186 | EQuery {exps, tables, rnum, state, query, body, initial, ...} => | 226 | EQuery {exps, tables, rnum, state, query, body, initial, ...} => |
187 let | 227 let |
188 val (body, sns) = prepExp (body, sns) | 228 val (body, st) = prepExp (body, st) |
189 in | 229 in |
190 case prepString (query, [], 0) of | 230 case prepString (query, st) of |
191 NONE => | 231 NONE => |
192 ((EQuery {exps = exps, tables = tables, rnum = rnum, | 232 ((EQuery {exps = exps, tables = tables, rnum = rnum, |
193 state = state, query = query, body = body, | 233 state = state, query = query, body = body, |
194 initial = initial, prepared = NONE}, loc), | 234 initial = initial, prepared = NONE}, loc), |
195 sns) | 235 st) |
196 | SOME (ss, n) => | 236 | SOME (id, s, st) => |
197 let | 237 ((EQuery {exps = exps, tables = tables, rnum = rnum, |
198 val s = String.concat (rev ss) | 238 state = state, query = query, body = body, |
199 in | 239 initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st) |
200 ((EQuery {exps = exps, tables = tables, rnum = rnum, | |
201 state = state, query = query, body = body, | |
202 initial = initial, prepared = SOME {id = #2 sns, query = s, nested = true}}, loc), | |
203 ((s, n) :: #1 sns, #2 sns + 1)) | |
204 end | |
205 end | 240 end |
206 | 241 |
207 | EDml {dml, ...} => | 242 | EDml {dml, ...} => |
208 (case prepString (dml, [], 0) of | 243 (case prepString (dml, st) of |
209 NONE => (e, sns) | 244 NONE => (e, st) |
210 | SOME (ss, n) => | 245 | SOME (id, s, st) => |
211 let | 246 ((EDml {dml = dml, prepared = SOME {id = id, dml = s}}, loc), st)) |
212 val s = String.concat (rev ss) | |
213 in | |
214 ((EDml {dml = dml, prepared = SOME {id = #2 sns, dml = s}}, loc), | |
215 ((s, n) :: #1 sns, #2 sns + 1)) | |
216 end) | |
217 | 247 |
218 | ENextval {seq, ...} => | 248 | ENextval {seq, ...} => |
219 if #supportsNextval (Settings.currentDbms ()) then | 249 if #supportsNextval (Settings.currentDbms ()) then |
220 let | 250 let |
221 val s = case seq of | 251 val s = case seq of |
226 val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) | 256 val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) |
227 in | 257 in |
228 (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) | 258 (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) |
229 end | 259 end |
230 in | 260 in |
231 case prepString (s, [], 0) of | 261 case prepString (s, st) of |
232 NONE => (e, sns) | 262 NONE => (e, st) |
233 | SOME (ss, n) => | 263 | SOME (id, s, st) => |
234 let | 264 ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st) |
235 val s = String.concat (rev ss) | |
236 in | |
237 ((ENextval {seq = seq, prepared = SOME {id = #2 sns, query = s}}, loc), | |
238 ((s, n) :: #1 sns, #2 sns + 1)) | |
239 end | |
240 end | 265 end |
241 else | 266 else |
242 (e, sns) | 267 (e, st) |
243 | 268 |
244 | EUnurlify (e, t) => | 269 | EUnurlify (e, t) => |
245 let | 270 let |
246 val (e, sns) = prepExp (e, sns) | 271 val (e, st) = prepExp (e, st) |
247 in | 272 in |
248 ((EUnurlify (e, t), loc), sns) | 273 ((EUnurlify (e, t), loc), st) |
249 end | 274 end |
250 | 275 |
251 fun prepDecl (d as (_, loc), sns) = | 276 fun prepDecl (d as (_, loc), st) = |
252 case #1 d of | 277 case #1 d of |
253 DStruct _ => (d, sns) | 278 DStruct _ => (d, st) |
254 | DDatatype _ => (d, sns) | 279 | DDatatype _ => (d, st) |
255 | DDatatypeForward _ => (d, sns) | 280 | DDatatypeForward _ => (d, st) |
256 | DVal (x, n, t, e) => | 281 | DVal (x, n, t, e) => |
257 let | 282 let |
258 val (e, sns) = prepExp (e, sns) | 283 val (e, st) = prepExp (e, st) |
259 in | 284 in |
260 ((DVal (x, n, t, e), loc), sns) | 285 ((DVal (x, n, t, e), loc), st) |
261 end | 286 end |
262 | DFun (x, n, xts, t, e) => | 287 | DFun (x, n, xts, t, e) => |
263 let | 288 let |
264 val (e, sns) = prepExp (e, sns) | 289 val (e, st) = prepExp (e, st) |
265 in | 290 in |
266 ((DFun (x, n, xts, t, e), loc), sns) | 291 ((DFun (x, n, xts, t, e), loc), st) |
267 end | 292 end |
268 | DFunRec fs => | 293 | DFunRec fs => |
269 let | 294 let |
270 val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) => | 295 val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) => |
271 let | 296 let |
272 val (e, sns) = prepExp (e, sns) | 297 val (e, st) = prepExp (e, st) |
273 in | 298 in |
274 ((x, n, xts, t, e), sns) | 299 ((x, n, xts, t, e), st) |
275 end) sns fs | 300 end) st fs |
276 in | 301 in |
277 ((DFunRec fs, loc), sns) | 302 ((DFunRec fs, loc), st) |
278 end | 303 end |
279 | 304 |
280 | DTable _ => (d, sns) | 305 | DTable _ => (d, st) |
281 | DSequence _ => (d, sns) | 306 | DSequence _ => (d, st) |
282 | DView _ => (d, sns) | 307 | DView _ => (d, st) |
283 | DDatabase _ => (d, sns) | 308 | DDatabase _ => (d, st) |
284 | DPreparedStatements _ => (d, sns) | 309 | DPreparedStatements _ => (d, st) |
285 | DJavaScript _ => (d, sns) | 310 | DJavaScript _ => (d, st) |
286 | DCookie _ => (d, sns) | 311 | DCookie _ => (d, st) |
287 | DStyle _ => (d, sns) | 312 | DStyle _ => (d, st) |
288 | 313 |
289 fun prepare (ds, ps) = | 314 fun prepare (ds, ps) = |
290 let | 315 let |
291 val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds | 316 val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds |
292 in | 317 in |
293 ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps) | 318 ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps) |
294 end | 319 end |
295 | 320 |
296 end | 321 end |
297 |