Merge in upstream

6 files changed, 24 insertions, 7 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 0a088436..42ab7f70 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -341,6 +341,8 @@ fastcgi.server = (
 \item \texttt{-sql FILENAME}: Set where a database set-up SQL script is written.
 
 \item \texttt{-static}: Link the runtime system statically.  The default is to link against dynamic libraries.
+
+\item \texttt{-stop PHASE}: Stop compilation after the named phase, printing the intermediate program to stderr.  This flag is mainly useful for debugging the Ur/Web compiler itself.
 \end{itemize}
 
 There is an additional convenience method for invoking \texttt{urweb}.  If the main argument is \texttt{FOO}, and \texttt{FOO.ur} exists but \texttt{FOO.urp} doesn't, then the invocation is interpreted as if called on a \texttt{.urp} file containing \texttt{FOO} as its only main entry, with an additional \texttt{rewrite all FOO/*} directive.
diff --git a/src/compiler.sig b/src/compiler.sig
index fdb1311f..fa131cf4 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -202,4 +202,7 @@ signature COMPILER = sig
 
     val moduleOf : string -> string
 
+    val setStop : string -> unit
+    (* Stop compilation after this phase. *)
+
 end
diff --git a/src/compiler.sml b/src/compiler.sml
index 0ffab01c..21ae903f 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -86,6 +86,9 @@ val doIflow = ref false
 
 val doDumpSource = ref (fn () => ())
 
+val stop = ref (NONE : string option)
+fun setStop s = stop := SOME s
+
 fun transform (ph : ('src, 'dst) phase) name = {
     func = fn input => let
                   val () = if !debug then
@@ -102,6 +105,10 @@ fun transform (ph : ('src, 'dst) phase) name = {
                       (!doDumpSource ();
                        doDumpSource := (fn () => ());
                        NONE)
+                  else if !stop = SOME name then
+                      (Print.eprint (#print ph v);
+                       ErrorMsg.error ("Stopped compilation after phase " ^ name);
+                       NONE)
                   else
                       (if !dumpSource then
                            doDumpSource := (fn () => Print.eprint (#print ph v))
diff --git a/src/elaborate.sml b/src/elaborate.sml
index dfa8d0e2..0c8db756 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -873,8 +873,9 @@
                                              | _ => false}
 
          val (others1, others2) = eatMatching (fn (c1, c2) =>
-                                                  not (hasUnifs c1 andalso hasUnifs c2)
-                                                  andalso consEq env loc (c1, c2)) (#others s1, #others s2)
+                                                  c1 = c2
+                                                  orelse (not (hasUnifs c1 andalso hasUnifs c2)
+                                                          andalso consEq env loc (c1, c2))) (#others s1, #others s2)
          (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
 
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index b0c4e03f..6bdc9539 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -133,6 +133,9 @@ fun oneRun args =
               | "-static" :: rest =>
                 (Settings.setStaticLinking true;
                  doArgs rest)
+              | "-stop" :: phase :: rest =>
+                (Compiler.setStop phase;
+                 doArgs rest)
               | "-path" :: name :: path :: rest =>
                 (Compiler.addPath (name, path);
                  doArgs rest)
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index e96a0e8f..846a878b 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -45,7 +45,7 @@ fun simpleTypeImpure tsyms =
                    | TDatatype (n, _) => IS.member (tsyms, n)
                    | _ => false)
 
-fun simpleImpure (tsyms, syms) =
+fun simpleImpure isGlobal (tsyms, syms) =
     U.Exp.existsB {typ = fn _ => false,
                    exp = fn (env, e) =>
                             case e of
@@ -65,6 +65,7 @@ fun simpleImpure (tsyms, syms) =
                                 in
                                     simpleTypeImpure tsyms t
                                 end
+                              | EApp _ => not isGlobal
                               | _ => false,
                    bind = fn (env, b) =>
                              case b of
@@ -325,7 +326,7 @@ fun reduce (file : file) =
                                           case #1 e of
                                               ENamed n => IM.find (absCounts, n)
                                             | EApp (e, arg) =>
-                                              if simpleImpure (timpures, impures) env arg then
+                                              if simpleImpure true (timpures, impures) env arg then
                                                   NONE
                                               else
                                                   (case remaining e of
@@ -352,14 +353,14 @@ fun reduce (file : file) =
                                absCounts)
                             | DVal (_, n, _, e, _) =>
                               (timpures,
-                               if simpleImpure (timpures, impures) E.empty e then
+                               if simpleImpure true (timpures, impures) E.empty e then
                                    IS.add (impures, n)
                                else
                                    impures,
                                IM.insert (absCounts, n, countAbs E.empty e))
                             | DValRec vis =>
                               (timpures,
-                               if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
+                               if List.exists (fn (_, _, _, e, _) => simpleImpure true (timpures, impures) E.empty e) vis then
                                    foldl (fn ((_, n, _, _, _), impures) =>
                                              IS.add (impures, n)) impures vis
                                else
@@ -532,7 +533,7 @@ fun reduce (file : file) =
             end
 
         val impure = fn env => fn e =>
-                        simpleImpure (timpures, impures) env e andalso impure e
+                        simpleImpure false (timpures, impures) env e andalso impure e
                         andalso not (List.null (summarize ~1 e))
 
         fun passive (e : exp) =