Mercurial > urweb

comparison src/cjr_print.sml @ 182:d11754ffe252

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Compiled pattern matching to C
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 12:43:20 -0400
parents 31dfab1d4050
children 19ee24bffbc0
comparison
equal deleted inserted replaced
181:31dfab1d4050 182:d11754ffe252
83 83
84 fun p_enamed env n = 84 fun p_enamed env n =
85 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n) 85 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
86 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n) 86 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
87 87
88 fun p_exp' par env (e, _) = 88 fun p_con_named env n =
89 string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
90 handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n)
91
92 fun p_pat_preamble env (p, _) =
93 case p of
94 PWild => (box [],
95 env)
96 | PVar (x, t) => (box [p_typ env t,
97 space,
98 string "__lwr_",
99 string x,
100 string "_",
101 string (Int.toString (E.countERels env)),
102 string ";",
103 newline],
104 env)
105 | PPrim _ => (box [], env)
106 | PCon (_, NONE) => (box [], env)
107 | PCon (_, SOME p) => p_pat_preamble env p
108 | PRecord xps =>
109 foldl (fn ((_, p, _), (pp, env)) =>
110 let
111 val (pp', env) = p_pat_preamble env p
112 in
113 (box [pp', pp], env)
114 end) (box [], env) xps
115
116 fun p_patCon env pc =
117 case pc of
118 PConVar n => p_con_named env n
119 | PConFfi _ => raise Fail "CjrPrint PConFfi"
120
121 fun p_pat (env, exit, depth) (p, _) =
122 case p of
123 PWild =>
124 (box [], env)
125 | PVar (x, t) =>
126 (box [string "__lwr_",
127 string x,
128 string "_",
129 string (Int.toString (E.countERels env)),
130 space,
131 string "=",
132 space,
133 string "disc",
134 string (Int.toString depth),
135 string ";"],
136 E.pushERel env x t)
137 | PPrim (Prim.Int n) =>
138 (box [string "if",
139 space,
140 string "(disc",
141 string (Int.toString depth),
142 space,
143 string "!=",
144 space,
145 Prim.p_t (Prim.Int n),
146 string ")",
147 space,
148 exit],
149 env)
150 | PPrim (Prim.String s) =>
151 (box [string "if",
152 space,
153 string "(strcmp(disc",
154 string (Int.toString depth),
155 string ",",
156 space,
157 Prim.p_t (Prim.String s),
158 string "))",
159 space,
160 exit],
161 env)
162 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
163
164 | PCon (pc, po) =>
165 let
166 val (p, env) =
167 case po of
168 NONE => (box [], env)
169 | SOME p =>
170 let
171 val (p, env) = p_pat (env, exit, depth + 1) p
172
173 val (x, to) = case pc of
174 PConVar n =>
175 let
176 val (x, to, _) = E.lookupConstructor env n
177 in
178 (x, to)
179 end
180 | PConFfi _ => raise Fail "PConFfi"
181
182 val t = case to of
183 NONE => raise Fail "CjrPrint: Constructor mismatch"
184 | SOME t => t
185 in
186 (box [string "{",
187 newline,
188 p_typ env t,
189 space,
190 string "disc",
191 string (Int.toString (depth + 1)),
192 space,
193 string "=",
194 space,
195 string "disc",
196 string (Int.toString depth),
197 string "->data.__lwc_",
198 string x,
199 string ";",
200 newline,
201 p,
202 newline,
203 string "}"],
204 env)
205 end
206 in
207 (box [string "if",
208 space,
209 string "(disc",
210 string (Int.toString depth),
211 string "->tag",
212 space,
213 string "!=",
214 space,
215 p_patCon env pc,
216 string ")",
217 space,
218 exit,
219 newline,
220 p],
221 env)
222 end
223
224 | PRecord xps =>
225 let
226 val (xps, env) =
227 ListUtil.foldlMap (fn ((x, p, t), env) =>
228 let
229 val (p, env) = p_pat (env, exit, depth + 1) p
230
231 val p = box [string "{",
232 newline,
233 p_typ env t,
234 space,
235 string "disc",
236 string (Int.toString (depth + 1)),
237 space,
238 string "=",
239 space,
240 string "disc",
241 string (Int.toString depth),
242 string ".",
243 string x,
244 string ";",
245 newline,
246 p,
247 newline,
248 string "}"]
249 in
250 (p, env)
251 end) env xps
252 in
253 (p_list_sep newline (fn x => x) xps,
254 env)
255 end
256
257 local
258 val count = ref 0
259 in
260 fun newGoto () =
261 let
262 val r = !count
263 in
264 count := r + 1;
265 string ("L" ^ Int.toString r)
266 end
267 end
268
269 fun p_exp' par env (e, loc) =
89 case e of 270 case e of
90 EPrim p => Prim.p_t p 271 EPrim p => Prim.p_t p
91 | ERel n => p_rel env n 272 | ERel n => p_rel env n
92 | ENamed n => p_enamed env n 273 | ENamed n => p_enamed env n
93 | ECon (n, eo) => 274 | ECon (n, eo) =>
94 let 275 let
95 val (x, _, dn) = E.lookupConstructor env n 276 val (x, _, dn) = E.lookupConstructor env n
96 val (dx, _) = E.lookupDatatype env dn 277 val (dx, _) = E.lookupDatatype env dn
97 in 278 in
98 box [string "{(", 279 box [string "({",
99 newline, 280 newline,
100 string "struct", 281 string "struct",
101 space, 282 space,
102 string "__lwd_", 283 string "__lwd_",
103 string dx, 284 string dx,
121 string ("__lwc_" ^ x ^ "_" ^ Int.toString n), 302 string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
122 string ";", 303 string ";",
123 newline, 304 newline,
124 case eo of 305 case eo of
125 NONE => box [] 306 NONE => box []
126 | SOME e => box [string "tmp->data.", 307 | SOME e => box [string "tmp->data.__lwc_",
127 string x, 308 string x,
128 space, 309 space,
129 string "=", 310 string "=",
130 space, 311 space,
131 p_exp env e, 312 p_exp env e,
178 string "tmp;", 359 string "tmp;",
179 space, 360 space,
180 string "})" ] 361 string "})" ]
181 | EField (e, x) => 362 | EField (e, x) =>
182 box [p_exp' true env e, 363 box [p_exp' true env e,
183 string ".", 364 string ".__lwf_",
184 string x] 365 string x]
185 366
186 | ECase _ => raise Fail "CjrPrint ECase" 367 | ECase (e, pes, {disc, result}) =>
368 let
369 val final = newGoto ()
370
371 val body = foldl (fn ((p, e), body) =>
372 let
373 val exit = newGoto ()
374 val (pr, _) = p_pat_preamble env p
375 val (p, env) = p_pat (env,
376 box [string "goto",
377 space,
378 exit,
379 string ";"],
380 0) p
381 in
382 box [body,
383 box [string "{",
384 newline,
385 pr,
386 newline,
387 p,
388 newline,
389 string "result",
390 space,
391 string "=",
392 space,
393 p_exp env e,
394 string ";",
395 newline,
396 string "goto",
397 space,
398 final,
399 string ";",
400 newline,
401 string "}"],
402 newline,
403 exit,
404 string ":",
405 newline]
406 end) (box []) pes
407 in
408 box [string "({",
409 newline,
410 p_typ env disc,
411 space,
412 string "disc0",
413 space,
414 string "=",
415 space,
416 p_exp env e,
417 string ";",
418 newline,
419 p_typ env result,
420 space,
421 string "result;",
422 newline,
423 body,
424 string "lw_error(ctx, FATAL, \"",
425 string (ErrorMsg.spanToString loc),
426 string ": pattern match failure\");",
427 newline,
428 final,
429 string ":",
430 space,
431 string "result;",
432 newline,
433 string "})"]
434 end
187 435
188 | EWrite e => box [string "(lw_write(ctx, ", 436 | EWrite e => box [string "(lw_write(ctx, ",
189 p_exp env e, 437 p_exp env e,
190 string "), lw_unit_v)"] 438 string "), lw_unit_v)"]
191 439
234 space, 482 space,
235 string "{", 483 string "{",
236 newline, 484 newline,
237 p_list_sep (box []) (fn (x, t) => box [p_typ env t, 485 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
238 space, 486 space,
487 string "__lwf_",
239 string x, 488 string x,
240 string ";", 489 string ";",
241 newline]) xts, 490 newline]) xts,
242 string "};"] 491 string "};"]
243 | DDatatype (x, n, xncs) => 492 | DDatatype (x, n, xncs) =>
536 newline, 785 newline,
537 string "if (request[0] == '/') ++request;", 786 string "if (request[0] == '/') ++request;",
538 newline, 787 newline,
539 case to of 788 case to of
540 NONE => box [] 789 NONE => box []
541 | SOME t => box [string "tmp->data.", 790 | SOME t => box [string "tmp->data.__lwc_",
542 string x', 791 string x',
543 space, 792 space,
544 string "=", 793 string "=",
545 space, 794 space,
546 unurlify t, 795 unurlify t,