[Git][ghc/ghc][wip/T24334] 2 commits: Simplifier: Preserve OccInfo on DataAlt fields when case binder is dead (#24770)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue May 7 12:33:49 UTC 2024
Sebastian Graf pushed to branch wip/T24334 at Glasgow Haskell Compiler / GHC
Commits:
a5c61b58 by Sebastian Graf at 2024-05-07T14:33:17+02:00
Simplifier: Preserve OccInfo on DataAlt fields when case binder is dead (#24770)
See the adjusted `Note [DataAlt occ info]`.
This change also has a positive repercussion on
`Note [Combine case alts: awkward corner]`.
Fixes #24770.
- - - - -
350ea87e by Sebastian Graf at 2024-05-07T14:33:20+02:00
Kill seqRule, discard dead seq# in Prep (#24334)
Discarding seq#s in Core land via `seqRule` was problematic; see #24334.
So instead we discard certain dead, discardable seq#s in Prep now.
See the updated `Note [seq# magic]`.
This fixes the symptoms of #24334.
- - - - -
15 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/codeGen/should_compile/T24264.hs
- + testsuite/tests/core-to-stg/T24334.hs
- + testsuite/tests/core-to-stg/T24334.stdout
- testsuite/tests/core-to-stg/all.T
- testsuite/tests/simplCore/should_compile/T21851.stderr
- + testsuite/tests/simplCore/should_compile/T24770.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -9,12 +9,8 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where
import GHC.Prelude
import GHC.Core.Subst
-import GHC.Types.Var ( Var )
import GHC.Types.Var.Env ( mkInScopeSet )
-import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
- , idInlineActivation, setInlineActivation
- , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
- , isJoinId, idJoinPointHood, idUnfolding )
+import GHC.Types.Id
import GHC.Core.Utils ( mkAltExpr
, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
@@ -754,7 +750,7 @@ combineAlts alts
, Alt _ bndrs1 rhs1 <- alt1
, let filtered_alts = filterOut (identical_alt rhs1) rest_alts
, not (equalLength rest_alts filtered_alts)
- = assertPpr (null bndrs1) (ppr alts) $
+ = assertPpr (all isDeadBinder bndrs1) (ppr alts) $
Alt DEFAULT [] rhs1 : filtered_alts
| otherwise
@@ -762,14 +758,13 @@ combineAlts alts
where
find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])
- -- The (Just alt) is a binder-free alt
- -- See Note [Combine case alts: awkward corner]
+ -- The (Just alt) is an alt where all fields are dead
find_bndr_free_alt []
= (Nothing, [])
find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)
- | null bndrs = (Just alt, alts)
- | otherwise = case find_bndr_free_alt alts of
- (mb_bf, alts) -> (mb_bf, alt:alts)
+ | all isDeadBinder bndrs = (Just alt, alts)
+ | otherwise = case find_bndr_free_alt alts of
+ (mb_bf, alts) -> (mb_bf, alt:alts)
identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs
-- Even if this alt has binders, they will have been cloned
@@ -823,9 +818,9 @@ big for cheapEqExpr to catch it.
Note [Combine case alts: awkward corner]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We would really like to check isDeadBinder on the binders in the
-alternative. But alas, the simplifer zaps occ-info on binders in case
-alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify.
+We check isDeadBinder on field binders in order to collapse into a DEFAULT alt.
+But alas, the simplifer often zaps occ-info on field binders in DataAlts when
+the case binder is alive; see Note [DataAlt occ info] in GHC.Core.Opt.Simplify.
* One alternative (perhaps a good one) would be to do OccAnal
just before CSE. Then perhaps we could get rid of combineIdenticalAlts
@@ -833,14 +828,12 @@ alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify.
* Another would be for CSE to return free vars as it goes.
-* But the current solution is to find a nullary alternative (including
- the DEFAULT alt, if any). This will not catch
- case x of
- A y -> blah
- B z p -> blah
- where no alternative is nullary or DEFAULT. But the current
- solution is at least cheap.
-
+* But the current solution is to accept that we do not catch cases such as
+ case x of c
+ A _ -> blah[c]
+ B _ _ -> blah[c]
+ where the case binder c is alive and no alternative is DEFAULT.
+ But the current solution is at least cheap.
************************************************************************
* *
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2067,21 +2067,18 @@ unsafeEqualityProofRule
{- *********************************************************************
* *
- Rules for seq# and spark#
+ Rules for spark#
* *
********************************************************************* -}
-seqRule :: RuleM CoreExpr
-seqRule = do
+-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
+sparkRule :: RuleM CoreExpr
+sparkRule = do -- reduce on HNF
[Type _ty_a, Type _ty_s, a, s] <- getArgs
guard $ exprIsHNF a
return $ mkCoreUnboxedTuple [s, a]
-
--- spark# :: forall a s . a -> State# s -> (# State# s, a #)
-sparkRule :: RuleM CoreExpr
-sparkRule = seqRule -- reduce on HNF, just the same
- -- XXX perhaps we shouldn't do this, because a spark eliminated by
- -- this rule won't be counted as a dud at runtime?
+ -- XXX perhaps we shouldn't do this, because a spark eliminated by
+ -- this rule won't be counted as a dud at runtime?
{-
************************************************************************
@@ -2158,9 +2155,7 @@ builtinRules
platform <- getPlatform
return $ Var (primOpId IntAndOp)
`App` arg `App` mkIntVal platform (d - 1)
- ],
-
- mkBasicRule seqHashName 4 seqRule
+ ]
]
++ builtinBignumRules
{-# NOINLINE builtinRules #-}
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -26,7 +26,7 @@ core expression with (hopefully) improved usage information.
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
occurAnalyseExpr,
- zapLambdaBndrs, scrutBinderSwap_maybe
+ zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap
) where
import GHC.Prelude hiding ( head, init, last, tail )
@@ -3262,7 +3262,7 @@ inline x, cancel the casts, and away we go.
Note [Care with binder-swap on dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note explains why we need isDictId in scrutBinderSwap_maybe.
+This Note explains why we need isDictId in scrutOkForBinderSwap.
Consider this tricky example (#21229, #21470):
class Sing (b :: Bool) where sing :: Bool
@@ -3306,7 +3306,7 @@ Conclusion:
for a /dictionary variable/ do not perform
the clever cast version of the binder-swap
-Hence the subtle isDictId in scrutBinderSwap_maybe.
+Hence the subtle isDictId in scrutOkForBinderSwap.
Note [Zap case binders in proxy bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3328,7 +3328,7 @@ addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
-- See Note [The binder-swap substitution]
addBndrSwap scrut case_bndr
env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
- | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut
+ | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut
, scrut_var /= case_bndr
-- Consider: case x of x { ... }
-- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
@@ -3342,25 +3342,30 @@ addBndrSwap scrut case_bndr
case_bndr' = zapIdOccInfo case_bndr
-- See Note [Zap case binders in proxy bindings]
-scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)
--- If (scrutBinderSwap_maybe e = Just (v, mco), then
+-- | See bBinderSwaOk.
+data BinderSwapDecision
+ = NoBinderSwap
+ | DoBinderSwap OutVar MCoercion
+
+scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
+-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then
-- v = e |> mco
-- See Note [Case of cast]
-- See Note [Care with binder-swap on dictionaries]
--
-- We use this same function in SpecConstr, and Simplify.Iteration,
-- when something binder-swap-like is happening
-scrutBinderSwap_maybe (Var v) = Just (v, MRefl)
-scrutBinderSwap_maybe (Cast (Var v) co)
- | not (isDictId v) = Just (v, MCo (mkSymCo co))
+scrutOkForBinderSwap (Var v) = DoBinderSwap v MRefl
+scrutOkForBinderSwap (Cast (Var v) co)
+ | not (isDictId v) = DoBinderSwap v (MCo (mkSymCo co))
-- Cast: see Note [Case of cast]
-- isDictId: see Note [Care with binder-swap on dictionaries]
-- The isDictId rejects a Constraint/Constraint binder-swap, perhaps
-- over-conservatively. But I have never seen one, so I'm leaving
-- the code as simple as possible. Losing the binder-swap in a
-- rare case probably has very low impact.
-scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e -- Drop ticks
-scrutBinderSwap_maybe _ = Nothing
+scrutOkForBinderSwap (Tick _ e) = scrutOkForBinderSwap e -- Drop ticks
+scrutOkForBinderSwap _ = NoBinderSwap
lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
-- See Note [The binder-swap substitution]
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1719,7 +1719,7 @@ extendCaseBndrEnv :: LevelEnv
-> LevelEnv
extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
case_bndr (Var scrut_var)
- -- We could use OccurAnal. scrutBinderSwap_maybe here, and perhaps
+ -- We could use OccurAnal. scrutOkForBinderSwap here, and perhaps
-- get a bit more floating. But we didn't in the past and it's
-- an unforced change, so I'm leaving it.
= le { le_subst = extendSubstWithVar subst case_bndr scrut_var
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline
import GHC.Core.Opt.Simplify.Utils
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe )
+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
import GHC.Core.Coercion hiding ( substCo, substCoVar )
@@ -33,7 +33,7 @@ import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
import GHC.Core.DataCon
( DataCon, dataConWorkId, dataConRepStrictness
, dataConRepArgTys, isUnboxedTupleDataCon
- , StrictnessMark (..) )
+ , StrictnessMark (..), dataConWrapId_maybe )
import GHC.Core.Opt.Stats ( Tick(..) )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Core.Unfold
@@ -3234,16 +3234,36 @@ The point is that we bring into the envt a binding
after the outer case, and that makes (a,b) alive. At least we do unless
the case binder is guaranteed dead.
-Note [Case alternative occ info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are simply reconstructing a case (the common case), we always
-zap the occurrence info on the binders in the alternatives. Even
-if the case binder is dead, the scrutinee is usually a variable, and *that*
-can bring the case-alternative binders back to life.
-See Note [Add unfolding for scrutinee]
+Note [DataAlt occ info]
+~~~~~~~~~~~~~~~~~~~~~~~
+Our general goal is to preserve dead-ness occ-info on the field binders of a
+case alternative. Why? It's generally a good idea, but one specific reason is to
+support (SEQ4) of Note [seq# magic].
+
+But we have to be careful: even if the field binder is not mentioned in the case
+alternative and thus annotated IAmDead by OccurAnal, it might "come back to
+life" in one of two ways:
+
+ 1. If the case binder is alive, its unfolding might bring back the field
+ binder, as in Note [knownCon occ info]:
+ case blah of y { I# _ -> $wf (case y of I# v -> v) }
+ ==>
+ case blah of y { I# v -> $wf v }
+ 2. Even if the case binder appears to be dead, there is the scenario in
+ Note [Add unfolding for scrutinee], in which the fields come back to live
+ through the unfolding of variable scrutinee, as follows:
+ join j = case x of Just v -> blah v; Nothing -> ... in
+ case x of Just _ -> jump j; Nothing -> ...
+ ==> { inline j, unfold x to Just v, simplify }
+ join j = case x of Just v -> blah v; Nothing -> ... in
+ case x of Just v -> blah v; Nothing -> ...
+
+Thus, when we are simply reconstructing a case (the common case), and the
+case binder is not dead, or the scrutinee is a variable, we zap the
+occurrence info on DataAlt field binders. See `adjustFieldOccInfo`.
Note [Improving seq]
-~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~
Consider
type family F :: * -> *
type instance F Int = Int
@@ -3349,7 +3369,9 @@ simplAlts env0 scrut case_bndr alts cont'
-- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts
-- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils
- ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
+ ; alts' <- forM in_alts $
+ simplAlt alt_env' (Just scrut') imposs_deflt_cons
+ case_bndr' (scrutOkForBinderSwap scrut) cont'
; let alts_ty' = contResultType cont'
-- See Note [Avoiding space leaks in OutType]
@@ -3375,39 +3397,43 @@ improveSeq _ env scrut _ case_bndr1 _
------------------------------------
simplAlt :: SimplEnv
- -> Maybe OutExpr -- The scrutinee
- -> [AltCon] -- These constructors can't be present when
- -- matching the DEFAULT alternative
- -> OutId -- The case binder
+ -> Maybe OutExpr -- The scrutinee
+ -> [AltCon] -- These constructors can't be present when
+ -- matching the DEFAULT alternative
+ -> OutId -- The case binder `bndr`
+ -> BinderSwapDecision -- DoBinderSwap v co <==> scrut = Just (v |> co),
+ -- add unfolding `v :-> bndr |> sym co`
-> SimplCont
-> InAlt
-> SimplM OutAlt
-simplAlt env scrut' imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)
+simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs)
= assert (null bndrs) $
- do { let env' = addDefaultUnfoldings env scrut' case_bndr' imposs_deflt_cons
+ do { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons
; rhs' <- simplExprC env' rhs cont'
; return (Alt DEFAULT [] rhs') }
-simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)
+simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs)
= assert (null bndrs) $
- do { let env' = addAltUnfoldings env scrut' case_bndr' (Lit lit)
+ do { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit)
; rhs' <- simplExprC env' rhs cont'
; return (Alt (LitAlt lit) [] rhs') }
-simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)
- = do { -- See Note [Adding evaluatedness info to pattern-bound variables]
- let vs_with_evals = addEvals scrut' con vs
- ; (env', vs') <- simplBinders env vs_with_evals
+simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs)
+ = do {
+ ; (env', vs') <- simplBinders env vs
+ -- See Note [Adding evaluatedness info to pattern-bound variables]
+ -- and Note [DataAlt occ info]
+ ; let vs_with_info' = adjustFieldIdInfo scrut' case_bndr' bndr_swap' con vs'
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
con_app :: OutExpr
- con_app = mkConApp2 con inst_tys' vs'
- env'' = addAltUnfoldings env' scrut' case_bndr' con_app
+ con_app = mkConApp2 con inst_tys' vs_with_info'
+ env'' = addAltUnfoldings env' case_bndr' bndr_swap' con_app
; rhs' <- simplExprC env'' rhs cont'
- ; return (Alt (DataAlt con) vs' rhs') }
+ ; return (Alt (DataAlt con) vs_with_info' rhs') }
{- Note [Adding evaluatedness info to pattern-bound variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3438,9 +3464,10 @@ do it here). The right thing is to do some kind of binder-swap;
see #15226 for discussion.
-}
-addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
+adjustFieldIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id]
-- See Note [Adding evaluatedness info to pattern-bound variables]
-addEvals scrut con vs
+-- and Note [DataAlt occ info]
+adjustFieldIdInfo scrut case_bndr bndr_swap con vs
-- Deal with seq# applications
| Just scr <- scrut
, isUnboxedTupleDataCon con
@@ -3449,59 +3476,73 @@ addEvals scrut con vs
-- a list of arguments only to throw it away immediately.
, Just (Var f) <- stripNArgs 4 scr
, f `hasKey` seqHashKey
- , let x' = zapIdOccInfoAndSetEvald MarkedStrict x
- = [s, x']
+ , let x' = setCaseBndrEvald MarkedStrict x
+ = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x']
-- Deal with banged datacon fields
-addEvals _scrut con vs = go vs the_strs
- where
- the_strs = dataConRepStrictness con
-
- go [] [] = []
- go (v:vs') strs | isTyVar v = v : go vs' strs
- go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs
- go _ _ = pprPanic "Simplify.addEvals"
- (ppr con $$
- ppr vs $$
- ppr_with_length (map strdisp the_strs) $$
- ppr_with_length (dataConRepArgTys con) $$
- ppr_with_length (dataConRepStrictness con))
- where
- ppr_with_length list
- = ppr list <+> parens (text "length =" <+> ppr (length list))
- strdisp :: StrictnessMark -> SDoc
- strdisp MarkedStrict = text "MarkedStrict"
- strdisp NotMarkedStrict = text "NotMarkedStrict"
-
-zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id
-zapIdOccInfoAndSetEvald str v =
- setCaseBndrEvald str $ -- Add eval'dness info
- zapIdOccInfo v -- And kill occ info;
- -- see Note [Case alternative occ info]
-
-addDefaultUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> [AltCon] -> SimplEnv
-addDefaultUnfoldings env mb_scrut case_bndr imposs_deflt_cons
+ -- This case is quite allocation sensitive to T9233 which has a large record
+ -- with strict fields. Hence we try not to update vs twice!
+adjustFieldIdInfo _scrut case_bndr bndr_swap con vs
+ | Nothing <- dataConWrapId_maybe con
+ -- a common fast path; no need to allocate the_strs when they are all lazy anyway!
+ = map (adjustFieldOccInfo case_bndr bndr_swap) vs
+ | otherwise
+ = go vs the_strs
+ where
+ the_strs = dataConRepStrictness con
+
+ go [] [] = []
+ go (v:vs') strs | isTyVar v = v : go vs' strs
+ go (v:vs') (str:strs) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs
+ go _ _ = pprPanic "Simplify.adjustFieldIdInfo"
+ (ppr con $$
+ ppr vs $$
+ ppr_with_length (map strdisp the_strs) $$
+ ppr_with_length (dataConRepArgTys con) $$
+ ppr_with_length (dataConRepStrictness con))
+ where
+ ppr_with_length list
+ = ppr list <+> parens (text "length =" <+> ppr (length list))
+ strdisp :: StrictnessMark -> SDoc
+ strdisp MarkedStrict = text "MarkedStrict"
+ strdisp NotMarkedStrict = text "NotMarkedStrict"
+
+adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr
+-- Kill occ info if we do binder swap and the case binder is alive;
+-- see Note [DataAlt occ info]
+adjustFieldOccInfo case_bndr bndr_swap field_bndr
+ | not (isDeadBinder case_bndr) -- (1) in the Note: If the case binder is alive,
+ = zapped_field_bndr -- the field binders might come back alive
+
+ | DoBinderSwap{} <- bndr_swap -- (2) in the Note: If binder swap might take place,
+ = zapped_field_bndr -- the case binder might come back alive
+
+ | otherwise
+ = field_bndr -- otherwise the field binders stay dead
+ where
+ zapped_field_bndr = if isTyVar field_bndr then field_bndr else zapIdOccInfo field_bndr
+
+addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv
+addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons
= env2
where
unf = mkOtherCon imposs_deflt_cons
-- Record the constructors that the case-binder *can't* be.
env1 = addBinderUnfolding env case_bndr unf
- env2 | Just scrut <- mb_scrut
- , Just (v,_mco) <- scrutBinderSwap_maybe scrut
+ env2 | DoBinderSwap v _mco <- bndr_swap
= addBinderUnfolding env1 v unf
| otherwise = env1
-addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplEnv
-addAltUnfoldings env mb_scrut case_bndr con_app
+addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv
+addAltUnfoldings env case_bndr bndr_swap con_app
= env2
where
con_app_unf = mk_simple_unf con_app
env1 = addBinderUnfolding env case_bndr con_app_unf
-- See Note [Add unfolding for scrutinee]
- env2 | Just scrut <- mb_scrut
- , Just (v,mco) <- scrutBinderSwap_maybe scrut
+ env2 | DoBinderSwap v mco <- bndr_swap
= addBinderUnfolding env1 v $
if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf
then con_app_unf -- twice in the common case
@@ -3580,7 +3621,7 @@ So instead we add the unfolding x -> Just a, and x -> Nothing in the
respective RHSs.
Since this transformation is tantamount to a binder swap, we use
-GHC.Core.Opt.OccurAnal.scrutBinderSwap_maybe to do the check.
+GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check.
Exactly the same issue arises in GHC.Core.Opt.SpecConstr;
see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr
@@ -3884,8 +3925,9 @@ mkDupableContWithDmds env _
; let cont_scaling = contHoleScaling cont
-- See Note [Scaling in case-of-case]
; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)
- ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)
- -- Safe to say that there are no handled-cons for the DEFAULT case
+ ; alts' <- forM (scaleAltsBy cont_scaling alts) $
+ simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont
+ -- Safe to say that there are no handled-cons for the DEFAULT case
-- NB: simplBinder does not zap deadness occ-info, so
-- a dead case_bndr' will still advertise its deadness
-- This is really important because in
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Core.Opt.Simplify.Inline
import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )
+import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )
import GHC.Core.DataCon
import GHC.Core.Class( classTyVars )
import GHC.Core.Coercion hiding( substCo )
@@ -1104,7 +1104,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
= (env2, alt_bndrs')
where
live_case_bndr = not (isDeadBinder case_bndr)
- env1 | Just (v, mco) <- scrutBinderSwap_maybe scrut
+ env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut
, isReflMCo mco = extendValEnv env v cval
| otherwise = env -- See Note [Add scrutinee to ValueEnv too]
env2 | live_case_bndr = extendValEnv env1 case_bndr cval
@@ -1198,7 +1198,7 @@ though the simplifier has systematically replaced uses of 'x' with 'y'
and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came
from outside the case. See #4908 for the live example.
-It's very like the binder-swap story, so we use scrutBinderSwap_maybe
+It's very like the binder-swap story, so we use scrutOkForBinderSwap
to identify suitable scrutinees -- but only if there is no cast
(isReflMCo) because that's all that the ValueEnv allows.
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -890,6 +890,29 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _])
floats = snocFloat floats_scrut case_float `appFloats` floats_rhs
; return (floats, rhs) }
+cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs])
+ -- See item (SEQ4) of Note [seq# magic]. We want to match
+ -- case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s']
+ -- and simplify to rhs[s]. Triggers in T15226.
+ | isUnboxedTupleDataCon dc
+ , (Var f,[_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut
+ , f `hasKey` seqHashKey
+ , exprOkToDiscard arg
+ -- ok-to-discard, because we want to discard the evaluation of `arg`.
+ -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as
+ -- `quotInt# 1# 0#`, but not ThrowsException primops.
+ -- See Note [Classifying primop effects]
+ -- and Note [Transformations affected by primop effects] for why this is
+ -- the correct choice.
+ , Var token_in' <- lookupCorePrepEnv env token_in
+ , isDeadBinder res, isDeadBinder bndr
+ -- Check that bndr and res are dead
+ -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier
+ -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info]
+ -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a
+ -- variable, and in that case the zapping doesn't happen; see that Note.
+ = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs
+
cpeRhsE env (Case scrut bndr ty alts)
= do { (floats, scrut') <- cpeBody env scrut
; (env', bndr2) <- cpCloneBndr env bndr
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -2295,9 +2295,16 @@ Things to note
also we can attach an evaldUnfolding to x' to discard any
subsequent evals such as the `case x' of __DEFAULT`.
+(SEQ4)
+ T15226 demonstrates that we want to discard ok-for-discard seq#s. That is,
+ simplify `case seq# <ok-to-discard> s of (# s', _ #) -> rhs[s']` to `rhs[s]`.
+ You might wonder whether the Simplifier could do this. But see the excellent
+ example in #24334 (immortalised as test T24334) for why it should be done in
+ CorePrep.
+
Implementing seq#. The compiler has magic for `seq#` in
-- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+- GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4).
- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see
Note [Adding evaluatedness info to pattern-bound variables]
=====================================
testsuite/tests/codeGen/should_compile/T24264.hs
=====================================
@@ -24,12 +24,8 @@ fun3 :: a -> IO a
{-# OPAQUE fun3 #-}
fun3 x = do
pure ()
- -- "evaluate $! x"
- case x of !x' -> IO (noinline seq# x')
- -- noinline to work around the bogus seqRule
- -- This ideally also should not push a continuation to the stack
- -- before entering 'x'. It currently does, but let's wait for
- -- !11515 to land before worrying about that.
+ evaluate $! x
+ -- This should not push a continuation to the stack before entering 'x'
funPair :: a -> IO (a, a)
{-# OPAQUE funPair #-}
=====================================
testsuite/tests/core-to-stg/T24334.hs
=====================================
@@ -0,0 +1,20 @@
+import Control.Exception
+import Data.IORef
+
+strictPrint :: Show a => a -> IO ()
+{-# OPAQUE strictPrint #-}
+strictPrint x = print $! x
+
+f :: Show a => a -> IORef a -> IO ()
+{-# OPAQUE f #-}
+f x r = do
+ x' <- evaluate $! x
+ writeIORef r x'
+ strictPrint x'
+
+main :: IO ()
+main = do
+ r <- newIORef (42 :: Int)
+ f (error "foo") r `catch` \(e :: SomeException) -> return ()
+ n <- readIORef r
+ print n
=====================================
testsuite/tests/core-to-stg/T24334.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -5,4 +5,5 @@ test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -dd
test('T23914', normal, compile, ['-O'])
test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques'])
test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques'])
+test('T24334', normal, compile_and_run, ['-O'])
test('T24463', normal, compile, ['-O'])
=====================================
testsuite/tests/simplCore/should_compile/T21851.stderr
=====================================
@@ -10,8 +10,12 @@ g' :: Int -> Int
[GblId,
Arity=1,
Str=<L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 30 0}]
g'
- = \ (x :: Int) -> case T21851a.$w$sf x of { (# ww, ww1 #) -> ww }
+ = \ (x :: Int) ->
+ case T21851a.$w$sf x of { (# ww, _ [Occ=Dead] #) -> ww }
+
+
=====================================
testsuite/tests/simplCore/should_compile/T24770.hs
=====================================
@@ -0,0 +1,3 @@
+module T24770 where
+
+foo = getLine >> getLine
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -516,3 +516,4 @@ test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
test('T24768', normal, compile, ['-O'])
+test('T24770', [ grep_errmsg(r'Dead') ], compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14656b5948b1a423c177c14a0e4320d74b19170d...350ea87e742c351a63672adf421acc57cf8e0b88
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14656b5948b1a423c177c14a0e4320d74b19170d...350ea87e742c351a63672adf421acc57cf8e0b88
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240507/0560176e/attachment-0001.html>
More information about the ghc-commits
mailing list