Mercurial > urweb
changeset 1431:4a6f84092399
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 | 36c0a1be3f5a |
| children | 7d024767b024 |
| files | include/types.h src/c/urweb.c src/cjr_print.sml src/postgres.sml |
| diffstat | 4 files changed, 280 insertions(+), 334 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Wed Mar 02 18:35:03 2011 -0500 +++ b/include/types.h Thu Mar 10 18:51:15 2011 -0500 @@ -18,10 +18,7 @@ char *data; } uw_Basis_blob; -struct __uws_0 { -}; - -typedef struct __uws_0 uw_unit; +typedef int uw_unit; typedef uw_unit uw_Basis_unit; typedef enum uw_Basis_bool { uw_Basis_False, uw_Basis_True } uw_Basis_bool;
--- a/src/c/urweb.c Wed Mar 02 18:35:03 2011 -0500 +++ b/src/c/urweb.c Thu Mar 10 18:51:15 2011 -0500 @@ -20,7 +20,7 @@ #include "types.h" -uw_unit uw_unit_v = {}; +uw_unit uw_unit_v = 0; // Socket extras
--- a/src/cjr_print.sml Wed Mar 02 18:35:03 2011 -0500 +++ b/src/cjr_print.sml Thu Mar 10 18:51:15 2011 -0500 @@ -73,6 +73,7 @@ case t of TFun (t1, t2) => (EM.errorAt loc "Function type remains"; string "<FUNCTION>") + | TRecord 0 => string "uw_unit" | TRecord i => box [string "struct", space, string "__uws_", @@ -155,71 +156,36 @@ PConVar n => p_con_named env n | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) -fun p_pat (env, exit, depth) (p, loc) = +fun p_patMatch (env, disc) (p, loc) = case p of - PWild => - (box [], env) - | PVar (x, t) => - (box [string "__uwr_", - p_ident x, - string "_", - string (Int.toString (E.countERels env)), - space, - string "=", - space, - string "disc", - string (Int.toString depth), - string ";"], - E.pushERel env x t) - | PPrim (Prim.Int n) => - (box [string "if", - space, - string "(disc", - string (Int.toString depth), - space, - string "!=", - space, - Prim.p_t_GCC (Prim.Int n), - string ")", - space, - exit], - env) - | PPrim (Prim.String s) => - (box [string "if", - space, - string "(strcmp(disc", - string (Int.toString depth), - string ",", - space, - Prim.p_t_GCC (Prim.String s), - string "))", - space, - exit], - env) - | PPrim (Prim.Char ch) => - (box [string "if", - space, - string "(disc", - string (Int.toString depth), - space, - string "!=", - space, - Prim.p_t_GCC (Prim.Char ch), - string ")", - space, - exit], - env) + PWild => string "1" + | PVar _ => string "1" + | PPrim (Prim.Int n) => box [string ("(" ^ disc), + space, + string "==", + space, + Prim.p_t_GCC (Prim.Int n), + string ")"] + | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc), + string ",", + space, + Prim.p_t_GCC (Prim.String s), + string ")"] + | PPrim (Prim.Char ch) => box [string ("(" ^ disc), + space, + string "==", + space, + Prim.p_t_GCC (Prim.Char ch), + string ")"] | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" | PCon (dk, pc, po) => let - val (p, env) = + val p = case po of - NONE => (box [], env) + NONE => box [] | SOME p => let - val (p, env) = p_pat (env, exit, depth + 1) p - val (x, to) = case pc of PConVar n => let @@ -233,170 +199,158 @@ val t = case to of NONE => raise Fail "CjrPrint: Constructor mismatch" | SOME t => t + + val x = case pc of + PConVar n => + let + val (x, _, _) = E.lookupConstructor env n + in + "uw_" ^ ident x + end + | PConFfi {mod = m, con, ...} => + "uw_" ^ ident m ^ "_" ^ ident con + + val disc' = case dk of + Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" + | Default => disc ^ "->data." ^ x + | Option => + if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + + val p = p_patMatch (env, disc') p in - (box [string "{", - newline, - p_typ env t, - space, - string "disc", - string (Int.toString (depth + 1)), - space, - string "=", - space, - case dk of - Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" - | Default => box [string "disc", - string (Int.toString depth), - string "->data.", - string x] - | Option => - if isUnboxable t then - box [string "disc", - string (Int.toString depth)] - else - box [string "*disc", - string (Int.toString depth)], - string ";", - newline, - p, - newline, - string "}"], - env) + box [space, + string "&&", + space, + p] end in - (box [string "if", - space, - string "(disc", - string (Int.toString depth), - case (dk, po) of - (Enum, _) => box [space, - string "!=", - space, - p_patCon env pc] - | (Default, _) => box [string "->tag", - space, - string "!=", - space, - p_patCon env pc] - | (Option, NONE) => box [space, - string "!=", - space, - string "NULL"] - | (Option, SOME _) => box [space, - string "==", - space, - string "NULL"], - string ")", - space, - exit, - newline, - p], - env) + box [string disc, + case (dk, po) of + (Enum, _) => box [space, + string "==", + space, + p_patCon env pc] + | (Default, _) => box [string "->tag", + space, + string "==", + space, + p_patCon env pc] + | (Option, NONE) => box [space, + string "==", + space, + string "NULL"] + | (Option, SOME _) => box [space, + string "!=", + space, + string "NULL"], + p] + end + + | PRecord xps => + p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps + + | PNone _ => + box [string disc, + space, + string "==", + space, + string "NULL"] + + | PSome (t, p) => + let + val disc' = if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + + val p = p_patMatch (env, disc') p + in + box [string disc, + space, + string "!=", + space, + string "NULL", + space, + string "&&", + space, + p] + end + +fun p_patBind (env, disc) (p, loc) = + case p of + PWild => + (box [], env) + | PVar (x, t) => + (box [p_typ env t, + space, + string "__uwr_", + p_ident x, + string "_", + string (Int.toString (E.countERels env)), + space, + string "=", + space, + string disc, + string ";", + newline], + E.pushERel env x t) + | PPrim _ => (box [], env) + + | PCon (_, _, NONE) => (box [], env) + + | PCon (dk, pc, SOME p) => + let + val (x, to) = case pc of + PConVar n => + let + val (x, to, _) = E.lookupConstructor env n + in + ("uw_" ^ ident x, to) + end + | PConFfi {mod = m, con, arg, ...} => + ("uw_" ^ ident m ^ "_" ^ ident con, arg) + + val t = case to of + NONE => raise Fail "CjrPrint: Constructor mismatch" + | SOME t => t + + val disc' = case dk of + Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" + | Default => disc ^ "->data." ^ x + | Option => + if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + in + p_patBind (env, disc') p end | PRecord xps => let val (xps, env) = - ListUtil.foldlMap (fn ((x, p, t), env) => - let - val (p, env) = p_pat (env, exit, depth + 1) p - - val p = box [string "{", - newline, - p_typ env t, - space, - string "disc", - string (Int.toString (depth + 1)), - space, - string "=", - space, - string "disc", - string (Int.toString depth), - string ".__uwf_", - p_ident x, - string ";", - newline, - p, - newline, - string "}"] - in - (p, env) - end) env xps + ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p) + env xps in - (p_list_sep newline (fn x => x) xps, + (p_list_sep (box []) (fn x => x) xps, env) end - | PNone t => - (box [string "if", - space, - string "(disc", - string (Int.toString depth), - space, - string "!=", - space, - string "NULL)", - space, - exit, - newline], - env) + | PNone _ => (box [], env) | PSome (t, p) => let - val (p, env) = - let - val (p, env) = p_pat (env, exit, depth + 1) p - in - (box [string "{", - newline, - p_typ env t, - space, - string "disc", - string (Int.toString (depth + 1)), - space, - string "=", - space, - if isUnboxable t then - box [string "disc", - string (Int.toString depth)] - else - box [string "*disc", - string (Int.toString depth)], - string ";", - newline, - p, - newline, - string "}"], - env) - end + val disc' = if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" in - (box [string "if", - space, - string "(disc", - string (Int.toString depth), - space, - string "==", - space, - string "NULL)", - space, - exit, - newline, - p], - env) + p_patBind (env, disc') p end -local - val count = ref 0 -in -fun newGoto () = - let - val r = !count - in - count := r + 1; - string ("L" ^ Int.toString r) - end -end - fun patConInfo env pc = case pc of PConVar n => @@ -1567,6 +1521,8 @@ space, p_exp' true env e2]) + | ERecord (0, _) => string "0" + | ERecord (i, xes) => box [string "({", space, string "struct", @@ -1591,77 +1547,58 @@ p_ident x] | ECase (e, pes, {disc, result}) => - let - val final = newGoto () - - val body = foldl (fn ((p, e), body) => - let - val exit = newGoto () - val (pr, _) = p_pat_preamble env p - val (p, env) = p_pat (env, - box [string "goto", - space, - exit, - string ";"], - 0) p - in - box [body, - box [string "{", - newline, - pr, - newline, - p, - newline, - string "result", - space, - string "=", - space, - p_exp env e, - string ";", - newline, - string "goto", - space, - final, - string ";", - newline, - string "}"], - newline, - exit, - string ":", - newline] - end) (box []) pes - in - box [string "({", - newline, - p_typ env disc, - space, - string "disc0", - space, - string "=", - space, - p_exp env e, - string ";", - newline, - p_typ env result, - space, - string "result;", - newline, - body, - string "uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": pattern match failure\");", - newline, - final, - string ":", - space, - string "result;", - newline, - string "})"] - end + box [string "({", + newline, + p_typ env disc, + space, + string "disc", + space, + string "=", + space, + p_exp env e, + string ";", + newline, + newline, + foldr (fn ((p, e), body) => + let + val pm = p_patMatch (env, "disc") p + val (pb, env) = p_patBind (env, "disc") p + in + box [pm, + space, + string "?", + space, + box [string "({", + pb, + p_exp env e, + string ";", + newline, + string "})"], + newline, + space, + string ":", + space, + body] + end) (box [string "({", + newline, + p_typ env result, + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": pattern match failure\");", + newline, + string "tmp;", + newline, + string "})"]) pes, + string ";", + newline, + string "})"] | EWrite e => box [string "(uw_write(ctx, ", p_exp env e, - string "), uw_unit_v)"] + string "), 0)"] | ESeq (e1, e2) => let @@ -1904,7 +1841,7 @@ newline, case mode of - Settings.Error => string "uw_unit_v;" + Settings.Error => string "0;" | Settings.None => string "uw_dup_and_clear_error_message(ctx);", newline, @@ -1942,7 +1879,7 @@ newline, newline, - string "uw_unit_v;", + string "0;", newline, string "})"] @@ -2624,18 +2561,20 @@ newline]) xts), newline, box (map getInput xts), - string "struct __uws_", - string (Int.toString i), - space, - string "uw_inputs", - space, - string "= {", - newline, - box (map (fn (x, _) => box [string "uw_input_", - p_ident x, - string ",", - newline]) xts), - string "};", + case i of + 0 => string "uw_unit uw_inputs;" + | _ => box [string "struct __uws_", + string (Int.toString i), + space, + string "uw_inputs", + space, + string "= {", + newline, + box (map (fn (x, _) => box [string "uw_input_", + p_ident x, + string ",", + newline]) xts), + string "};"], newline], box [string ",", space, @@ -2780,7 +2719,7 @@ (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), inputsVar, - string ", uw_unit_v);", + string ", 0);", newline, box (case ek of Core.Rpc _ => [urlify env ran] @@ -3012,9 +2951,9 @@ newline, box [string "uw_unit __uwr_", string x1, - string "_0 = uw_unit_v, __uwr_", + string "_0 = 0, __uwr_", string x2, - string "_1 = uw_unit_v;", + string "_1 = 0;", newline, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, string ";", @@ -3114,7 +3053,7 @@ newline, string "uw_unit __uwr_", string x2, - string "_1 = uw_unit_v;", + string "_1 = 0;", newline, p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) x2 dummyt) e, @@ -3138,9 +3077,9 @@ newline, string "uw_unit __uwr_", string x1, - string "_0 = uw_unit_v, __uwr_", + string "_0 = 0, __uwr_", string x2, - string "_1 = uw_unit_v;", + string "_1 = 0;", newline, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, string ";", @@ -3149,7 +3088,7 @@ newline]) initializers, if hasDb then box [p_enamed env (!initialize), - string "(ctx, uw_unit_v);", + string "(ctx, 0);", newline] else box []], @@ -3162,7 +3101,7 @@ newline, box [string "uw_write(ctx, ", p_enamed env n, - string "(ctx, msg, uw_unit_v));", + string "(ctx, msg, 0));", newline], string "}", newline,
--- a/src/postgres.sml Wed Mar 02 18:35:03 2011 -0500 +++ b/src/postgres.sml Thu Mar 10 18:51:15 2011 -0500 @@ -669,29 +669,56 @@ p_ensql t (box [string "(*", e, string ")"]), string ")"] -fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = - box [string "PGconn *conn = uw_get_db(ctx);", - newline, - string "const int paramFormats[] = { ", +fun makeParams inputs = + box [string "static const int paramFormats[] = { ", p_list_sep (box [string ",", space]) (fn t => if isBlob t then string "1" else string "0") inputs, string " };", newline, - string "const int paramLengths[] = { ", - p_list_sepi (box [string ",", space]) - (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size") - | Nullable Blob => string ("arg" ^ Int.toString (i + 1) - ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") - | _ => string "0") inputs, - string " };", + if List.exists isBlob inputs then + box [string "const int *paramLengths = uw_malloc(ctx, ", + string (Int.toString (length inputs)), + string " * sizeof(int));", + newline, + p_list_sepi (box []) + (fn i => fn t => + box [string "paramLengths[", + string (Int.toString i), + string "] = ", + case t of + Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size") + | Nullable Blob => string ("arg" ^ Int.toString (i + 1) + ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") + | _ => string "0", + string ";", + newline]) inputs, + string " };", + newline] + else + box [string "const int *paramLengths = paramFormats;", + newline], + + string "const char **paramValues = uw_malloc(ctx, ", + string (Int.toString (length inputs)), + string " * sizeof(char*));", newline, - string "const char *paramValues[] = { ", - p_list_sepi (box [string ",", space]) - (fn i => fn t => p_ensql t (box [string "arg", - string (Int.toString (i + 1))])) + p_list_sepi (box []) + (fn i => fn t => box [string "paramValues[", + string (Int.toString i), + string "] = ", + p_ensql t (box [string "arg", + string (Int.toString (i + 1))]), + string ";", + newline]) inputs, - string " };", + newline] + +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = + box [string "PGconn *conn = uw_get_db(ctx);", newline, + + makeParams inputs, + newline, string "PGresult *res = ", if #persistent (Settings.currentProtocol ()) then @@ -831,26 +858,9 @@ fun dmlPrepared {loc, id, dml, inputs, mode} = box [string "PGconn *conn = uw_get_db(ctx);", newline, - string "const int paramFormats[] = { ", - p_list_sep (box [string ",", space]) - (fn t => if isBlob t then string "1" else string "0") inputs, - string " };", - newline, - string "const int paramLengths[] = { ", - p_list_sepi (box [string ",", space]) - (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size") - | Nullable Blob => string ("arg" ^ Int.toString (i + 1) - ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") - | _ => string "0") inputs, - string " };", - newline, - string "const char *paramValues[] = { ", - p_list_sepi (box [string ",", space]) - (fn i => fn t => p_ensql t (box [string "arg", - string (Int.toString (i + 1))])) - inputs, - string " };", - newline, + + makeParams inputs, + newline, string "PGresult *res;", newline,