X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=a27aa47d24068172db4dc708b2bad41f9562fa9d;hb=a496c6a2211b821357872cb15c0204c848585b38;hp=be6eba32587592f60d502eaa9af9587faee77f04;hpb=75ba47fa64d358c569c214be669b6570533ae920;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index be6eba3..a27aa47 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -39,6 +39,7 @@ import PrelInfo		( realWorldPrimId )
 import BasicTypes	( TopLevelFlag(..), isTopLevel, 
 			  RecFlag(..), isNonRuleLoopBreaker )
 import Maybes		( orElse )
+import Data.List	( mapAccumL )
 import Outputable
 import Util
 \end{code}
@@ -234,8 +235,10 @@ simplTopBinds env binds
     trace True  bind = pprTrace "SimplBind" (ppr (bindersOf bind))
     trace False bind = \x -> x
 
-    simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r
-    simpl_bind env (Rec pairs)  = simplRecBind      env TopLevel pairs
+    simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
+    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+	where
+	  (env', b') = addBndrRules env b (lookupRecBndr env b)
 \end{code}
 
 
@@ -253,15 +256,22 @@ simplRecBind :: SimplEnv -> TopLevelFlag
 	     -> [(InId, InExpr)]
 	     -> SimplM SimplEnv
 simplRecBind env top_lvl pairs
-  = do	{ env' <- go (zapFloats env) pairs
+  = do	{ let (env_with_info, triples) = mapAccumL add_rules env pairs
+	; env' <- go (zapFloats env_with_info) triples
 	; return (env `addRecFloats` env') }
 	-- addFloats adds the floats from env', 
 	-- *and* updates env with the in-scope set from env'
   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))
+	where
+	  (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
+
     go env [] = return env
 	
-    go env ((bndr, rhs) : pairs)
-	= do { env <- simplRecOrTopPair env top_lvl bndr rhs
+    go env ((old_bndr, new_bndr, rhs) : pairs)
+	= do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
 	     ; go env pairs }
 \end{code}
 
@@ -274,18 +284,16 @@ It assumes the binder has already been simplified, but not its IdInfo.
 \begin{code}
 simplRecOrTopPair :: SimplEnv
 	     	  -> TopLevelFlag
-	     	  -> InId -> InExpr	-- Binder and rhs
+	     	  -> InId -> OutBndr -> InExpr	-- Binder and rhs
 	     	  -> SimplM SimplEnv	-- Returns an env that includes the binding
 
-simplRecOrTopPair env top_lvl bndr rhs
-  | preInlineUnconditionally env top_lvl bndr rhs  	-- Check for unconditional inline
-  = do	{ tick (PreInlineUnconditionally bndr)
-	; return (extendIdSubst env bndr (mkContEx env rhs)) }
+simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+  | preInlineUnconditionally env top_lvl old_bndr rhs  	-- Check for unconditional inline
+  = do	{ tick (PreInlineUnconditionally old_bndr)
+	; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
 
   | otherwise
-  = do	{ let bndr' = lookupRecBndr env bndr
-	      (env', bndr'') = addLetIdInfo env bndr bndr'
-	; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' }
+  = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env 
 	-- May not actually be recursive, but it doesn't matter
 \end{code}
 
@@ -578,6 +586,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
 	-- (for example) be no longer strictly demanded.
 	-- The solution here is a bit ad hoc...
  	info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+				   `setWorkerInfo`    worker_info
+
         final_info | loop_breaker		= new_bndr_info
 		   | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
 		   | otherwise			= info_w_unf
@@ -591,6 +601,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
     return (addNonRec env final_id new_rhs)
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
+    worker_info  = substWorker env (workerInfo old_info)
     loop_breaker = isNonRuleLoopBreaker occ_info
     old_info     = idInfo old_bndr
     occ_info     = occInfo old_info
@@ -896,9 +907,10 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
 		     (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = do	{ (env, bndr') <- simplNonRecBndr env bndr
-	; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
-	; simplLam env bndrs body cont }
+  = do	{ (env1, bndr1) <- simplNonRecBndr env bndr
+	; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+	; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+	; simplLam env3 bndrs body cont }
 \end{code}
 
 
@@ -977,8 +989,8 @@ completeCall env var cont
 	-- the wrapper didn't occur for things that have specialisations till a 
 	-- later phase, so but now we just try RULES first
 	--
-	-- Note [Self-recursive rules]
-	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	-- Note [Rules for recursive functions]
+	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 	-- You might think that we shouldn't apply rules for a loop breaker: 
 	-- doing so might give rise to an infinite loop, because a RULE is
 	-- rather like an extra equation for the function:
@@ -1455,7 +1467,7 @@ simplCaseBinder env scrut case_bndr alts
 		-- See Note [no-case-of-case]
 	= (env, case_bndr)
 
-	| otherwise	-- Failed try [see Note 2 above]
+	| otherwise	-- Failed try; see Note [Suppressing the case binder-swap]
 			--     not (isEvaldUnfolding (idUnfolding v))
 	= case scrut of
 	    Var v -> (modifyInScope env1 v case_bndr', case_bndr')
@@ -1533,7 +1545,7 @@ simplAlts env scrut case_bndr alts cont'
     do	{ let alt_env = zapFloats env
 	; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
 
-	; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts
+	; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts
 
 	; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
 	; return (scrut', case_bndr', alts') }