From c55001c567b4f6e17f7a0c174c003318aac6a8ed Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 16 Aug 2006 16:42:16 +0000
Subject: [PATCH] Get dead-ness right in knownCon

---
 compiler/simplCore/Simplify.lhs |   34 +++++++++++++++++++++-------------
 1 file changed, 21 insertions(+), 13 deletions(-)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 56f44e8..b30ed04 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1414,17 +1414,18 @@ simplCaseBinder env (Var v) case_bndr
 -- Failed try [see Note 2 above]
 --     not (isEvaldUnfolding (idUnfolding v))
 
-  = simplBinder env (zap case_bndr)		`thenSmpl` \ (env, case_bndr') ->
+  = simplBinder env (zapOccInfo case_bndr)		`thenSmpl` \ (env, case_bndr') ->
     returnSmpl (modifyInScope env v case_bndr', case_bndr')
 	-- We could extend the substitution instead, but it would be
 	-- a hack because then the substitution wouldn't be idempotent
 	-- any more (v is an OutId).  And this does just as well.
-  where
-    zap b = b `setIdOccInfo` NoOccInfo
 	    
 simplCaseBinder env other_scrut case_bndr 
   = simplBinder env case_bndr 		`thenSmpl` \ (env, case_bndr') ->
     returnSmpl (env, case_bndr')
+
+zapOccInfo :: InId -> InId
+zapOccInfo b = b `setIdOccInfo` NoOccInfo
 \end{code}
 
 
@@ -1694,8 +1695,9 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
 	-- If the case binder is alive, then we add the unfolding
 	--	case_bndr = C vs
 	-- to the envt; so vs are now very much alive
+	-- Note [Aug06] I can't see why this actually matters
     zap_occ_info | isDeadBinder case_bndr' = \id -> id
-		 | otherwise		   = \id -> id `setIdOccInfo` NoOccInfo
+		 | otherwise		   = zapOccInfo
 
 mk_rhs_env env case_bndr' case_bndr_unf
   = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
@@ -1742,7 +1744,7 @@ knownCon env scrut con args bndr alts cont
 
 	(DataAlt dc, bs, rhs)  
 		-> ASSERT( n_drop_tys + length bs == length args )
-		   bind_args env bs (drop n_drop_tys args)	$ \ env ->
+		   bind_args env dead_bndr bs (drop n_drop_tys args)	$ \ env ->
 		   let
 			-- It's useful to bind bndr to scrut, rather than to a fresh
 			-- binding 	x = Con arg1 .. argn
@@ -1761,23 +1763,29 @@ knownCon env scrut con args bndr alts cont
 		   simplNonRecX env bndr bndr_rhs		$ \ env ->
 		   simplExprF env rhs cont
 	        where
+		   dead_bndr = isDeadBinder bndr
 		   n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc)
 			      | otherwise	    = 0
 			-- Vanilla data constructors lack type arguments in the pattern
 
 -- Ugh!
-bind_args env [] _ thing_inside = thing_inside env
+bind_args env dead_bndr [] _ thing_inside = thing_inside env
 
-bind_args env (b:bs) (Type ty : args) thing_inside
+bind_args env dead_bndr (b:bs) (Type ty : args) thing_inside
   = ASSERT( isTyVar b )
-    bind_args (extendTvSubst env b ty) bs args thing_inside
+    bind_args (extendTvSubst env b ty) dead_bndr bs args thing_inside
     
-bind_args env (b:bs) (arg : args) thing_inside
--- Note that the binder might be "dead", because it doesn't occur in the RHS
--- Nevertheless we bind it here, in case we need it for the con_app for the case_bndr
+bind_args env dead_bndr (b:bs) (arg : args) thing_inside
   = ASSERT( isId b )
-    simplNonRecX env b arg	$ \ env ->
-    bind_args env bs args thing_inside
+    let
+	b' = if dead_bndr then b else zapOccInfo b
+		-- Note that the binder might be "dead", because it doesn't occur 
+		-- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
+		-- Nevertheless we must keep it if the case-binder is alive, because it may
+		-- be used in teh con_app
+    in
+    simplNonRecX env b' arg	$ \ env ->
+    bind_args env dead_bndr bs args thing_inside
 \end{code}
 
 
-- 
1.7.10.4