[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
Mon May 6 13:39:51 UTC 2024
Sebastian Graf pushed to branch wip/T24334 at Glasgow Haskell Compiler / GHC
Commits:
16d2ca25 by Sebastian Graf at 2024-05-06T15:39:38+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.
- - - - -
769878d5 by Sebastian Graf at 2024-05-06T15:39:38+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.
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.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/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 )
@@ -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 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/Simplify/Iteration.hs
=====================================
@@ -3234,13 +3234,12 @@ 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]
+~~~~~~~~~~~~~~~~~~~~~~~
+It is in general possible that a DataAlt field binder comes back to life
+through the case binder, as in Note [Add unfolding for scrutinee].
+Thus, when we are simply reconstructing a case (the common case), and the
+case binder is not dead, we zap the occurrence info on DataAlt field binders.
Note [Improving seq]
~~~~~~~~~~~~~~~~~~~
@@ -3397,7 +3396,8 @@ simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs 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
+ let vs_with_evals = zapIdOccInfoIfCaseBndrAlive case_bndr' $
+ addEvals scrut' con vs
; (env', vs') <- simplBinders env vs_with_evals
-- Bind the case-binder to (con args)
@@ -3449,7 +3449,7 @@ 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
+ , let x' = setCaseBndrEvald MarkedStrict x
= [s, x']
-- Deal with banged datacon fields
@@ -3459,7 +3459,7 @@ addEvals _scrut con vs = go vs the_strs
go [] [] = []
go (v:vs') strs | isTyVar v = v : go vs' strs
- go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs
+ go (v:vs') (str:strs) = setCaseBndrEvald str v : go vs' strs
go _ _ = pprPanic "Simplify.addEvals"
(ppr con $$
ppr vs $$
@@ -3473,11 +3473,12 @@ addEvals _scrut con vs = go vs the_strs
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]
+zapIdOccInfoIfCaseBndrAlive :: OutId -> [CoreBndr] -> [CoreBndr]
+-- Kill occ info if case binder is alive;
+-- see Note [DataAlt occ info]
+zapIdOccInfoIfCaseBndrAlive case_bndr field_bndrs
+ | isDeadBinder case_bndr = field_bndrs
+ | otherwise = [ if isTyVar v then v else zapIdOccInfo v | v <- field_bndrs ]
addDefaultUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> [AltCon] -> SimplEnv
addDefaultUnfoldings env mb_scrut case_bndr imposs_deflt_cons
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -890,6 +890,18 @@ 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, value, Var token_in]) <- collectArgs scrut
+ , f `hasKey` seqHashKey
+ , exprOkToDiscard value
+ , Var token_in' <- lookupCorePrepEnv env token_in
+ , isDeadBinder res, isDeadBinder bndr -- check that bndr and res are dead
+ = 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/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/3aca1d9eb7c157be7c3910067ce812a9fce4bf61...769878d597cb3ce789335efc350140a32859594e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3aca1d9eb7c157be7c3910067ce812a9fce4bf61...769878d597cb3ce789335efc350140a32859594e
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/20240506/21701b3f/attachment-0001.html>
More information about the ghc-commits
mailing list