diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-03-25 18:10:43 +0000 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-04-07 09:38:49 +0100 |
| commit | 5184ca1fe4ceebf6018186bac9bf4234e42b3cb3 (patch) | |
| tree | 5ca478dd7f36fb46bb2cb1f7ee75104f0235c1fe | |
| parent | 247684adc83f025d2ee329f4c98ae1f8829060b4 (diff) | |
| download | haskell-5184ca1fe4ceebf6018186bac9bf4234e42b3cb3.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 |