X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=693644f258096743b55c8022ad9da8508c4f0fae;hb=eba4dfc2e9cf3caae2cdb6e54558972745a121f7;hp=202a6176d396ea902fa3c7ea2079f2950a76d77b;hpb=80965661715b664b4926fc525d0c89306b92e832;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 202a617..693644f 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -79,8 +79,10 @@ data SimplCont		-- Strict contexts
 	     SimplCont
 
   | ApplyTo  DupFlag 
-	     InExpr SimplEnv		-- The argument, as yet unsimplified, 
-	     SimplCont			-- and its environment
+	     CoreExpr		-- The argument
+	     (Maybe SimplEnv)   -- (Just se) => the arg is un-simplified and this is its subst-env
+				-- Nothing   => the arg is already simplified; don't repeatedly simplify it!
+	     SimplCont		-- and its environment
 
   | Select   DupFlag 
 	     InId [InAlt] SimplEnv	-- The case binder, alts, and subst-env
@@ -181,18 +183,18 @@ countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
 countArgs other			  = 0
 
 -------------------
-pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+pushContArgs ::[OutArg] -> SimplCont -> SimplCont
 -- Pushes args with the specified environment
-pushContArgs env []           cont = cont
-pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
+pushContArgs []           cont = cont
+pushContArgs (arg : args) cont = ApplyTo NoDup arg Nothing (pushContArgs args cont)
 \end{code}
 
 
 \begin{code}
 getContArgs :: SwitchChecker
 	    -> OutId -> SimplCont 
-	    -> ([(InExpr, SimplEnv, Bool)],	-- Arguments; the Bool is true for strict args
-		SimplCont)			-- Remaining continuation
+	    -> ([(InExpr, Maybe SimplEnv, Bool)],	-- Arguments; the Bool is true for strict args
+		SimplCont)				-- Remaining continuation
 -- getContArgs id k = (args, k', inl)
 -- 	args are the leading ApplyTo items in k
 --	(i.e. outermost comes first)
@@ -374,12 +376,12 @@ interestingCallContext :: Bool 		-- False <=> no args at all
 interestingCallContext some_args some_val_args cont
   = interesting cont
   where
-    interesting (Select _ _ _ _ _)       = some_args
-    interesting (ApplyTo _ _ _ _)        = True	-- Can happen if we have (coerce t (f x)) y
+    interesting (Select {})              = some_args
+    interesting (ApplyTo {})             = True	-- Can happen if we have (coerce t (f x)) y
 						-- Perhaps True is a bit over-keen, but I've
 						-- seen (coerce f) x, where f has an INLINE prag,
 						-- So we have to give some motivaiton for inlining it
-    interesting (ArgOf _ _ _ _)	         = some_val_args
+    interesting (ArgOf {})	         = some_val_args
     interesting (Stop ty _ interesting)  = some_val_args && interesting
     interesting (CoerceIt _ cont)        = interesting cont
 	-- If this call is the arg of a strict function, the context
@@ -746,6 +748,11 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 			-- int_cxt to prevent us inlining inside a lambda without some 
 			-- good reason.  See the notes on int_cxt in preInlineUnconditionally
 
+      IAmDead -> True	-- This happens; for example, the case_bndr during case of
+			-- known constructor:  case (a,b) of x { (p,q) -> ... }
+			-- Here x isn't mentioned in the RHS, so we don't want to
+			-- create the (dead) let-binding  let x = (a,b) in ...
+
       other -> False
 
 -- Here's an example that we don't handle well: