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

+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

+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

+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'])