X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=baf2a3097a3c47a80437cd08883407d680a76403;hb=8e15cfb601a904523a39079aa7c55e729ccbffda;hp=dbad116eae6fe733140a182e89ed83e0d9c4e687;hpb=58e45ee86bbda3f24a4caf41c0aea7a6b787367e;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index dbad116..baf2a30 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -264,7 +264,7 @@ simplRecBind env top_lvl pairs
   where
     add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
 	-- Add the (substituted) rules to the binder
-    add_rules env (bndr, rhs) = (env, (bndr, bndr', rhs))
+    add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
 	where
 	  (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
 
@@ -1027,12 +1027,10 @@ completeCall env var cont
 	------------- Next try inlining ----------------
 	{ let	arg_infos = [interestingArg arg | arg <- args, isValArg arg]
 		n_val_args = length arg_infos
-	      	interesting_cont = interestingCallContext (notNull args)
-						  	  (notNull arg_infos)
-						  	  call_cont
+	      	interesting_cont = interestingCallContext call_cont
 	 	active_inline = activeInline env var
-		maybe_inline  = callSiteInline dflags active_inline
-				       var arg_infos interesting_cont
+		maybe_inline  = callSiteInline dflags active_inline var
+				               (null args) arg_infos interesting_cont
 	; case maybe_inline of {
 	    Just unfolding  	-- There is an inlining!
 	      ->  do { tick (UnfoldingDone var)
@@ -1331,7 +1329,7 @@ where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
 	   I# x# -> let x = x' `cast` sym co 
 		    in rhs
 
-so that 'rhs' can take advantage of hte form of x'.  Notice that Note
+so that 'rhs' can take advantage of the form of x'.  Notice that Note
 [Case of cast] may then apply to the result.
 
 This showed up in Roman's experiments.  Example:
@@ -1574,19 +1572,19 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
 
 simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
   = do	{	-- Deal with the pattern-bound variables
-	  (env, vs') <- simplBinders env (add_evals con vs)
-
 		-- Mark the ones that are in ! positions in the
 		-- data constructor as certainly-evaluated.
-	; let vs'' = add_evals con vs'
+		-- NB: simplLamBinders preserves this eval info
+	  let vs_with_evals = add_evals vs (dataConRepStrictness con)
+	; (env, vs') <- simplLamBndrs env vs_with_evals
 
 		-- Bind the case-binder to (con args)
 	; let inst_tys' = tyConAppArgs (idType case_bndr')
-	      con_args  = map Type inst_tys' ++ varsToCoreExprs vs'' 
+	      con_args  = map Type inst_tys' ++ varsToCoreExprs vs' 
 	      env'      = addBinderUnfolding env case_bndr' (mkConApp con con_args)
 
 	; rhs' <- simplExprC env' rhs cont'
-	; return (DataAlt con, vs'', rhs') }
+	; return (DataAlt con, vs', rhs') }
   where
 	-- add_evals records the evaluated-ness of the bound variables of
 	-- a case pattern.  This is *important*.  Consider
@@ -1597,9 +1595,7 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
 	-- We really must record that b is already evaluated so that we don't
 	-- go and re-evaluate it when constructing the result.
 	-- See Note [Data-con worker strictness] in MkId.lhs
-    add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
-
-    cat_evals dc vs strs
+    add_evals vs strs
 	= go vs strs
 	where
 	  go [] [] = []
@@ -1610,12 +1606,15 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
 	    where
 	      zapped_v = zap_occ_info v
 	      evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
-	  go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
+	  go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs)
 
-	-- If the case binder is alive, then we add the unfolding
+	-- zap_occ_info: 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
+	-- Note [Aug06] I can't see why this actually matters, but it's neater
+	-- 	  case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
+	--   ==>  case e of t { (a,b) -> ...(a)... }
+	-- Look, Ma, a is alive now.
     zap_occ_info | isDeadBinder case_bndr' = \id -> id
 		 | otherwise		   = zapOccInfo