[commit: ghc] wip/T14152: Inline exit join points in the "final" simplifier iteration (5374dec)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T14152
Link       : http://ghc.haskell.org/trac/ghc/changeset/5374dec7a871fb7b75472a3055adc738660fbb1b/ghc

>---------------------------------------------------------------

commit 5374dec7a871fb7b75472a3055adc738660fbb1b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Sep 1 15:02:34 2017 +0100

    Inline exit join points in the "final" simplifier iteration


>---------------------------------------------------------------

5374dec7a871fb7b75472a3055adc738660fbb1b
 compiler/simplCore/CoreMonad.hs  |  7 +++++--
 compiler/simplCore/Exitify.hs    |  3 +++
 compiler/simplCore/SimplCore.hs  | 19 +++++++++++--------
 compiler/simplCore/SimplUtils.hs |  7 +++++--
 compiler/simplCore/Simplify.hs   |  3 ++-
 5 files changed, 26 insertions(+), 13 deletions(-)

diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 03b380d..46d81df 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -175,19 +175,22 @@ data SimplMode             -- See comments in SimplMonad
         , sm_inline     :: Bool     -- Whether inlining is enabled
         , sm_case_case  :: Bool     -- Whether case-of-case is enabled
         , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+        , sm_preserve_exit_joins :: Bool -- Whether exit join points must be preserved
         }
 
 instance Outputable SimplMode where
     ppr (SimplMode { sm_phase = p, sm_names = ss
                    , sm_rules = r, sm_inline = i
-                   , sm_eta_expand = eta, sm_case_case = cc })
+                   , sm_eta_expand = eta, sm_case_case = cc
+                   , sm_preserve_exit_joins = pej })
        = text "SimplMode" <+> braces (
          sep [ text "Phase =" <+> ppr p <+>
                brackets (text (concat $ intersperse "," ss)) <> comma
              , pp_flag i   (sLit "inline") <> comma
              , pp_flag r   (sLit "rules") <> comma
              , pp_flag eta (sLit "eta-expand") <> comma
-             , pp_flag cc  (sLit "case-of-case") ])
+             , pp_flag cc  (sLit "case-of-case") <> comma
+             , pp_flag pej (sLit "preserve-exit-joins") ])
          where
            pp_flag f s = ppUnless f (text "no") <+> ptext s
 
diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
index 9cabb8e..0a4a060 100644
--- a/compiler/simplCore/Exitify.hs
+++ b/compiler/simplCore/Exitify.hs
@@ -344,6 +344,9 @@ For `postInlineUnconditionally` and unfolding-based inlining, the function
 `simplLetUnfolding` simply gives exit join points no unfolding, which prevents
 this kind of inlining.
 
+In the `final` run of the simplifier, we do allow inlining of exit join points,
+via a `SimplifierMode` flag.
+
 Note [Avoid duplicate exit points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 4b41792..70d5e0f 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -142,20 +142,23 @@ getCoreToDo dflags
     maybe_strictness_before phase
       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 
-    base_mode = SimplMode { sm_phase      = panic "base_mode"
-                          , sm_names      = []
-                          , sm_dflags     = dflags
-                          , sm_rules      = rules_on
-                          , sm_eta_expand = eta_expand_on
-                          , sm_inline     = True
-                          , sm_case_case  = True }
+    base_mode = SimplMode { sm_phase               = panic "base_mode"
+                          , sm_names               = []
+                          , sm_dflags              = dflags
+                          , sm_rules               = rules_on
+                          , sm_eta_expand          = eta_expand_on
+                          , sm_inline              = True
+                          , sm_case_case           = True
+                          , sm_preserve_exit_joins = True}
 
     simpl_phase phase names iter
       = CoreDoPasses
       $   [ maybe_strictness_before phase
           , CoreDoSimplify iter
                 (base_mode { sm_phase = Phase phase
-                           , sm_names = names })
+                           , sm_names = names
+                           , sm_preserve_exit_joins = names /= ["final"]
+                           })
 
           , maybe_rule_check (Phase phase) ]
 
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index b9e1664..3ba340c 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -736,7 +736,9 @@ simplEnvForGHCi dflags
                            , sm_rules  = rules_on
                            , sm_inline = False
                            , sm_eta_expand = eta_expand_on
-                           , sm_case_case  = True }
+                           , sm_case_case = True
+                           , sm_preserve_exit_joins = False
+                           }
   where
     rules_on      = gopt Opt_EnableRewriteRules   dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
@@ -1088,7 +1090,8 @@ preInlineUnconditionally env top_lvl bndr rhs
   | isStableUnfolding (idUnfolding bndr)     = False -- Note [Stable unfoldings and preInlineUnconditionally]
   | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
   | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
-  | isExitJoinId bndr                        = False
+  | sm_preserve_exit_joins mode
+  , isExitJoinId bndr                        = False -- Note [Do not inline exit join points]
   | otherwise = case idOccInfo bndr of
                   IAmDead                    -> True -- Happens in ((\x.1) v)
                   occ at OneOcc { occ_one_br = True }
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 10e7859..c2d3279 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -3243,7 +3243,8 @@ simplLetUnfolding :: SimplEnv-> TopLevelFlag
 simplLetUnfolding env top_lvl cont_mb id new_rhs unf
   | isStableUnfolding unf
   = simplStableUnfolding env top_lvl cont_mb id unf
-  | isExitJoinId id
+  | sm_preserve_exit_joins (getMode env)
+  , isExitJoinId id
   = return unf -- see Note [Do not inline exit join points]
   | otherwise
   = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs