Zap dead-ness info appropriately in SpecConstr

SpecConstr can make pattern binders come alive, so we must remember
to zap their dead-variable annotation.  See extendCaseBndrs.

(This was triggering a Core Lint failure in DPH.)

1 files changed, 24 insertions, 14 deletions

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index bdd9a16a71..0280255510 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -27,8 +27,7 @@ import DataCon		( dataConRepArity, dataConUnivTyVars )
 import Coercion	
 import Rules
 import Type		hiding( substTy )
-import Id		( Id, idName, idType, isDataConWorkId_maybe, idArity,
-			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
+import Id
 import Var
 import VarEnv
 import VarSet
@@ -591,17 +590,28 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 extendValEnv env _  Nothing   = env
 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 
-extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
+extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
 -- When we encounter
 --	case scrut of b
 --	    C x y -> ...
--- we want to bind b, and perhaps scrut too, to (C x y)
--- NB: Extends only the sc_vals part of the envt
-extendCaseBndrs env scrut case_bndr con alt_bndrs
-  = case scrut of
-	Var v  -> extendValEnv env1 v cval
-	_other -> env1
+-- we want to bind b, to (C x y)
+-- NB1: Extends only the sc_vals part of the envt
+-- NB2: Kill the dead-ness info on the pattern binders x,y, since
+--      they are potentially made alive by the [b -> C x y] binding
+extendCaseBndrs env case_bndr con alt_bndrs
+  | isDeadBinder case_bndr
+  = (env, alt_bndrs)
+  | otherwise
+  = (env1, map zap alt_bndrs)
+	-- NB: We used to bind v too, if scrut = (Var v); but
+        --     the simplifer has already done this so it seems
+        --     redundant to do so here
+ 	-- case scrut of
+  	--	Var v  -> extendValEnv env1 v cval
+	--	_other -> env1
  where
+   zap v | isTyVar v = v		-- See NB2 above
+         | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
 		DEFAULT    -> Nothing
@@ -788,15 +798,15 @@ scExpr' env (Case scrut b ty alts)
 	  ; return (alt_usg `combineUsage` scrut_usg',
 	  	    Case scrut' b' (scSubstTy env ty) alts') }
 
-    sc_alt env scrut' b' (con,bs,rhs)
-      = do { let (env1, bs') = extendBndrsWith RecArg env bs
-		 env2        = extendCaseBndrs env1 scrut' b' con bs'
+    sc_alt env _scrut' b' (con,bs,rhs)
+      = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
+		 (env2, bs2) = extendCaseBndrs env1 b' con bs1
 	   ; (usg,rhs') <- scExpr env2 rhs
-	   ; let (usg', arg_occs) = lookupOccs usg bs'
+	   ; let (usg', arg_occs) = lookupOccs usg bs2
 		 scrut_occ = case con of
 				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
 				_      	   -> ScrutOcc emptyUFM
-	   ; return (usg', scrut_occ, (con,bs',rhs')) }
+	   ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
   | isTyVar bndr	-- Type-lets may be created by doBeta