X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=693f1a2c6b64cd1256f65ddd5a2dc33160ee66c2;hb=145efe5483bba17e0ea9d55a9ab0aa891d3fc4de;hp=9723dfb7019a5c21ef3c2cd36c519ea7b371429a;hpb=ca919ae01e81fb4afb2243bb34eceff56ca66043;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9723dfb..693f1a2 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -742,7 +742,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType
 	-- Kept monadic just so we can do the seqType
 simplType env ty
   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
-    seqType new_ty   `seq`   returnSmpl new_ty
+    seqType new_ty   `seq`   return new_ty
   where
     new_ty = substTy env ty
 \end{code}
@@ -939,8 +939,8 @@ simplNote env InlineMe e cont
 		-- (even a type application -- anything except Stop)
   = simplExprF env e cont
 
-simplNote env (CoreNote s) e cont
-  = simplExpr env e    `thenSmpl` \ e' ->
+simplNote env (CoreNote s) e cont = do
+    e' <- simplExpr env e
     rebuild env (Note (CoreNote s) e') cont
 \end{code}
 
@@ -1009,8 +1009,8 @@ completeCall env var cont
 				Just act_fn -> lookupRule act_fn in_scope 
 							  rules var args 
 	; case maybe_rule of {
-	    Just (rule, rule_rhs) -> 
-		tick (RuleFired (ru_name rule))			`thenSmpl_`
+	    Just (rule, rule_rhs) -> do
+		tick (RuleFired (ru_name rule))
 		(if dopt Opt_D_dump_rule_firings dflags then
 		   pprTrace "Rule fired" (vcat [
 			text "Rule:" <+> ftext (ru_name rule),
@@ -1019,8 +1019,8 @@ completeCall env var cont
 			text "Cont:  " <+> ppr call_cont])
 		 else
 			id)		$
-		simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
-		-- The ruleArity says how many args the rule consumed
+		 simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
+		 -- The ruleArity says how many args the rule consumed
 	
 	  ; Nothing -> do	-- No rules
 
@@ -1572,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
@@ -1595,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 [] [] = []
@@ -1608,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
 
@@ -1739,7 +1740,7 @@ mkDupableCont :: SimplEnv -> SimplCont
 
 mkDupableCont env cont
   | contIsDupable cont
-  = returnSmpl (env, cont, mkBoringStop (contResultType cont))
+  = return (env, cont, mkBoringStop (contResultType cont))
 
 mkDupableCont env (Stop {}) = panic "mkDupableCont" 	-- Handled by previous eqn