diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 21e8a5eabd5a757660d0bdd66c20ff230072e296..b295a70b0a67341e0bd417f944f4dfc8822434b8 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/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 #-}
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 7add9fd9bfb4d08276f767e44a99c6250ba3ee77..564c199316c41cc35e0a8039df61e3bec08b30c0 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/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
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 35c774f8f49982347ac25dfaba1920c7780d1630..36ecd0ab9a3902f8dd5efa2e156e31d9e05995a0 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/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]
diff --git a/testsuite/tests/codeGen/should_compile/T24264.hs b/testsuite/tests/codeGen/should_compile/T24264.hs
index a52ca4dc747b854c5ed86685432676e5ea2037bb..9c790e1477c2f8e80af0a8d75cc1f9c17971abcd 100644
--- a/testsuite/tests/codeGen/should_compile/T24264.hs
+++ b/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 #-}
diff --git a/testsuite/tests/core-to-stg/T24334.hs b/testsuite/tests/core-to-stg/T24334.hs
new file mode 100644
index 0000000000000000000000000000000000000000..59256874c17dca129155a4ca1cab8dffbc75aa31
--- /dev/null
+++ b/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
diff --git a/testsuite/tests/core-to-stg/T24334.stdout b/testsuite/tests/core-to-stg/T24334.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..d81cc0710eb6cf9efd5b920a8453e1e07157b6cd
--- /dev/null
+++ b/testsuite/tests/core-to-stg/T24334.stdout
@@ -0,0 +1 @@
+42
diff --git a/testsuite/tests/core-to-stg/all.T b/testsuite/tests/core-to-stg/all.T
index 51465e5e9805da1e4fda3057b8acb6d0a5d9e636..858c70afb02b032220ea5adf646cfe0410ed0f05 100644
--- a/testsuite/tests/core-to-stg/all.T
+++ b/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'])