diff options
-rw-r--r-- | src/checknest.sml | 4 | ||||
-rw-r--r-- | src/cjr.sml | 2 | ||||
-rw-r--r-- | src/cjr_print.sml | 36 | ||||
-rw-r--r-- | src/cjrize.sml | 4 | ||||
-rw-r--r-- | src/jscomp.sml | 9 | ||||
-rw-r--r-- | src/mono.sml | 2 | ||||
-rw-r--r-- | src/mono_print.sml | 6 | ||||
-rw-r--r-- | src/mono_reduce.sml | 2 | ||||
-rw-r--r-- | src/mono_util.sml | 4 | ||||
-rw-r--r-- | src/monoize.sml | 5 | ||||
-rw-r--r-- | src/prepare.sml | 4 | ||||
-rw-r--r-- | src/scriptcheck.sml | 2 | ||||
-rw-r--r-- | src/shake.sig | 3 | ||||
-rw-r--r-- | src/shake.sml | 24 |
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 |