X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=45cda3856f130f3d4ab14400059d512a52caba18;hb=522c8ebea4546658b4a5ee6727a0cab64fd72e8b;hp=e6a65f4eddc091f8490f7c497235512d70a0b069;hpb=0477b3897086e437d192db8d644b1ef30af82898;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index e6a65f4..45cda38 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -26,10 +26,8 @@ import Id		( Id, idType, idInfo, idArity, isDataConWorkId,
 			  idNewDemandInfo, setIdInfo, 
 			  setIdOccInfo, zapLamIdInfo, setOneShotLambda
 			)
-import IdInfo		( OccInfo(..), isLoopBreaker,
-			  setArityInfo, zapDemandInfo,
-			  setUnfoldingInfo, 
-			  occInfo
+import IdInfo		( OccInfo(..), setArityInfo, zapDemandInfo,
+			  setUnfoldingInfo, occInfo
 			)
 import NewDemand	( isStrictDmd )
 import TcGadt		( dataConCanMatch )
@@ -58,7 +56,7 @@ import VarEnv		( elemVarEnv, emptyVarEnv )
 import TysPrim		( realWorldStatePrimTy )
 import PrelInfo		( realWorldPrimId )
 import BasicTypes	( TopLevelFlag(..), isTopLevel, 
-			  RecFlag(..), isNonRec
+			  RecFlag(..), isNonRec, isNonRuleLoopBreaker
 			)
 import OrdList
 import List		( nub )
@@ -372,7 +370,6 @@ completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
   | otherwise
   = 	-- Make the arguments atomic if necessary, 
 	-- adding suitable bindings
-    -- pprTrace "completeNonRecX" (ppr new_bndr <+> ppr new_rhs) $
     mkAtomicArgsE env is_strict new_rhs		$ \ env new_rhs ->
     completeLazyBind env NotTopLevel
 		     old_bndr new_bndr new_rhs	`thenSmpl` \ (floats, env) ->
@@ -600,14 +597,17 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
 
   |  otherwise
   = let
-		-- Add arity info
+	-- 	Arity info
   	new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
 
+	-- 	Unfolding info
 	-- Add the unfolding *only* for non-loop-breakers
 	-- Making loop breakers not have an unfolding at all 
 	-- means that we can avoid tests in exprIsConApp, for example.
 	-- This is important: if exprIsConApp says 'yes' for a recursive
 	-- thing, then we can get into an infinite loop
+
+	-- 	Demand info
 	-- If the unfolding is a value, the demand info may
 	-- go pear-shaped, so we nuke it.  Example:
 	--	let x = (a,b) in
@@ -635,7 +635,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
     returnSmpl (unitFloat env final_id new_rhs, env)
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
-    loop_breaker = isLoopBreaker occ_info
+    loop_breaker = isNonRuleLoopBreaker occ_info
     old_info     = idInfo old_bndr
     occ_info     = occInfo old_info
 \end{code}    
@@ -926,7 +926,7 @@ simplVar env var cont
   = case substId env var of
 	DoneEx e	 -> simplExprF (zapSubstEnv env) e cont
 	ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
-	DoneId var1 occ  -> completeCall (zapSubstEnv env) var1 occ cont
+	DoneId var1      -> completeCall (zapSubstEnv env) var1 cont
 		-- Note [zapSubstEnv]
 		-- The template is already simplified, so don't re-substitute.
 		-- This is VITAL.  Consider
@@ -940,7 +940,7 @@ simplVar env var cont
 ---------------------------------------------------------
 --	Dealing with a call site
 
-completeCall env var occ_info cont
+completeCall env var cont
   =     -- Simplify the arguments
     getDOptsSmpl					`thenSmpl` \ dflags ->
     let
@@ -1005,8 +1005,8 @@ completeCall env var occ_info cont
 	interesting_cont = interestingCallContext (notNull args)
 						  (notNull arg_infos)
 						  call_cont
-    	active_inline = activeInline env var occ_info
-	maybe_inline  = callSiteInline dflags active_inline occ_info
+    	active_inline = activeInline env var
+	maybe_inline  = callSiteInline dflags active_inline
 				       var arg_infos interesting_cont
     in
     case maybe_inline of {