[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 12:01:36 UTC 2024
Sebastian Graf pushed to branch wip/T24334 at Glasgow Haskell Compiler / GHC
Commits:
ffa35d44 by Sebastian Graf at 2024-05-06T13:58:20+02:00
Simplifier: Preserve OccInfo on DataAlt fields when case binder is dead (#24770)
See the adjusted `Note [DataAlt occ info]`.
Fixes #24770.
- - - - -
a6ecbc65 by Sebastian Graf at 2024-05-06T14:01:25+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.
- - - - -
10 changed files:
- 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/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 -> [Id] -> [Id]
+-- Kill occ info if case binder is alive;
+-- see Note [DataAlt occ info]
+zapIdOccInfoIfCaseBndrAlive case_bndr field_bndrs
+ | isDeadBinder case_bndr = field_bndrs
+ | otherwise = map zapIdOccInfo 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
=====================================
@@ -514,3 +514,4 @@ test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
+test('T24770', [ grep_errmsg(r'Dead') ], compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5549b0f474598b784bc6c41c55f3e0fa537ab4f4...a6ecbc656b1a908240dda63aefdd696ae0c88745
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5549b0f474598b784bc6c41c55f3e0fa537ab4f4...a6ecbc656b1a908240dda63aefdd696ae0c88745
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/de9d058d/attachment-0001.html>
More information about the ghc-commits
mailing list