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

git at git.haskell.org git at git.haskell.org
Wed Sep 20 16:26:20 UTC 2017


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

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

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

commit 845a0e3bda5e093d8c380176cc2c427f80cc9bdf
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


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

845a0e3bda5e093d8c380176cc2c427f80cc9bdf
 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 107440a..33d1820 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -174,19 +174,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 0ceaf82..6b41510 100644
--- a/compiler/simplCore/Exitify.hs
+++ b/compiler/simplCore/Exitify.hs
@@ -350,6 +350,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 956a72b..91279c9 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -144,20 +144,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 76ec091..3a59d70 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -738,7 +738,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
@@ -1090,7 +1092,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 6e80300..89e9544 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -3245,7 +3245,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



More information about the ghc-commits mailing list