summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-12-11 02:05:41 -0500
committerGravatar Ziv Scully <ziv@mit.edu>2014-12-11 02:05:41 -0500
commit7a2739b18042953cdfc608a5d9c96237c97cebba (patch)
treef9598f40d97e26581e6f9f4cb910f5e335f7b0e1 /src
parent219524359a25417b9e140130ab77a9a330c41012 (diff)
parentd47f51e33733c851a53feb308ddaee3924910371 (diff)
Merge.
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c4
-rw-r--r--src/elaborate.sml19
-rw-r--r--src/mono_opt.sml10
-rw-r--r--src/mono_reduce.sml92
-rw-r--r--src/monoize.sml12
5 files changed, 130 insertions, 7 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 4cd347b2..d01cfaa2 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1664,6 +1664,10 @@ void uw_writec(uw_context ctx, char c) {
uw_writec_unsafe(ctx, c);
}
+void uw_Basis_writec(uw_context ctx, char c) {
+ uw_writec(ctx, c);
+}
+
static void uw_write_unsafe(uw_context ctx, const char* s) {
int len = strlen(s);
memcpy(ctx->page.front, s, len);
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c55dec01..749bd2f1 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3020,6 +3020,25 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
| (L'.SgnConst sgis1, L'.SgnConst sgis2) =>
let
+ (* This reshuffling was added to avoid some unfortunate unification behavior.
+ * In particular, in sub-signature checking, constraints might be unified,
+ * even when we don't expect them to be unifiable, deciding on bad values
+ * for unification variables and dooming later unification.
+ * By putting all the constraints _last_, we allow all the other unifications
+ * to happen first, hoping that no unification variables survive to confuse
+ * constraint unification. *)
+
+ val sgis2 =
+ let
+ val (constraints, others) = List.partition
+ (fn (L'.SgiConstraint _, _) => true
+ | _ => false) sgis2
+ in
+ case constraints of
+ [] => sgis2
+ | _ => others @ constraints
+ end
+
(*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1),
("sgn2", p_sgn env sgn2),
("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)),
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 97f78d3d..22ee36fc 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -167,6 +167,9 @@ fun exp e =
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
+ | EStrcat (e1, (EPrim (Prim.String (_, "")), _)) => #1 e1
+ | EStrcat ((EPrim (Prim.String (_, "")), _), e2) => #1 e2
+
| EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) =>
let
val s =
@@ -220,6 +223,11 @@ fun exp e =
| EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) =>
EFfiApp ("Basis", "htmlifySpecialChar_w", [e])
+ | EWrite (EFfiApp ("Basis", "intToString", [e]), _) =>
+ EFfiApp ("Basis", "htmlifyInt_w", [e])
+ | EApp ((EFfi ("Basis", "intToString"), loc), e) =>
+ EFfiApp ("Basis", "intToString", [(e, (TFfi ("Basis", "int"), loc))])
+
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) =>
EPrim (Prim.String (Prim.Html, htmlifyInt n))
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) =>
@@ -621,6 +629,8 @@ fun exp e =
EFfiApp ("Basis", "attrifyChar", [e])
| EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
EFfiApp ("Basis", "attrifyChar_w", [e])
+ | EWrite (EFfiApp ("Basis", "str1", [e]), _) =>
+ EFfiApp ("Basis", "writec", [e])
| EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 50553560..8ca84c15 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -39,6 +39,10 @@ structure U = MonoUtil
structure IM = IntBinaryMap
structure IS = IntBinarySet
+structure SS = BinarySetFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
fun simpleTypeImpure tsyms =
U.Typ.exists (fn TFun _ => true
@@ -208,6 +212,20 @@ fun match (env, p : pat, e : exp) =
else
No
+ | (PPrim (Prim.String (_, s)), _) =>
+ let
+ fun lengthLb (e : exp) =
+ case #1 e of
+ EStrcat (e1, e2) => lengthLb e1 + lengthLb e2
+ | EPrim (Prim.String (_, s)) => size s
+ | _ => 0
+ in
+ if lengthLb e > size s then
+ No
+ else
+ Maybe
+ end
+
| (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
if n1 = n2 then
case (po, eo) of
@@ -578,6 +596,75 @@ fun reduce (file : file) =
case e' of
(ECase _, _) => e
| _ => doSub ())
+
+ fun isRecord () =
+ case #1 e' of
+ ERecord _ => true
+ | _ => false
+
+ fun whichProj i (e : exp) =
+ case #1 e of
+ EPrim _ => SOME SS.empty
+ | ERel i' => if i' = i then NONE else SOME SS.empty
+ | ENamed _ => SOME SS.empty
+ | ECon (_, _, NONE) => SOME SS.empty
+ | ECon (_, _, SOME e') => whichProj i e'
+ | ENone _ => SOME SS.empty
+ | ESome (_, e') => whichProj i e'
+ | EFfi _ => SOME SS.empty
+ | EFfiApp (_, _, es) => whichProjs i (map #1 es)
+ | EApp (e1, e2) => whichProjs i [e1, e2]
+ | EAbs (_, _, _, e) => whichProj (i + 1) e
+ | EUnop (_, e1) => whichProj i e1
+ | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
+ | ERecord xets => whichProjs i (map #2 xets)
+ | EField ((ERel i', _), s) =>
+ if i' = i then
+ SOME (SS.singleton s)
+ else
+ SOME SS.empty
+ | EField (e1, _) => whichProj i e1
+ | ECase (e1, pes, _) =>
+ whichProjs' i ((0, e1)
+ :: map (fn (p, e) => (patBinds p, e)) pes)
+ | EStrcat (e1, e2) => whichProjs i [e1, e2]
+ | EError (e1, _) => whichProj i e1
+ | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2
+ | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2]
+ | ERedirect (e1, _) => whichProj i e1
+ | EWrite e1 => whichProj i e1
+ | ESeq (e1, e2) => whichProjs i [e1, e2]
+ | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)]
+ | EClosure (_, es) => whichProjs i es
+ | EQuery {query = e1, body = e2, initial = e3, ...} =>
+ whichProjs' i [(0, e1), (2, e2), (0, e3)]
+ | EDml (e1, _) => whichProj i e1
+ | ENextval e1 => whichProj i e1
+ | ESetval (e1, e2) => whichProjs i [e1, e2]
+ | EUnurlify (e1, _, _) => whichProj i e1
+ | EJavaScript (_, e1) => whichProj i e1
+ | ESignalReturn e1 => whichProj i e1
+ | ESignalBind (e1, e2) => whichProjs i [e1, e2]
+ | ESignalSource e1 => whichProj i e1
+ | EServerCall (e1, _, _, _) => whichProj i e1
+ | ERecv (e1, _) => whichProj i e1
+ | ESleep e1 => whichProj i e1
+ | ESpawn e1 => whichProj i e1
+
+ and whichProjs i es =
+ whichProjs' i (map (fn e => (0, e)) es)
+
+ and whichProjs' i es =
+ case es of
+ [] => SOME SS.empty
+ | (n, e) :: es' =>
+ case (whichProj (i + n) e, whichProjs' i es') of
+ (SOME m1, SOME m2) =>
+ if SS.isEmpty (SS.intersection (m1, m2)) then
+ SOME (SS.union (m1, m2))
+ else
+ NONE
+ | _ => NONE
in
if impure env e' then
let
@@ -636,7 +723,10 @@ fun reduce (file : file) =
else
e
end
- else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then
+ else if countFree 0 0 b > 1
+ andalso not (!fullMode)
+ andalso not (passive e')
+ andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then
e
else
trySub ()
diff --git a/src/monoize.sml b/src/monoize.sml
index fa69b3af..4034e3ed 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2003,9 +2003,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcat [gf "Rows",
(L'.ECase (gf "OrderBy",
[((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""),
- ((L'.PWild, loc),
+ ((L'.PVar ("orderby", s), loc),
strcat [str " ORDER BY ",
- gf "OrderBy"])],
+ (L'.ERel 0, loc)])],
{disc = s, result = s}), loc),
gf "Limit",
gf "Offset"]), loc), fm)
@@ -2114,8 +2114,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
[((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))),
loc),
str ""),
- ((L'.PWild, loc),
- strcat [str " WHERE ", gf "Where"])],
+ ((L'.PVar ("where", s), loc),
+ strcat [str " WHERE ", (L'.ERel 0, loc)])],
{disc = s,
result = s}), loc),
@@ -2143,8 +2143,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
[((L'.PPrim (Prim.String
(Prim.Normal, #trueString (Settings.currentDbms ()))), loc),
str ""),
- ((L'.PWild, loc),
- strcat [str " HAVING ", gf "Having"])],
+ ((L'.PVar ("having", s), loc),
+ strcat [str " HAVING ", (L'.ERel 0, loc)])],
{disc = s,
result = s}), loc)
]), loc),