X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCSE.lhs;h=1386197ebaabc1c1e25290ccf1d3e34ad11eb1e2;hp=495ea42fc457242d6a19db995602b68fc79322f7;hb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;hpb=bb924bddcd3988d50b4cf2afbd8895e886a23520

diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 495ea42..1386197 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -11,7 +11,7 @@ module CSE (
 #include "HsVersions.h"
 
 import DynFlags	( DynFlag(..), DynFlags )
-import Id		( Id, idType, idInlinePragma )
+import Id		( Id, idType, idInlinePragma, zapIdOccInfo )
 import CoreUtils	( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
 import DataCon		( isUnboxedTupleCon )
 import Type		( tyConAppArgs )
@@ -69,7 +69,7 @@ to run the substitution over types and IdInfo.  No no no.  Instead, we just thro
 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
 
 
-[Note: case binders 1]
+Note [Case binders 1]
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
@@ -83,9 +83,9 @@ but for CSE purpose that's a bad idea.
 
 So we add the binding (wild1 -> a) to the extra var->var mapping.
 Notice this is exactly backwards to what the simplifier does, which is
-to try to replaces uses of a with uses of wild1
+to try to replaces uses of 'a' with uses of 'wild1'
 
-[Note: case binders 2]
+Note [Case binders 2]
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
 	case (h x) of y -> ...(h x)...
@@ -98,7 +98,7 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression.
 	case binder -> scrutinee 
 to the substitution
 
-[Note: unboxed tuple case binders]
+Note [Unboxed tuple case binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
 	case f x of t { (# a,b #) -> 
@@ -233,34 +233,40 @@ cseExpr env (Lam b e)	     	   = let (env', b') = addBinder env b
 				     in Lam b' (cseExpr env' e)
 cseExpr env (Let bind e)    	   = let (env', bind') = cseBind env bind
 				     in Let bind' (cseExpr env' e)
-cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
+cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts)
 				   where
 				     scrut' = tryForCSE env scrut
 				     (env', bndr') = addBinder env bndr
-
+				     bndr'' = zapIdOccInfo bndr'
+					-- The swizzling from Note [Case binders 2] may
+					-- cause a dead case binder to be alive, so we
+					-- play safe here and bring them all to life
 
 cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt]
 
 cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]
   | isUnboxedTupleCon con
 	-- Unboxed tuples are special because the case binder isn't
-	-- a real values.  See [Note: unboxed tuple case binders]
-  = [(DataAlt con, args', tryForCSE new_env rhs)]
+	-- a real values.  See Note [Unboxed tuple case binders]
+  = [(DataAlt con, args'', tryForCSE new_env rhs)]
   where
     (env', args') = addBinders env args
+    args'' = map zapIdOccInfo args'	-- They should all be ids
+	-- Same motivation for zapping as [Case binders 2] only this time
+	-- it's Note [Unboxed tuple case binders]
     new_env | exprIsCheap scrut' = env'
 	    | otherwise 	 = extendCSEnv env' scrut' tup_value
-    tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr))
+    tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))
 
 cseAlts env scrut' bndr bndr' alts
   = map cse_alt alts
   where
     (con_target, alt_env)
 	= case scrut' of
-		Var v' -> (v',    extendSubst env bndr v')	-- See [Note: case binder 1]
+		Var v' -> (v',     extendSubst env bndr v')	-- See Note [Case binders 1]
 								-- map: bndr -> v'
 
-		_      ->  (bndr', extendCSEnv env scrut' (Var  bndr'))	-- See [Note: case binder 2]
+		_      ->  (bndr', extendCSEnv env scrut' (Var  bndr'))	-- See Note [Case binders 2]
 									-- map: scrut' -> bndr'
 
     arg_tys = tyConAppArgs (idType bndr)