diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2020-09-15 11:47:02 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-09-24 13:46:21 -0400 |
| commit | 2cad0a4723ffe05dd5d072950c1945f64d588bdd (patch) | |
| tree | 9c015afe630e3ee4af5ed156b6d01c48cddb8e51 | |
| parent | b689f3db0229ac58af5383796fb13c6d40e358ce (diff) | |
| download | haskell-2cad0a4723ffe05dd5d072950c1945f64d588bdd.tar.gz | |
Simplify: Allow case-of-bottom to be disabled
| -rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 3 |
3 files changed, 11 insertions, 2 deletions
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 070ea11cc2..3964bdfe83 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -165,6 +165,8 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_case_bottom :: !Bool -- ^ Whether to discard continuations + -- of bottoming case expressions , sm_dflags :: DynFlags -- Just for convenient non-monadic access; we don't override these. -- @@ -181,14 +183,17 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad 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_case_bottom = cb }) = 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") + , pp_flag cb (sLit "case-of-bottom") + ]) where pp_flag f s = ppUnless f (text "no") <+> ptext s diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e219a0dba9..9043e45f33 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1941,6 +1941,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) con | not (contIsTrivial cont) -- Only do this if there is a non-trivial -- continuation to discard, else we do it -- again and again! + , sm_case_bottom (getMode env) = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] return (emptyFloats env, castBottomExpr res cont_ty) where diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 420d406eed..c13f456cd1 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -306,6 +306,8 @@ instance Outputable ArgSpec where addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty + | ArgInfo { ai_dmds = [] } <- ai + = addValArgTo (ai { ai_dmds = repeat topDmd }) arg hole_ty | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai -- Pop the top demand and and discounts off , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } @@ -871,6 +873,7 @@ simplEnvForGHCi dflags -- interpreter , sm_eta_expand = eta_expand_on , sm_case_case = True + , sm_case_bottom = True , sm_pre_inline = pre_inline_on } where |