From c881c3b462801bc67419783c4169302fce5e3aeb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 3 Dec 2014 21:06:15 -0500 Subject: Some more optimization of string expressions showing up in JSON generation (Meta library) --- src/mono_opt.sml | 5 +++++ src/mono_reduce.sml | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index d1e5ce55..a49d54e1 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -220,6 +220,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), _), _)]) => diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 50553560..591d4c1b 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -208,6 +208,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 -- cgit v1.2.3 From 7639360d7a0111054b68c3fe91bb2558706aaefc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 3 Dec 2014 21:21:37 -0500 Subject: MonoOpt: remove concatenation with empty string --- src/mono_opt.sml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index a49d54e1..211b273e 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -166,6 +166,9 @@ fun exp e = 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 -- cgit v1.2.3 From de8817f2e2e5cf49421cdcc08a754b8277f13866 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 4 Dec 2014 02:47:24 -0500 Subject: More aggressive inlining of 'let' with record literals, plus some changes to Monoization of queries, to make inlining more common --- src/mono_reduce.sml | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++++- src/monoize.sml | 12 ++++----- 2 files changed, 83 insertions(+), 7 deletions(-) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 591d4c1b..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 @@ -592,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 @@ -650,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 0829abc9..6563da8b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1992,9 +1992,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) @@ -2103,8 +2103,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), @@ -2132,8 +2132,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), -- cgit v1.2.3 From 514bde72c4a3f291221bbb362b9496c020042925 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 4 Dec 2014 19:54:04 -0500 Subject: Optimizing writes of single characters --- include/urweb/urweb_cpp.h | 2 ++ src/c/urweb.c | 4 ++++ src/mono_opt.sml | 2 ++ 3 files changed, 8 insertions(+) diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 637cddfc..39679dd5 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -396,4 +396,6 @@ extern const char uw_begin_xhtml[], uw_begin_html5[]; int uw_remoteSock(struct uw_context *); void uw_set_remoteSock(struct uw_context *, int sock); +void uw_Basis_writec(struct uw_context *, char); + #endif diff --git a/src/c/urweb.c b/src/c/urweb.c index 1f2c8b3c..e2881b05 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1659,6 +1659,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/mono_opt.sml b/src/mono_opt.sml index 211b273e..2d40e0f0 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -626,6 +626,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))) -- cgit v1.2.3 From b50cd7f9ddf5f7d8428ba79a0e336556389ac1c0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 4 Dec 2014 20:22:39 -0500 Subject: In checking signature subsumption, be sure to try constraints last. --- src/elab_env.sml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 9fbe7bd7..711db166 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1114,7 +1114,24 @@ and hnormSgn env (all as (sgn, loc)) = case sgn of SgnError => all | SgnVar n => hnormSgn env (#2 (lookupSgnNamed env n)) - | SgnConst _ => all + | SgnConst sgis => + 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 (constraint, others) = List.partition + (fn (SgiConstraint _, _) => true + | _ => false) sgis + in + case constraint of + [] => all + | _ => (SgnConst (others @ constraint), loc) + end | SgnFun _ => all | SgnProj (m, ms, x) => let -- cgit v1.2.3 From b6df808b8ff4795f4523c39860070d6153cfad5d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 5 Dec 2014 19:41:27 -0500 Subject: Move code from last changeset, to improve performance --- src/elab_env.sml | 19 +------------------ src/elaborate.sml | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 711db166..9fbe7bd7 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1114,24 +1114,7 @@ and hnormSgn env (all as (sgn, loc)) = case sgn of SgnError => all | SgnVar n => hnormSgn env (#2 (lookupSgnNamed env n)) - | SgnConst sgis => - 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 (constraint, others) = List.partition - (fn (SgiConstraint _, _) => true - | _ => false) sgis - in - case constraint of - [] => all - | _ => (SgnConst (others @ constraint), loc) - end + | SgnConst _ => all | SgnFun _ => all | SgnProj (m, ms, x) => let 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)), -- cgit v1.2.3 From 7ef395b5a662246f57637e063949d00ddcf8e9dd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 6 Dec 2014 15:26:56 -0500 Subject: New release --- CHANGELOG | 9 +++++++++ configure.ac | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 979f4d87..4ac2df97 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +20141206 +======== + +- New HTML5 form widget tags and attributes +- New command-line option for HTTP servers: '-T', to set recv() timeout +- New C function uw_remoteSock() for use in FFI code +- Bug fixes and improvements to type inference and optimization + ======== 20140830 ======== diff --git a/configure.ac b/configure.ac index 2ff25580..ca0d48af 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20140830]) -WORKING_VERSION=1 +AC_INIT([urweb], [20141206]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From d47f51e33733c851a53feb308ddaee3924910371 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 6 Dec 2014 15:45:41 -0500 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index ca0d48af..57a4dc02 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20141206]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3