diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index eb52d6f8d215e469b30ebaaf2ba1e29a4e37fa24..9f5f196e2808c719aef8f4fffdf86ab7e5f1f3ab 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -71,6 +71,11 @@ and nothing stops us from transforming that to
, Right [x] -> b}
+Note that this can revive dead case binders (e.g. "b" above), hence we zap
+occurrence information on all case binders during STG CSE.
+See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr.
+
+
Note [StgCse after unarisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -344,16 +349,20 @@ stgCseExpr env (StgTick tick body)
= let body' = stgCseExpr env body
in StgTick tick body'
stgCseExpr env (StgCase scrut bndr ty alts)
- = mkStgCase scrut' bndr' ty alts'
+ = mkStgCase scrut' bndr'' ty alts'
where
scrut' = stgCseExpr env scrut
(env1, bndr') = substBndr env bndr
+ -- we must zap occurrence information on the case binder
+ -- because CSE might revive it.
+ -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr
+ bndr'' = zapIdOccInfo bndr'
env2 | StgApp trivial_scrut [] <- scrut'
= addTrivCaseBndr bndr trivial_scrut env1
-- See Note [Trivial case scrutinee]
| otherwise
= env1
- alts' = map (stgCseAlt env2 ty bndr') alts
+ alts' = map (stgCseAlt env2 ty bndr'') alts
-- A constructor application.
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index e86e5a76ae0a04d34ba0cc5de28b141ec471f109..4887857296eee1f1b685c3517df300d0444410fd 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -446,21 +446,49 @@ calls to nonVoidIds in various places. So we must not look up
Note [Dead-binder optimisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A case-binder, or data-constructor argument, may be marked as dead,
-because we preserve occurrence-info on binders in GHC.Core.Tidy (see
+Consider:
+
+ case x of (y, z<dead>) -> rhs
+
+where `z` is unused in `rhs`. When we return form the eval of `x`,
+GHC.StgToCmm.DataCon.bindConArgs will generate some loads, assuming the the
+value of `x` is returned in R1:
+ y := R1[1]
+ z := R1[2]
+
+If `z` is never used, the load `z := R1[2]` is a waste of a memory operation.
+CmmSink (which sinks loads to their usage sites, if any) will eliminate the dead
+load; but
+ 1. CmmSink only runs with -O
+ 2. It would save CmmSink work if we simply did not generate the load in the
+ first place.
+
+Hence STG uses dead-binder information, in `bindConArgs` to drop dead loads.
+That's why we preserve occurrence-info on binders in GHC.Core.Tidy (see
GHC.Core.Tidy.tidyIdBndr).
-If the binder is dead, we can sometimes eliminate a load. While
-CmmSink will eliminate that load, it's very easy to kill it at source
-(giving CmmSink less work to do), and in any case CmmSink only runs
-with -O. Since the majority of case binders are dead, this
-optimisation probably still has a great benefit-cost ratio and we want
-to keep it for -O0. See also Phab:D5358.
-
-This probably also was the reason for occurrence hack in Phab:D5339 to
-exist, perhaps because the occurrence information preserved by
-'GHC.Core.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the
-job we deleted the hacks.
+So it's important that deadness is accurate. But StgCse can invalidate it
+(#14895 #24233). Here is an example:
+
+ map_either :: (a -> b) -> Either String a -> Either String b
+ map_either = \f e -> case e of b<dead> {
+ Right x -> Right (f x)
+ Left x -> Left x
+ }
+
+ The case-binder "b" is dead (not used in the rhss of the alternatives).
+ StgCse notices that `Left x` doesn't need to be allocated as we can reuse `b`,
+ and we get:
+
+ map_either :: (a -> b) -> Either String a -> Either String b
+ map_either = \f e -> case e of b { -- b no longer dead!
+ Right x -> Right (f x)
+ Left x -> b
+ }
+
+For now StgCse simply zaps occurrence information on case binders. A more
+accurate update would complexify the implementation and doesn't seem worth it.
+
-}
cgCase (StgApp v []) _ (PrimAlt _) alts
diff --git a/testsuite/tests/core-to-stg/T14895.hs b/testsuite/tests/core-to-stg/T14895.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ef1458ecbbeeade69ef0159de9ef67350c4a85cc
--- /dev/null
+++ b/testsuite/tests/core-to-stg/T14895.hs
@@ -0,0 +1,5 @@
+module T14895 where
+
+go :: (a -> b) -> Either String a -> Either String b
+go f (Right a) = Right (f a)
+go _ (Left e) = Left e
diff --git a/testsuite/tests/core-to-stg/T14895.stderr b/testsuite/tests/core-to-stg/T14895.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..bf951646e5fc0585081855068657b9e662821b1e
--- /dev/null
+++ b/testsuite/tests/core-to-stg/T14895.stderr
@@ -0,0 +1,20 @@
+
+==================== Final STG: ====================
+T14895.go
+ :: forall a b.
+ (a -> b)
+ -> Data.Either.Either GHC.Base.String a
+ -> Data.Either.Either GHC.Base.String b
+[GblId, Arity=2, Str=<MC(1,L)><1L>, Unf=OtherCon []] =
+ {} \r [f ds]
+ case ds of wild {
+ Data.Either.Left e [Occ=Once1] -> wild<TagProper>;
+ Data.Either.Right a1 [Occ=Once1] ->
+ let {
+ sat [Occ=Once1] :: b
+ [LclId] =
+ {a1, f} \u [] f a1;
+ } in Data.Either.Right [sat];
+ };
+
+
diff --git a/testsuite/tests/core-to-stg/all.T b/testsuite/tests/core-to-stg/all.T
index e353cb8f7d7c33b7ac20d12996a072c3ba027727..ed2231bfbb9cfec7f6803815c8caf6dbdd169fcd 100644
--- a/testsuite/tests/core-to-stg/all.T
+++ b/testsuite/tests/core-to-stg/all.T
@@ -3,3 +3,4 @@
test('T19700', normal, compile, ['-O'])
test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep'])
test('T23914', normal, compile, ['-O'])
+test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques'])
diff --git a/testsuite/tests/simplCore/should_compile/T22309.stderr b/testsuite/tests/simplCore/should_compile/T22309.stderr
index ac0c768688aca60abfed35bdb8fe852ecb709992..65185b546d62bf91605d9a3a613cbccd10686104 100644
--- a/testsuite/tests/simplCore/should_compile/T22309.stderr
+++ b/testsuite/tests/simplCore/should_compile/T22309.stderr
@@ -9,45 +9,46 @@ $WMkW_NA :: NU_A %1 -> WNU_A =
case conrep of conrep1 { __DEFAULT -> MkW_NA [conrep1]; };
$WMkW_F :: UF %1 -> WU_F =
- \r [conrep] case conrep of { Mk_F us -> MkW_F [us]; };
+ \r [conrep] case conrep of conrep1 { Mk_F us -> MkW_F [us]; };
$WMkW_E :: UE %1 -> WU_E =
- \r [conrep] case conrep of { Mk_E us -> MkW_E [us]; };
+ \r [conrep] case conrep of conrep1 { Mk_E us -> MkW_E [us]; };
$WMkW_D :: UD %1 -> WU_D =
\r [conrep]
- case conrep of { Mk_D unbx unbx1 -> MkW_D [unbx unbx1]; };
+ case conrep of conrep1 { Mk_D unbx unbx1 -> MkW_D [unbx unbx1]; };
$WMkW_C :: UC %1 -> WU_C =
- \r [conrep] case conrep of { Mk_C unbx -> MkW_C [unbx]; };
+ \r [conrep] case conrep of conrep1 { Mk_C unbx -> MkW_C [unbx]; };
$WMkW_B :: UB %1 -> WU_B =
- \r [conrep] case conrep of { Mk_B unbx -> MkW_B [unbx]; };
+ \r [conrep] case conrep of conrep1 { Mk_B unbx -> MkW_B [unbx]; };
$WMkW_A :: UA %1 -> WU_A =
- \r [conrep] case conrep of { Mk_A unbx -> MkW_A [unbx]; };
+ \r [conrep] case conrep of conrep1 { Mk_A unbx -> MkW_A [unbx]; };
$WNU_MkB :: Int64 %1 -> Int64 %1 -> NU_B =
\r [conrep conrep1]
- case conrep of {
+ case conrep of conrep2 {
I64# unbx ->
- case conrep1 of { I64# unbx1 -> NU_MkB [unbx unbx1]; };
+ case conrep1 of conrep3 { I64# unbx1 -> NU_MkB [unbx unbx1]; };
};
$WMk_D :: Int32 %1 -> Int32 %1 -> UD =
\r [conrep conrep1]
- case conrep of {
- I32# unbx -> case conrep1 of { I32# unbx1 -> Mk_D [unbx unbx1]; };
+ case conrep of conrep2 {
+ I32# unbx ->
+ case conrep1 of conrep3 { I32# unbx1 -> Mk_D [unbx unbx1]; };
};
$WMk_C :: Int32 %1 -> UC =
- \r [conrep] case conrep of { I32# unbx -> Mk_C [unbx]; };
+ \r [conrep] case conrep of conrep1 { I32# unbx -> Mk_C [unbx]; };
$WMk_B :: Int64 %1 -> UB =
- \r [conrep] case conrep of { I64# unbx -> Mk_B [unbx]; };
+ \r [conrep] case conrep of conrep1 { I64# unbx -> Mk_B [unbx]; };
$WMk_A :: Int %1 -> UA =
- \r [conrep] case conrep of { I# unbx -> Mk_A [unbx]; };
+ \r [conrep] case conrep of conrep1 { I# unbx -> Mk_A [unbx]; };
MkW_NB :: NU_B %1 -> WNU_B =
\r [eta] case eta of eta { __DEFAULT -> MkW_NB [eta]; };
@@ -71,7 +72,8 @@ MkW_A :: Int# %1 -> WU_A = \r [eta] MkW_A [eta];
NU_MkB :: Int64# %1 -> Int64# %1 -> NU_B =
\r [eta eta] NU_MkB [eta eta];
-NU_MkA :: (# Int, Int #) %1 -> NU_A = \r [us us] NU_MkA [us us];
+NU_MkA :: (# Int64, Int64 #) %1 -> NU_A =
+ \r [us us] NU_MkA [us us];
Mk_F :: (# Double #) %1 -> UF = \r [us] Mk_F [us];
diff --git a/testsuite/tests/simplStg/should_compile/T15226b.stderr b/testsuite/tests/simplStg/should_compile/T15226b.stderr
index ed92963c0eff248fb33ce9fc3a7a938620273e2c..416b9321be2af4aa8e7ebe9c8f7d682d753efeaf 100644
--- a/testsuite/tests/simplStg/should_compile/T15226b.stderr
+++ b/testsuite/tests/simplStg/should_compile/T15226b.stderr
@@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
:: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b
[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []] =
{} \r [conrep conrep1]
- case conrep of conrep2 [Occ=Once1] {
+ case conrep of conrep2 {
__DEFAULT ->
- case conrep1 of conrep3 [Occ=Once1] {
+ case conrep1 of conrep3 {
__DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3];
};
};
@@ -19,13 +19,13 @@ T15226b.testFun1
-> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #)
[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
{} \r [x y void]
- case seq# [x GHC.Prim.void#] of {
+ case seq# [x GHC.Prim.void#] of ds1 {
Solo# ipv1 [Occ=Once1] ->
let {
sat [Occ=Once1] :: T15226b.StrictPair a b
[LclId] =
{ipv1, y} \u []
- case y of conrep [Occ=Once1] {
+ case y of conrep {
__DEFAULT -> T15226b.MkStrictPair [ipv1 conrep];
};
} in seq# [sat GHC.Prim.void#];