[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