diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-03-25 18:10:43 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-08 08:07:10 -0400 |
| commit | 898afe90c0a11a0c2b243efb75f2d83d17893b30 (patch) | |
| tree | cf665996b225b56fc8527038b57b34996b3c9549 | |
| parent | 88d8a0ed387cef8ee45aa3c1b3bc22d5d9d5e51a (diff) | |
| download | haskell-898afe90c0a11a0c2b243efb75f2d83d17893b30.tar.gz | |
Stop retaining SimplEnvs in unforced Unfoldings
Related to #15455
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unfold/Make.hs | 2 |
2 files changed, 8 insertions, 4 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 5daa7fc157..e46a5c1cc5 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -3088,7 +3088,9 @@ addAltUnfoldings env scrut case_bndr con_app ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } where - mk_simple_unf = mkSimpleUnfolding (seUnfoldingOpts env) + -- Force the opts, so that the whole SimplEnv isn't retained + !opts = seUnfoldingOpts env + mk_simple_unf = mkSimpleUnfolding opts addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf @@ -3864,12 +3866,14 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify | otherwise - = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs + = -- Otherwise, we end up retaining all the SimpleEnv + let !opts = seUnfoldingOpts env + in mkLetUnfolding opts top_lvl InlineRhs id new_rhs ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding -mkLetUnfolding uf_opts top_lvl src id new_rhs +mkLetUnfolding !uf_opts top_lvl src id new_rhs = is_bottoming `seq` -- See Note [Force bottoming field] return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index 54e44cfe04..aa95a13af1 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -70,7 +70,7 @@ mkCompulsoryUnfolding' expr -- Simplify.simplUnfolding. mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding -mkSimpleUnfolding opts rhs +mkSimpleUnfolding !opts rhs = mkUnfolding opts InlineRhs False False rhs mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding |