From 85e68b2124e33f5b005dd2bf2206a0e12b46073c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 6 Mar 2015 09:46:21 -0500
Subject: Change MonoReduce to do fixed-pointing, since it sometimes enables
 more optimizations for itself (e.g., yanking lambdas out of [case]s)

---
 src/mono_reduce.sml | 39 +++++++++++++++++++++++++++------------
 1 file changed, 27 insertions(+), 12 deletions(-)

(limited to 'src/mono_reduce.sml')

diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 39d02b99..61866af7 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -330,7 +330,9 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false,
                                              U.Exp.RelE _ => n + 1
                                            | _ => n} 0
 
-fun reduce (file : file) =
+val yankedCase = ref false
+
+fun reduce' (file : file) =
     let
         val (timpures, impures, absCounts) =
             foldl (fn ((d, _), (timpures, impures, absCounts)) =>
@@ -770,17 +772,18 @@ fun reduce (file : file) =
                                                                       Print.PD.string "}"]
                                     in
                                         if List.all (safe o #2) pes then
-                                            EAbs ("y", dom, result,
-                                                  (ECase (liftExpInExp 0 e',
-                                                          map (fn (p, (EAbs (_, _, _, e), _)) =>
-                                                                  (p, swapExpVarsPat (0, patBinds p) e)
-                                                                | (p, (EError (e, (TFun (_, t), _)), loc)) =>
-                                                                  (p, (EError (liftExpInExp (patBinds p) e, t), loc))
-                                                                | (p, e) =>
-                                                                  (p, (EApp (liftExpInExp (patBinds p) e,
-                                                                             (ERel (patBinds p), loc)), loc)))
-                                                              pes,
-                                                          {disc = disc, result = result}), loc))
+                                            (yankedCase := true;
+                                             EAbs ("y", dom, result,
+                                                   (ECase (liftExpInExp 0 e',
+                                                           map (fn (p, (EAbs (_, _, _, e), _)) =>
+                                                                   (p, swapExpVarsPat (0, patBinds p) e)
+                                                               | (p, (EError (e, (TFun (_, t), _)), loc)) =>
+                                                                 (p, (EError (liftExpInExp (patBinds p) e, t), loc))
+                                                               | (p, e) =>
+                                                                 (p, (EApp (liftExpInExp (patBinds p) e,
+                                                                            (ERel (patBinds p), loc)), loc)))
+                                                               pes,
+                                                           {disc = disc, result = result}), loc)))
                                         else
                                             e
                                     end
@@ -894,4 +897,16 @@ fun reduce (file : file) =
         U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
     end
 
+fun reduce file =
+    let
+        val () = yankedCase := false
+        val file' = reduce' file
+    in
+        if !yankedCase then
+            reduce file'
+        else
+            file'
+    end
+
+
 end
-- 
cgit v1.2.3