[commit: ghc] wip/T14152: Inline exit join points in the "final" simplifier iteration (8ec2062)
git at git.haskell.org
git at git.haskell.org
Wed Sep 20 15:59:20 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T14152
Link : http://ghc.haskell.org/trac/ghc/changeset/8ec2062347fb7deba69878c84c3b93ce9ea61707/ghc
>---------------------------------------------------------------
commit 8ec2062347fb7deba69878c84c3b93ce9ea61707
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
>---------------------------------------------------------------
8ec2062347fb7deba69878c84c3b93ce9ea61707
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 8d29719..1e11e1f 100644
--- a/compiler/simplCore/Exitify.hs
+++ b/compiler/simplCore/Exitify.hs
@@ -349,6 +349,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