summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h2
-rw-r--r--src/c/urweb.c14
-rw-r--r--src/cjr.sml4
-rw-r--r--src/cjr_env.sml1
-rw-r--r--src/cjr_print.sml154
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/prepare.sig32
-rw-r--r--src/prepare.sml180
-rw-r--r--src/sources3
11 files changed, 391 insertions, 12 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 059cea0d..2c7576d9 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -64,3 +64,5 @@ lw_Basis_int lw_Basis_sqlifyInt(lw_context, lw_Basis_int);
lw_Basis_float lw_Basis_sqlifyFloat(lw_context, lw_Basis_float);
lw_Basis_string lw_Basis_sqlifyString(lw_context, lw_Basis_string);
lw_Basis_bool lw_Basis_sqlifyBool(lw_context, lw_Basis_bool);
+
+char *lw_Basis_ensqlBool(lw_Basis_bool);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index c37393f2..6f54e1a7 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -122,7 +122,7 @@ void lw_set_input(lw_context ctx, char *name, char *value) {
ctx->inputs[n] = value;
- printf("[%d] %s = %s\n", n, name, value);
+ //printf("[%d] %s = %s\n", n, name, value);
}
char *lw_get_input(lw_context ctx, int n) {
@@ -130,7 +130,7 @@ char *lw_get_input(lw_context ctx, int n) {
lw_error(ctx, FATAL, "Negative input index %d", n);
if (n >= lw_inputs_len)
lw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
- printf("[%d] = %s\n", n, ctx->inputs[n]);
+ //printf("[%d] = %s\n", n, ctx->inputs[n]);
return ctx->inputs[n];
}
@@ -656,3 +656,13 @@ char *lw_Basis_sqlifyBool(lw_context ctx, lw_Basis_bool b) {
else
return "TRUE";
}
+
+char *lw_Basis_ensqlBool(lw_Basis_bool b) {
+ static lw_Basis_int true = 1;
+ static lw_Basis_int false = 0;
+
+ if (b == lw_Basis_False)
+ return (char *)&false;
+ else
+ return (char *)&true;
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 4d6608ce..0f261de6 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -76,7 +76,8 @@ datatype exp' =
state : typ,
query : exp,
body : exp,
- initial : exp }
+ initial : exp,
+ prepared : int option }
withtype exp = exp' located
@@ -90,6 +91,7 @@ datatype decl' =
| DTable of string * (string * typ) list
| DDatabase of string
+ | DPreparedStatements of (string * int) list
withtype decl = decl' located
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 0859abe5..fc4833da 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -164,6 +164,7 @@ fun declBinds env (d, loc) =
end) env vis
| DTable _ => env
| DDatabase _ => env
+ | DPreparedStatements _ => env
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 50098a99..c813a260 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -333,6 +333,45 @@ fun p_unsql env (tAll as (t, loc)) e =
Print.eprefaces' [("Type", p_typ env tAll)];
string "ERROR")
+datatype sql_type =
+ Int
+ | Float
+ | String
+ | Bool
+
+fun p_sql_type t =
+ string (case t of
+ Int => "lw_Basis_int"
+ | Float => "lw_Basis_float"
+ | String => "lw_Basis_string"
+ | Bool => "lw_Basis_bool")
+
+fun getPargs (e, _) =
+ case e of
+ EPrim (Prim.String _) => []
+ | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
+
+ | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
+ | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
+ | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
+ | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
+
+ | _ => raise Fail "CjrPrint: getPargs"
+
+fun p_ensql t e =
+ case t of
+ Int => box [string "(char *)&", e]
+ | Float => box [string "(char *)&", e]
+ | String => e
+ | Bool => box [string "lw_Basis_ensqlBool(", e, string ")"]
+
+fun p_ensql_len t e =
+ case t of
+ Int => string "sizeof(lw_Basis_int)"
+ | Float => string "sizeof(lw_Basis_float)"
+ | String => box [string "strlen(", e, string ")"]
+ | Bool => string "sizeof(lw_Basis_bool)"
+
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
@@ -560,7 +599,7 @@ fun p_exp' par env (e, loc) =
newline,
string "})"]
- | EQuery {exps, tables, rnum, state, query, body, initial} =>
+ | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
let
val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps
val tables = ListUtil.mapConcat (fn (x, xts) =>
@@ -573,10 +612,54 @@ fun p_exp' par env (e, loc) =
newline,
string "PGconn *conn = lw_get_db(ctx);",
newline,
- string "char *query = ",
- p_exp env query,
- string ";",
- newline,
+ case prepared of
+ NONE => box [string "char *query = ",
+ p_exp env query,
+ string ";",
+ newline]
+ | SOME _ =>
+ let
+ val ets = getPargs query
+ in
+ box [p_list_sepi newline
+ (fn i => fn (e, t) =>
+ box [p_sql_type t,
+ space,
+ string "arg",
+ string (Int.toString (i + 1)),
+ space,
+ string "=",
+ space,
+ p_exp env e,
+ string ";"])
+ ets,
+ newline,
+ 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))]))
+ ets,
+ string " };",
+ newline,
+ newline,
+
+ string "const int paramLengths[] = { ",
+ p_list_sepi (box [string ",", space])
+ (fn i => fn (_, t) => p_ensql_len t (box [string "arg",
+ string (Int.toString (i + 1))]))
+ ets,
+ string " };",
+ newline,
+ newline,
+
+ string "const static int paramFormats[] = { ",
+ p_list_sep (box [string ",", space]) (fn _ => string "1") ets,
+ string " };",
+ newline,
+ newline]
+ end,
string "int n, i;",
newline,
p_typ env state,
@@ -588,7 +671,14 @@ fun p_exp' par env (e, loc) =
p_exp env initial,
string ";",
newline,
- string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);",
+ string "PGresult *res = ",
+ case prepared of
+ NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);"
+ | SOME n => box [string "PQexecPrepared(conn, \"lw",
+ string (Int.toString n),
+ string "\", ",
+ string (Int.toString (length (getPargs query))),
+ string ", paramValues, paramLengths, paramFormats, 1);"],
newline,
newline,
@@ -602,7 +692,11 @@ fun p_exp' par env (e, loc) =
newline,
string "lw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": Query failed:\\n%s\\n%s\", query, PQerrorMessage(conn));",
+ string ": Query failed:\\n%s\\n%s\", ",
+ case prepared of
+ NONE => string "query"
+ | SOME _ => p_exp env query,
+ string ", PQerrorMessage(conn));",
newline],
string "}",
newline,
@@ -814,6 +908,8 @@ fun p_decl env (dAll as (d, _) : decl) =
newline]
| DDatabase s => box [string "static void lw_db_validate(lw_context);",
newline,
+ string "static void lw_db_prepare(lw_context);",
+ newline,
newline,
string "void lw_db_init(lw_context ctx) {",
newline,
@@ -843,6 +939,8 @@ fun p_decl env (dAll as (d, _) : decl) =
newline,
string "lw_db_validate(ctx);",
newline,
+ string "lw_db_prepare(ctx);",
+ newline,
string "}",
newline,
newline,
@@ -853,6 +951,48 @@ fun p_decl env (dAll as (d, _) : decl) =
string "}",
newline]
+ | DPreparedStatements ss =>
+ box [string "static void lw_db_prepare(lw_context ctx) {",
+ newline,
+ string "PGconn *conn = lw_get_db(ctx);",
+ newline,
+ string "PGresult *res;",
+ newline,
+ newline,
+
+ p_list_sepi newline (fn i => fn (s, n) =>
+ box [string "res = PQprepare(conn, \"lw",
+ string (Int.toString i),
+ string "\", \"",
+ string (String.toString s),
+ string "\", ",
+ string (Int.toString n),
+ string ", NULL);",
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, PQerrorMessage(conn), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ string "PQclear(res);",
+ newline,
+ string "PQfinish(conn);",
+ newline,
+ string "lw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
+ string (String.toString s),
+ string "\\n%s\", msg);",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
+ newline])
+ ss,
+
+ string "}"]
+
datatype 'a search =
Found of 'a
| NotFound
diff --git a/src/cjrize.sml b/src/cjrize.sml
index ed8182c2..71bb2a0d 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -330,7 +330,7 @@ fun cifyExp (eAll as (e, loc), sm) =
val (initial, sm) = cifyExp (initial, sm)
in
((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
- query = query, body = body, initial = initial}, loc), sm)
+ query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
end
diff --git a/src/compiler.sig b/src/compiler.sig
index 30fef941..33af4a82 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -68,6 +68,7 @@ signature COMPILER = sig
val mono_reduce : (Mono.file, Mono.file) phase
val mono_shake : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
+ val prepare : (Cjr.file, Cjr.file) phase
val sqlify : (Mono.file, Cjr.file) phase
val toParseJob : (string, job) transform
@@ -87,6 +88,7 @@ signature COMPILER = sig
val toMono_shake : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
+ val toPrepare : (string, Cjr.file) transform
val toSqlify : (string, Cjr.file) transform
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 263aaf9a..773cf578 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -451,6 +451,13 @@ val cjrize = {
val toCjrize = transform cjrize "cjrize" o toMono_opt2
+val prepare = {
+ func = Prepare.prepare,
+ print = CjrPrint.p_file CjrEnv.empty
+}
+
+val toPrepare = transform prepare "prepare" o toCjrize
+
val sqlify = {
func = Cjrize.cjrize,
print = CjrPrint.p_sql CjrEnv.empty
@@ -472,7 +479,7 @@ fun compileC {cname, oname, ename} =
end
fun compile job =
- case run toCjrize job of
+ case run toPrepare job of
NONE => print "Ur compilation failed\n"
| SOME file =>
let
diff --git a/src/prepare.sig b/src/prepare.sig
new file mode 100644
index 00000000..0977100d
--- /dev/null
+++ b/src/prepare.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature PREPARE = sig
+
+ val prepare : Cjr.file -> Cjr.file
+
+end
diff --git a/src/prepare.sml b/src/prepare.sml
new file mode 100644
index 00000000..67f6e0b6
--- /dev/null
+++ b/src/prepare.sml
@@ -0,0 +1,180 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Prepare :> PREPARE = struct
+
+open Cjr
+
+fun prepString (e, ss, n) =
+ case #1 e of
+ EPrim (Prim.String s) =>
+ SOME (s :: ss, n)
+ | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+ (case prepString (e1, ss, n) of
+ NONE => NONE
+ | SOME (ss, n) => prepString (e2, ss, n))
+ | EFfiApp ("Basis", "sqlifyInt", [e]) =>
+ SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
+ | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
+ SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
+ | EFfiApp ("Basis", "sqlifyString", [e]) =>
+ SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
+ | EFfiApp ("Basis", "sqlifyBool", [e]) =>
+ SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
+
+ | _ => NONE
+
+fun prepExp (e as (_, loc), sns) =
+ case #1 e of
+ EPrim _ => (e, sns)
+ | ERel _ => (e, sns)
+ | ENamed _ => (e, sns)
+ | ECon (_, _, NONE) => (e, sns)
+ | ECon (dk, pc, SOME e) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((ECon (dk, pc, SOME e), loc), sns)
+ end
+ | EFfi _ => (e, sns)
+ | EFfiApp (m, x, es) =>
+ let
+ val (es, sns) = ListUtil.foldlMap prepExp sns es
+ in
+ ((EFfiApp (m, x, es), loc), sns)
+ end
+ | EApp (e1, e2) =>
+ let
+ val (e1, sns) = prepExp (e1, sns)
+ val (e2, sns) = prepExp (e2, sns)
+ in
+ ((EApp (e1, e2), loc), sns)
+ end
+
+ | ERecord (rn, xes) =>
+ let
+ val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((x, e), sns)
+ end) sns xes
+ in
+ ((ERecord (rn, xes), loc), sns)
+ end
+ | EField (e, s) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((EField (e, s), loc), sns)
+ end
+
+ | ECase (e, pes, ts) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((p, e), sns)
+ end) sns pes
+ in
+ ((ECase (e, pes, ts), loc), sns)
+ end
+
+ | EWrite e =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((EWrite e, loc), sns)
+ end
+ | ESeq (e1, e2) =>
+ let
+ val (e1, sns) = prepExp (e1, sns)
+ val (e2, sns) = prepExp (e2, sns)
+ in
+ ((ESeq (e1, e2), loc), sns)
+ end
+ | ELet (x, t, e1, e2) =>
+ let
+ val (e1, sns) = prepExp (e1, sns)
+ val (e2, sns) = prepExp (e2, sns)
+ in
+ ((ELet (x, t, e1, e2), loc), sns)
+ end
+
+ | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
+ (case prepString (query, [], 0) of
+ NONE => (e, sns)
+ | SOME (ss, n) =>
+ ((EQuery {exps = exps, tables = tables, rnum = rnum,
+ state = state, query = query, body = body,
+ initial = initial, prepared = SOME (#2 sns)}, loc),
+ ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
+
+fun prepDecl (d as (_, loc), sns) =
+ case #1 d of
+ DStruct _ => (d, sns)
+ | DDatatype _ => (d, sns)
+ | DDatatypeForward _ => (d, sns)
+ | DVal (x, n, t, e) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((DVal (x, n, t, e), loc), sns)
+ end
+ | DFun (x, n, xts, t, e) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((DFun (x, n, xts, t, e), loc), sns)
+ end
+ | DFunRec fs =>
+ let
+ val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((x, n, xts, t, e), sns)
+ end) sns fs
+ in
+ ((DFunRec fs, loc), sns)
+ end
+
+ | DTable _ => (d, sns)
+ | DDatabase _ => (d, sns)
+ | DPreparedStatements _ => (d, sns)
+
+fun prepare (ds, ps) =
+ let
+ val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
+ in
+ ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
+ end
+
+end
+
diff --git a/src/sources b/src/sources
index c57a30b1..6c1c7ac8 100644
--- a/src/sources
+++ b/src/sources
@@ -121,5 +121,8 @@ cjr_print.sml
cjrize.sig
cjrize.sml
+prepare.sig
+prepare.sml
+
compiler.sig
compiler.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-16 11:39:18 +0000