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

[git at git.haskell.org]

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

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

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

commit d619e1de1ee6d5b1da88d43c3a5c5f1eacce82f7
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


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

d619e1de1ee6d5b1da88d43c3a5c5f1eacce82f7
 compiler/simplCore/CoreMonad.hs  |  7 +++++--
 compiler/simplCore/Exitify.hs    |  3 +++
 compiler/simplCore/SimplCore.hs  | 17 ++++++++++-------
 compiler/simplCore/SimplUtils.hs |  7 +++++--
 compiler/simplCore/Simplify.hs   |  3 ++-
 5 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 3cb23cb..993b904 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -173,19 +173,22 @@ data SimplifierMode             -- 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 SimplifierMode 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 c699478..1207089 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -141,19 +141,22 @@ getCoreToDo dflags
     maybe_strictness_before phase
       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 
-    base_mode = SimplMode { sm_phase      = panic "base_mode"
-                          , sm_names      = []
-                          , 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_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 bdbd6a1..f101dba 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -713,7 +713,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
@@ -1065,7 +1067,8 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
   | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
   | not (gopt Opt_SimplPreInlining dflags)   = False
   | 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 d01fae0..253f682 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -3354,7 +3354,8 @@ simplLetUnfolding :: SimplEnv-> TopLevelFlag
 simplLetUnfolding env top_lvl cont_mb id new_rhs unf
   | isStableUnfolding unf
   = simplUnfolding 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
   = is_bottoming `seq`  -- See Note [Force bottoming field]