diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/compiler.sig | 3 | ||||
-rw-r--r-- | src/compiler.sml | 7 | ||||
-rw-r--r-- | src/elaborate.sml | 5 | ||||
-rw-r--r-- | src/main.mlton.sml | 3 | ||||
-rw-r--r-- | src/mono_reduce.sml | 11 |
5 files changed, 22 insertions, 7 deletions
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) = |