aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/checknest.sml4
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml36
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/jscomp.sml9
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml6
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml4
-rw-r--r--src/monoize.sml5
-rw-r--r--src/prepare.sml4
-rw-r--r--src/scriptcheck.sml2
-rw-r--r--src/shake.sig3
-rw-r--r--src/shake.sml24
14 files changed, 78 insertions, 29 deletions
diff --git a/src/checknest.sml b/src/checknest.sml
index c0f843d6..a53c7083 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -89,7 +89,7 @@ fun expUses globals =
end
| ESetval {seq, count} => IS.union (eu seq, eu count)
- | EUnurlify (e, _) => eu e
+ | EUnurlify (e, _, _) => eu e
in
eu
end
@@ -149,7 +149,7 @@ fun annotateExp globals =
(ESetval {seq = ae seq,
count = ae count}, loc)
- | EUnurlify (e, t) => (EUnurlify (ae e, t), loc)
+ | EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc)
in
ae
end
diff --git a/src/cjr.sml b/src/cjr.sml
index 53448a29..a19109d2 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -96,7 +96,7 @@ datatype exp' =
| ENextval of { seq : exp,
prepared : {id : int, query : string} option }
| ESetval of { seq : exp, count : exp }
- | EUnurlify of exp * typ
+ | EUnurlify of exp * typ * bool
withtype exp = exp' located
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8c5a24b4..faf5f7b2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1863,7 +1863,7 @@ fun p_exp' par env (e, loc) =
newline,
string "})"]
- | EUnurlify (e, t) =>
+ | EUnurlify (e, t, true) =>
let
fun getIt () =
if isUnboxable t then
@@ -1898,6 +1898,40 @@ fun p_exp' par env (e, loc) =
string "})"]
end
+ | EUnurlify (e, t, false) =>
+ let
+ fun getIt () =
+ if isUnboxable t then
+ unurlify false env t
+ else
+ box [string "({",
+ newline,
+ p_typ env t,
+ string " *tmp = uw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp = ",
+ unurlify false env t,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
+ in
+ box [string "({",
+ newline,
+ string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
+ p_exp env e,
+ string ");",
+ newline,
+ newline,
+ unurlify false env t,
+ string ";",
+ newline,
+ string "})"]
+ end
+
and p_exp env = p_exp' false env
fun p_fun env (fx, n, args, ran, e) =
diff --git a/src/cjrize.sml b/src/cjrize.sml
index e2807372..6e41a69b 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -476,12 +476,12 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.ESetval {seq = e1, count = e2}, loc), sm)
end
- | L.EUnurlify (e, t) =>
+ | L.EUnurlify (e, t, b) =>
let
val (e, sm) = cifyExp (e, sm)
val (t, sm) = cifyTyp (t, sm)
in
- ((L'.EUnurlify (e, t), loc), sm)
+ ((L'.EUnurlify (e, t, b), loc), sm)
end
| L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 11d75a3a..b99a6858 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -869,10 +869,11 @@ fun process file =
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
| ESetval _ => unsupported "Nextval"
- | EReturnBlob _ => unsupported "EUnurlify"
+ | EReturnBlob _ => unsupported "EReturnBlob"
| ERedirect _ => unsupported "ERedirect"
+ | EUnurlify (_, _, true) => unsupported "EUnurlify"
- | EUnurlify (e, t) =>
+ | EUnurlify (e, t, false) =>
let
val (e, st) = jsE inner (e, st)
val (e', st) = unurlifyExp loc (t, st)
@@ -1162,11 +1163,11 @@ fun process file =
((ESetval (e1, e2), loc), st)
end
- | EUnurlify (e, t) =>
+ | EUnurlify (e, t, b) =>
let
val (e, st) = exp outer (e, st)
in
- ((EUnurlify (e, t), loc), st)
+ ((EUnurlify (e, t, b), loc), st)
end
| EJavaScript (m, e') =>
diff --git a/src/mono.sml b/src/mono.sml
index af5e9031..898feb9b 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -108,7 +108,7 @@ datatype exp' =
| ENextval of exp
| ESetval of exp * exp
- | EUnurlify of exp * typ
+ | EUnurlify of exp * typ * bool
| EJavaScript of javascript_mode * exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a5e795b2..d1f5fc27 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -334,9 +334,9 @@ fun p_exp' par env (e, _) =
space,
p_exp env e2,
string ")"]
- | EUnurlify (e, _) => box [string "unurlify(",
- p_exp env e,
- string ")"]
+ | EUnurlify (e, _, _) => box [string "unurlify(",
+ p_exp env e,
+ string ")"]
| EJavaScript (m, e) => box [string "JavaScript(",
p_mode env m,
string ",",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 16cfd9f9..10de1c56 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -451,7 +451,7 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
- | EUnurlify (e, _) => summarize d e
+ | EUnurlify (e, _, _) => summarize d e
| EJavaScript (_, e) => summarize d e
| ESignalReturn e => summarize d e
| ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 02619437..a75843c4 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -346,12 +346,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e2,
fn e2' =>
(ESetval (e1', e2'), loc)))
- | EUnurlify (e, t) =>
+ | EUnurlify (e, t, b) =>
S.bind2 (mfe ctx e,
fn e' =>
S.map2 (mft t,
fn t' =>
- (EUnurlify (e', t'), loc)))
+ (EUnurlify (e', t', b), loc)))
| EJavaScript (m, e) =>
S.bind2 (mfmode ctx m,
fn m' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index ff5a0f3a..bda6cfe4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1338,7 +1338,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
(L'.EAbs ("_", un, s,
(L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
- t),
+ t, true),
loc)), loc)), loc),
fm)
end
@@ -3255,7 +3255,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val t = monoType env t
in
- ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t), loc)), loc),
+ ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
+ loc)), loc),
fm)
end
diff --git a/src/prepare.sml b/src/prepare.sml
index 2d144c67..2f49405b 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -281,11 +281,11 @@ fun prepExp (e as (_, loc), st) =
((ESetval {seq = e1, count = e2}, loc), st)
end
- | EUnurlify (e, t) =>
+ | EUnurlify (e, t, b) =>
let
val (e, st) = prepExp (e, st)
in
- ((EUnurlify (e, t), loc), st)
+ ((EUnurlify (e, t, b), loc), st)
end
fun prepDecl (d as (_, loc), st) =
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 7dec8d80..129f4281 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -115,7 +115,7 @@ fun classify (ds, ps) =
| EDml {dml, ...} => hasClient dml
| ENextval {seq, ...} => hasClient seq
| ESetval {seq, count, ...} => hasClient seq orelse hasClient count
- | EUnurlify (e, _) => hasClient e
+ | EUnurlify (e, _, _) => hasClient e
in
hasClient
end
diff --git a/src/shake.sig b/src/shake.sig
index 6c617435..2b805dea 100644
--- a/src/shake.sig
+++ b/src/shake.sig
@@ -31,4 +31,7 @@ signature SHAKE = sig
val shake : Core.file -> Core.file
+ val sliceDb : bool ref
+ (* Set this to try to delete anything not needed to determine the database schema. *)
+
end
diff --git a/src/shake.sml b/src/shake.sml
index 39ebdde0..686a043c 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -29,6 +29,8 @@
structure Shake :> SHAKE = struct
+val sliceDb = ref false
+
open Core
structure U = CoreUtil
@@ -67,7 +69,11 @@ fun shake file =
val (usedE, usedC) =
List.foldl
- (fn ((DExport (_, n, _), _), (usedE, usedC)) => (IS.add (usedE, n), usedC)
+ (fn ((DExport (_, n, _), _), st as (usedE, usedC)) =>
+ if !sliceDb then
+ st
+ else
+ (IS.add (usedE, n), usedC)
| ((DTable (_, _, c, _, pe, pc, ce, cc), _), (usedE, usedC)) =>
let
val usedC = usedVarsC usedC c
@@ -79,7 +85,11 @@ fun shake file =
in
(usedE, usedC)
end
- | ((DTask (e1, e2), _), st) => usedVars (usedVars st e1) e2
+ | ((DTask (e1, e2), _), st) =>
+ if !sliceDb then
+ st
+ else
+ usedVars (usedVars st e1) e2
| (_, acc) => acc) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -186,14 +196,14 @@ fun shake file =
| (DDatatype dts, _) => List.exists (fn (_, n, _, _) => IS.member (#con s, n)) dts
| (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
- | (DExport _, _) => true
+ | (DExport _, _) => not (!sliceDb)
| (DView _, _) => true
| (DSequence _, _) => true
| (DTable _, _) => true
- | (DDatabase _, _) => true
- | (DCookie _, _) => true
- | (DStyle _, _) => true
- | (DTask _, _) => true) file
+ | (DDatabase _, _) => not (!sliceDb)
+ | (DCookie _, _) => not (!sliceDb)
+ | (DStyle _, _) => not (!sliceDb)
+ | (DTask _, _) => not (!sliceDb)) file
end
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-09 19:03:38 +0000