Mercurial > urweb

comparison src/cjr_print.sml @ 1431:4a6f84092399

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Represent 'unit' as C 'int'; change pattern match compilation to avoid 'goto'; change Postgres prepared statement compilation to make life easier for the GCC escape analysis; all this in support of better tail call optimization
author Adam Chlipala <adam@chlipala.net>
date Thu, 10 Mar 2011 18:51:15 -0500
parents 7d963b8019e6
children 6064ddd90ca6
comparison
equal deleted inserted replaced
1430:36c0a1be3f5a 1431:4a6f84092399
71 71
72 fun p_typ' par env (t, loc) = 72 fun p_typ' par env (t, loc) =
73 case t of 73 case t of
74 TFun (t1, t2) => (EM.errorAt loc "Function type remains"; 74 TFun (t1, t2) => (EM.errorAt loc "Function type remains";
75 string "<FUNCTION>") 75 string "<FUNCTION>")
76 | TRecord 0 => string "uw_unit"
76 | TRecord i => box [string "struct", 77 | TRecord i => box [string "struct",
77 space, 78 space,
78 string "__uws_", 79 string "__uws_",
79 string (Int.toString i)] 80 string (Int.toString i)]
80 | TDatatype (Enum, n, _) => 81 | TDatatype (Enum, n, _) =>
153 fun p_patCon env pc = 154 fun p_patCon env pc =
154 case pc of 155 case pc of
155 PConVar n => p_con_named env n 156 PConVar n => p_con_named env n
156 | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) 157 | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
157 158
158 fun p_pat (env, exit, depth) (p, loc) = 159 fun p_patMatch (env, disc) (p, loc) =
159 case p of 160 case p of
160 PWild => 161 PWild => string "1"
161 (box [], env) 162 | PVar _ => string "1"
162 | PVar (x, t) => 163 | PPrim (Prim.Int n) => box [string ("(" ^ disc),
163 (box [string "__uwr_", 164 space,
164 p_ident x, 165 string "==",
165 string "_", 166 space,
166 string (Int.toString (E.countERels env)), 167 Prim.p_t_GCC (Prim.Int n),
167 space, 168 string ")"]
168 string "=", 169 | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc),
169 space, 170 string ",",
170 string "disc", 171 space,
171 string (Int.toString depth), 172 Prim.p_t_GCC (Prim.String s),
172 string ";"], 173 string ")"]
173 E.pushERel env x t) 174 | PPrim (Prim.Char ch) => box [string ("(" ^ disc),
174 | PPrim (Prim.Int n) => 175 space,
175 (box [string "if", 176 string "==",
176 space, 177 space,
177 string "(disc", 178 Prim.p_t_GCC (Prim.Char ch),
178 string (Int.toString depth), 179 string ")"]
179 space,
180 string "!=",
181 space,
182 Prim.p_t_GCC (Prim.Int n),
183 string ")",
184 space,
185 exit],
186 env)
187 | PPrim (Prim.String s) =>
188 (box [string "if",
189 space,
190 string "(strcmp(disc",
191 string (Int.toString depth),
192 string ",",
193 space,
194 Prim.p_t_GCC (Prim.String s),
195 string "))",
196 space,
197 exit],
198 env)
199 | PPrim (Prim.Char ch) =>
200 (box [string "if",
201 space,
202 string "(disc",
203 string (Int.toString depth),
204 space,
205 string "!=",
206 space,
207 Prim.p_t_GCC (Prim.Char ch),
208 string ")",
209 space,
210 exit],
211 env)
212 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" 180 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
213 181
214 | PCon (dk, pc, po) => 182 | PCon (dk, pc, po) =>
215 let 183 let
216 val (p, env) = 184 val p =
217 case po of 185 case po of
218 NONE => (box [], env) 186 NONE => box []
219 | SOME p => 187 | SOME p =>
220 let 188 let
221 val (p, env) = p_pat (env, exit, depth + 1) p
222
223 val (x, to) = case pc of 189 val (x, to) = case pc of
224 PConVar n => 190 PConVar n =>
225 let 191 let
226 val (x, to, _) = E.lookupConstructor env n 192 val (x, to, _) = E.lookupConstructor env n
227 in 193 in
231 ("uw_" ^ ident m ^ "_" ^ ident con, arg) 197 ("uw_" ^ ident m ^ "_" ^ ident con, arg)
232 198
233 val t = case to of 199 val t = case to of
234 NONE => raise Fail "CjrPrint: Constructor mismatch" 200 NONE => raise Fail "CjrPrint: Constructor mismatch"
235 | SOME t => t 201 | SOME t => t
202
203 val x = case pc of
204 PConVar n =>
205 let
206 val (x, _, _) = E.lookupConstructor env n
207 in
208 "uw_" ^ ident x
209 end
210 | PConFfi {mod = m, con, ...} =>
211 "uw_" ^ ident m ^ "_" ^ ident con
212
213 val disc' = case dk of
214 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
215 | Default => disc ^ "->data." ^ x
216 | Option =>
217 if isUnboxable t then
218 disc
219 else
220 "(*" ^ disc ^ ")"
221
222 val p = p_patMatch (env, disc') p
236 in 223 in
237 (box [string "{", 224 box [space,
238 newline, 225 string "&&",
239 p_typ env t, 226 space,
240 space, 227 p]
241 string "disc",
242 string (Int.toString (depth + 1)),
243 space,
244 string "=",
245 space,
246 case dk of
247 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
248 | Default => box [string "disc",
249 string (Int.toString depth),
250 string "->data.",
251 string x]
252 | Option =>
253 if isUnboxable t then
254 box [string "disc",
255 string (Int.toString depth)]
256 else
257 box [string "*disc",
258 string (Int.toString depth)],
259 string ";",
260 newline,
261 p,
262 newline,
263 string "}"],
264 env)
265 end 228 end
266 in 229 in
267 (box [string "if", 230 box [string disc,
268 space, 231 case (dk, po) of
269 string "(disc", 232 (Enum, _) => box [space,
270 string (Int.toString depth), 233 string "==",
271 case (dk, po) of 234 space,
272 (Enum, _) => box [space, 235 p_patCon env pc]
273 string "!=", 236 | (Default, _) => box [string "->tag",
274 space, 237 space,
275 p_patCon env pc] 238 string "==",
276 | (Default, _) => box [string "->tag", 239 space,
277 space, 240 p_patCon env pc]
278 string "!=", 241 | (Option, NONE) => box [space,
279 space, 242 string "==",
280 p_patCon env pc] 243 space,
281 | (Option, NONE) => box [space, 244 string "NULL"]
282 string "!=", 245 | (Option, SOME _) => box [space,
283 space, 246 string "!=",
284 string "NULL"] 247 space,
285 | (Option, SOME _) => box [space, 248 string "NULL"],
286 string "==", 249 p]
287 space, 250 end
288 string "NULL"], 251
289 string ")", 252 | PRecord xps =>
290 space, 253 p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps
291 exit, 254
292 newline, 255 | PNone _ =>
293 p], 256 box [string disc,
294 env) 257 space,
258 string "==",
259 space,
260 string "NULL"]
261
262 | PSome (t, p) =>
263 let
264 val disc' = if isUnboxable t then
265 disc
266 else
267 "(*" ^ disc ^ ")"
268
269 val p = p_patMatch (env, disc') p
270 in
271 box [string disc,
272 space,
273 string "!=",
274 space,
275 string "NULL",
276 space,
277 string "&&",
278 space,
279 p]
280 end
281
282 fun p_patBind (env, disc) (p, loc) =
283 case p of
284 PWild =>
285 (box [], env)
286 | PVar (x, t) =>
287 (box [p_typ env t,
288 space,
289 string "__uwr_",
290 p_ident x,
291 string "_",
292 string (Int.toString (E.countERels env)),
293 space,
294 string "=",
295 space,
296 string disc,
297 string ";",
298 newline],
299 E.pushERel env x t)
300 | PPrim _ => (box [], env)
301
302 | PCon (_, _, NONE) => (box [], env)
303
304 | PCon (dk, pc, SOME p) =>
305 let
306 val (x, to) = case pc of
307 PConVar n =>
308 let
309 val (x, to, _) = E.lookupConstructor env n
310 in
311 ("uw_" ^ ident x, to)
312 end
313 | PConFfi {mod = m, con, arg, ...} =>
314 ("uw_" ^ ident m ^ "_" ^ ident con, arg)
315
316 val t = case to of
317 NONE => raise Fail "CjrPrint: Constructor mismatch"
318 | SOME t => t
319
320 val disc' = case dk of
321 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
322 | Default => disc ^ "->data." ^ x
323 | Option =>
324 if isUnboxable t then
325 disc
326 else
327 "(*" ^ disc ^ ")"
328 in
329 p_patBind (env, disc') p
295 end 330 end
296 331
297 | PRecord xps => 332 | PRecord xps =>
298 let 333 let
299 val (xps, env) = 334 val (xps, env) =
300 ListUtil.foldlMap (fn ((x, p, t), env) => 335 ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p)
301 let 336 env xps
302 val (p, env) = p_pat (env, exit, depth + 1) p
303
304 val p = box [string "{",
305 newline,
306 p_typ env t,
307 space,
308 string "disc",
309 string (Int.toString (depth + 1)),
310 space,
311 string "=",
312 space,
313 string "disc",
314 string (Int.toString depth),
315 string ".__uwf_",
316 p_ident x,
317 string ";",
318 newline,
319 p,
320 newline,
321 string "}"]
322 in
323 (p, env)
324 end) env xps
325 in 337 in
326 (p_list_sep newline (fn x => x) xps, 338 (p_list_sep (box []) (fn x => x) xps,
327 env) 339 env)
328 end 340 end
329 341
330 | PNone t => 342 | PNone _ => (box [], env)
331 (box [string "if",
332 space,
333 string "(disc",
334 string (Int.toString depth),
335 space,
336 string "!=",
337 space,
338 string "NULL)",
339 space,
340 exit,
341 newline],
342 env)
343 343
344 | PSome (t, p) => 344 | PSome (t, p) =>
345 let 345 let
346 val (p, env) = 346 val disc' = if isUnboxable t then
347 let 347 disc
348 val (p, env) = p_pat (env, exit, depth + 1) p 348 else
349 in 349 "(*" ^ disc ^ ")"
350 (box [string "{",
351 newline,
352 p_typ env t,
353 space,
354 string "disc",
355 string (Int.toString (depth + 1)),
356 space,
357 string "=",
358 space,
359 if isUnboxable t then
360 box [string "disc",
361 string (Int.toString depth)]
362 else
363 box [string "*disc",
364 string (Int.toString depth)],
365 string ";",
366 newline,
367 p,
368 newline,
369 string "}"],
370 env)
371 end
372 in 350 in
373 (box [string "if", 351 p_patBind (env, disc') p
374 space,
375 string "(disc",
376 string (Int.toString depth),
377 space,
378 string "==",
379 space,
380 string "NULL)",
381 space,
382 exit,
383 newline,
384 p],
385 env)
386 end 352 end
387
388 local
389 val count = ref 0
390 in
391 fun newGoto () =
392 let
393 val r = !count
394 in
395 count := r + 1;
396 string ("L" ^ Int.toString r)
397 end
398 end
399 353
400 fun patConInfo env pc = 354 fun patConInfo env pc =
401 case pc of 355 case pc of
402 PConVar n => 356 PConVar n =>
403 let 357 let
1565 space, 1519 space,
1566 string s, 1520 string s,
1567 space, 1521 space,
1568 p_exp' true env e2]) 1522 p_exp' true env e2])
1569 1523
1524 | ERecord (0, _) => string "0"
1525
1570 | ERecord (i, xes) => box [string "({", 1526 | ERecord (i, xes) => box [string "({",
1571 space, 1527 space,
1572 string "struct", 1528 string "struct",
1573 space, 1529 space,
1574 string ("__uws_" ^ Int.toString i), 1530 string ("__uws_" ^ Int.toString i),
1589 box [p_exp' true env e, 1545 box [p_exp' true env e,
1590 string ".__uwf_", 1546 string ".__uwf_",
1591 p_ident x] 1547 p_ident x]
1592 1548
1593 | ECase (e, pes, {disc, result}) => 1549 | ECase (e, pes, {disc, result}) =>
1594 let 1550 box [string "({",
1595 val final = newGoto () 1551 newline,
1596 1552 p_typ env disc,
1597 val body = foldl (fn ((p, e), body) => 1553 space,
1598 let 1554 string "disc",
1599 val exit = newGoto () 1555 space,
1600 val (pr, _) = p_pat_preamble env p 1556 string "=",
1601 val (p, env) = p_pat (env, 1557 space,
1602 box [string "goto", 1558 p_exp env e,
1603 space, 1559 string ";",
1604 exit, 1560 newline,
1605 string ";"], 1561 newline,
1606 0) p 1562 foldr (fn ((p, e), body) =>
1607 in 1563 let
1608 box [body, 1564 val pm = p_patMatch (env, "disc") p
1609 box [string "{", 1565 val (pb, env) = p_patBind (env, "disc") p
1610 newline, 1566 in
1611 pr, 1567 box [pm,
1612 newline, 1568 space,
1613 p, 1569 string "?",
1614 newline, 1570 space,
1615 string "result", 1571 box [string "({",
1616 space, 1572 pb,
1617 string "=", 1573 p_exp env e,
1618 space, 1574 string ";",
1619 p_exp env e, 1575 newline,
1620 string ";", 1576 string "})"],
1621 newline, 1577 newline,
1622 string "goto", 1578 space,
1623 space, 1579 string ":",
1624 final, 1580 space,
1625 string ";", 1581 body]
1626 newline, 1582 end) (box [string "({",
1627 string "}"], 1583 newline,
1628 newline, 1584 p_typ env result,
1629 exit, 1585 space,
1630 string ":", 1586 string "tmp;",
1631 newline] 1587 newline,
1632 end) (box []) pes 1588 string "uw_error(ctx, FATAL, \"",
1633 in 1589 string (ErrorMsg.spanToString loc),
1634 box [string "({", 1590 string ": pattern match failure\");",
1635 newline, 1591 newline,
1636 p_typ env disc, 1592 string "tmp;",
1637 space, 1593 newline,
1638 string "disc0", 1594 string "})"]) pes,
1639 space, 1595 string ";",
1640 string "=", 1596 newline,
1641 space, 1597 string "})"]
1642 p_exp env e,
1643 string ";",
1644 newline,
1645 p_typ env result,
1646 space,
1647 string "result;",
1648 newline,
1649 body,
1650 string "uw_error(ctx, FATAL, \"",
1651 string (ErrorMsg.spanToString loc),
1652 string ": pattern match failure\");",
1653 newline,
1654 final,
1655 string ":",
1656 space,
1657 string "result;",
1658 newline,
1659 string "})"]
1660 end
1661 1598
1662 | EWrite e => box [string "(uw_write(ctx, ", 1599 | EWrite e => box [string "(uw_write(ctx, ",
1663 p_exp env e, 1600 p_exp env e,
1664 string "), uw_unit_v)"] 1601 string "), 0)"]
1665 1602
1666 | ESeq (e1, e2) => 1603 | ESeq (e1, e2) =>
1667 let 1604 let
1668 val useRegion = potentiallyFancy e1 1605 val useRegion = potentiallyFancy e1
1669 in 1606 in
1902 newline, 1839 newline,
1903 string "uw_end_region(ctx);", 1840 string "uw_end_region(ctx);",
1904 newline, 1841 newline,
1905 1842
1906 case mode of 1843 case mode of
1907 Settings.Error => string "uw_unit_v;" 1844 Settings.Error => string "0;"
1908 | Settings.None => string "uw_dup_and_clear_error_message(ctx);", 1845 | Settings.None => string "uw_dup_and_clear_error_message(ctx);",
1909 1846
1910 newline, 1847 newline,
1911 string "}))"] 1848 string "}))"]
1912 1849
1940 seqE = p_exp env seq, 1877 seqE = p_exp env seq,
1941 count = p_exp env count}, 1878 count = p_exp env count},
1942 newline, 1879 newline,
1943 newline, 1880 newline,
1944 1881
1945 string "uw_unit_v;", 1882 string "0;",
1946 newline, 1883 newline,
1947 string "})"] 1884 string "})"]
1948 1885
1949 | EUnurlify (e, t, true) => 1886 | EUnurlify (e, t, true) =>
1950 let 1887 let
2622 p_ident x, 2559 p_ident x,
2623 string ";", 2560 string ";",
2624 newline]) xts), 2561 newline]) xts),
2625 newline, 2562 newline,
2626 box (map getInput xts), 2563 box (map getInput xts),
2627 string "struct __uws_", 2564 case i of
2628 string (Int.toString i), 2565 0 => string "uw_unit uw_inputs;"
2629 space, 2566 | _ => box [string "struct __uws_",
2630 string "uw_inputs", 2567 string (Int.toString i),
2631 space, 2568 space,
2632 string "= {", 2569 string "uw_inputs",
2633 newline, 2570 space,
2634 box (map (fn (x, _) => box [string "uw_input_", 2571 string "= {",
2635 p_ident x, 2572 newline,
2636 string ",", 2573 box (map (fn (x, _) => box [string "uw_input_",
2637 newline]) xts), 2574 p_ident x,
2638 string "};", 2575 string ",",
2576 newline]) xts),
2577 string "};"],
2639 newline], 2578 newline],
2640 box [string ",", 2579 box [string ",",
2641 space, 2580 space,
2642 string "uw_inputs"], 2581 string "uw_inputs"],
2643 SOME xts) 2582 SOME xts)
2778 p_list_sep (box [string ",", space]) 2717 p_list_sep (box [string ",", space])
2779 (fn x => x) 2718 (fn x => x)
2780 (string "ctx" 2719 (string "ctx"
2781 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), 2720 :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
2782 inputsVar, 2721 inputsVar,
2783 string ", uw_unit_v);", 2722 string ", 0);",
2784 newline, 2723 newline,
2785 box (case ek of 2724 box (case ek of
2786 Core.Rpc _ => [urlify env ran] 2725 Core.Rpc _ => [urlify env ran]
2787 | _ => [string "uw_write(ctx, \"</html>\");", 2726 | _ => [string "uw_write(ctx, \"</html>\");",
2788 newline]), 2727 newline]),
3010 string (Int.toString i), 2949 string (Int.toString i),
3011 string "(uw_context ctx) {", 2950 string "(uw_context ctx) {",
3012 newline, 2951 newline,
3013 box [string "uw_unit __uwr_", 2952 box [string "uw_unit __uwr_",
3014 string x1, 2953 string x1,
3015 string "_0 = uw_unit_v, __uwr_", 2954 string "_0 = 0, __uwr_",
3016 string x2, 2955 string x2,
3017 string "_1 = uw_unit_v;", 2956 string "_1 = 0;",
3018 newline, 2957 newline,
3019 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, 2958 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
3020 string ";", 2959 string ";",
3021 newline], 2960 newline],
3022 string "}", 2961 string "}",
3112 string x1, 3051 string x1,
3113 string "_0 = cli;", 3052 string "_0 = cli;",
3114 newline, 3053 newline,
3115 string "uw_unit __uwr_", 3054 string "uw_unit __uwr_",
3116 string x2, 3055 string x2,
3117 string "_1 = uw_unit_v;", 3056 string "_1 = 0;",
3118 newline, 3057 newline,
3119 p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) 3058 p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
3120 x2 dummyt) e, 3059 x2 dummyt) e,
3121 string ";", 3060 string ";",
3122 newline, 3061 newline,
3136 newline, 3075 newline,
3137 box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({", 3076 box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
3138 newline, 3077 newline,
3139 string "uw_unit __uwr_", 3078 string "uw_unit __uwr_",
3140 string x1, 3079 string x1,
3141 string "_0 = uw_unit_v, __uwr_", 3080 string "_0 = 0, __uwr_",
3142 string x2, 3081 string x2,
3143 string "_1 = uw_unit_v;", 3082 string "_1 = 0;",
3144 newline, 3083 newline,
3145 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, 3084 p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
3146 string ";", 3085 string ";",
3147 newline, 3086 newline,
3148 string "});", 3087 string "});",
3149 newline]) initializers, 3088 newline]) initializers,
3150 if hasDb then 3089 if hasDb then
3151 box [p_enamed env (!initialize), 3090 box [p_enamed env (!initialize),
3152 string "(ctx, uw_unit_v);", 3091 string "(ctx, 0);",
3153 newline] 3092 newline]
3154 else 3093 else
3155 box []], 3094 box []],
3156 string "}", 3095 string "}",
3157 newline, 3096 newline,
3160 NONE => box [] 3099 NONE => box []
3161 | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", 3100 | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {",
3162 newline, 3101 newline,
3163 box [string "uw_write(ctx, ", 3102 box [string "uw_write(ctx, ",
3164 p_enamed env n, 3103 p_enamed env n,
3165 string "(ctx, msg, uw_unit_v));", 3104 string "(ctx, msg, 0));",
3166 newline], 3105 newline],
3167 string "}", 3106 string "}",
3168 newline, 3107 newline,
3169 newline], 3108 newline],
3170 3109