diff options
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 7 | ||||
| -rw-r--r-- | compiler/simplCore/Exitify.hs | 3 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 37 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 7 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 3 |
5 files changed, 35 insertions, 22 deletions
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 107440a768..33d1820579 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 40c7374f15..53434bf107 100644 --- a/compiler/simplCore/Exitify.hs +++ b/compiler/simplCore/Exitify.hs @@ -386,4 +386,7 @@ To prevent inlining, we check for that in `preInlineUnconditionally` directly. 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. -} diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 956a72b652..6c8a0d3aaf 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 } - - simpl_phase phase names iter + 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 is_final = CoreDoPasses $ [ maybe_strictness_before phase , CoreDoSimplify iter (base_mode { sm_phase = Phase phase - , sm_names = names }) + , sm_names = names + , sm_preserve_exit_joins = is_final + }) , maybe_rule_check (Phase phase) ] @@ -185,7 +188,7 @@ getCoreToDo dflags -- inlined. I found that spectral/hartel/genfft lost some useful -- strictness in the function sumcode' if augment is not inlined -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter False | phase <- [phases, phases-1 .. 1] ] @@ -208,7 +211,7 @@ getCoreToDo dflags -- New demand analyser demand_analyser = (CoreDoPasses ( strictness_pass ++ - [simpl_phase 0 ["post-worker-wrapper"] max_iter] + [simpl_phase 0 ["post-worker-wrapper"] max_iter False] )) -- Static forms are moved to the top level with the FloatOut pass. @@ -297,7 +300,7 @@ getCoreToDo dflags -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), + simpl_phase 0 ["main"] (max max_iter 3) False, runWhen do_float_in CoreDoFloatInwards, -- Run float-inwards immediately before the strictness analyser @@ -308,7 +311,7 @@ getCoreToDo dflags runWhen call_arity $ CoreDoPasses [ CoreDoCallArity - , simpl_phase 0 ["post-call-arity"] max_iter + , simpl_phase 0 ["post-call-arity"] max_iter False ], runWhen strictness demand_analyser, @@ -339,7 +342,7 @@ getCoreToDo dflags -- strictness analysis and the simplification which follows it. runWhen liberate_case (CoreDoPasses [ CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter + simpl_phase 0 ["post-liberate-case"] max_iter False ]), -- Run the simplifier after LiberateCase to vastly -- reduce the possibility of shadowing -- Reason: see Note [Shadowing] in SpecConstr.hs @@ -349,11 +352,11 @@ getCoreToDo dflags maybe_rule_check (Phase 0), -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter, + simpl_phase 0 ["final"] max_iter True, runWhen late_dmd_anal $ CoreDoPasses ( strictness_pass ++ - [simpl_phase 0 ["post-late-ww"] max_iter] + [simpl_phase 0 ["post-late-ww"] max_iter False] ), -- Final run of the demand_analyser, ensures that one-shot thunks are diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 9420081d84..2445675bb7 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@OneOcc { occ_one_br = True } diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index b85b6902b9..f326a3ea73 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 |