Second bite at the rules-only idea

This is part 2 of the patch that improved the interaction of RULES and
recursion.  It's vital that all Ids that may be referred to from later in
the module are marked 'IAmALoopBreaker' because otherwise we may do
postInlineUnconditionally, and lose the binding altogether. 

So I've added a boolean rules-only flag to IAmALoopBreaker.  Now we can
do inlining for rules-only loop-breakers.

compiler/basicTypes/BasicTypes.lhs

@@ -38,7 +38,7 @@ module BasicTypes(
 	TupCon(..), tupleParens,
 
 	OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, 
-	isDeadOcc, isLoopBreaker, isNoOcc,
+	isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
 
 	InsideLam, insideLam, notInsideLam,
 	OneBranch, oneBranch, notOneBranch,
@@ -372,13 +372,40 @@ data OccInfo
   | IAmDead		-- Marks unused variables.  Sometimes useful for
 			-- lambda and case-bound variables.
 
-  | OneOcc !InsideLam	-- Occurs exactly once, not inside a rule
- 	   !OneBranch
-	   !InterestingCxt
+  | OneOcc		-- Occurs exactly once, not inside a rule
+	!InsideLam
+ 	!OneBranch
+	!InterestingCxt
 
   | IAmALoopBreaker	-- Used by the occurrence analyser to mark loop-breakers
 			-- in a group of recursive definitions
+	!Bool		-- True <=> This loop breaker occurs only the RHS of a RULE
+\end{code}
+
+Note [RulesOnly]
+~~~~~~~~~~~~~~~~
+The RulesOnly constructor records if an Id occurs only in the RHS of a Rule.
+Similarly, the boolean in IAmLoopbreaker True if the only reason the Id is a
+loop-breaker only because of recursion through a RULE. In that case,
+we can ignore the loop-breaker-ness for inlining purposes.  Example
+(from GHC.Enum):
+
+  eftInt :: Int# -> Int# -> [Int]
+  eftInt x y = ...(non-recursive)...
+
+  {-# INLINE [0] eftIntFB #-}
+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
+  eftIntFB c n x y = ...(non-recursive)...
 
+  {-# RULES
+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt
+   #-}
+
+The two look mutually recursive only because of their RULES;
+we don't want that to inhibit inlining!
+
+\begin{code}
 isNoOcc :: OccInfo -> Bool
 isNoOcc NoOccInfo = True
 isNoOcc other     = False
@@ -405,8 +432,12 @@ oneBranch    = True
 notOneBranch = False
 
 isLoopBreaker :: OccInfo -> Bool
-isLoopBreaker IAmALoopBreaker = True
-isLoopBreaker other	      = False
+isLoopBreaker (IAmALoopBreaker _) = True
+isLoopBreaker other	          = False
+
+isNonRuleLoopBreaker :: OccInfo -> Bool
+isNonRuleLoopBreaker (IAmALoopBreaker False) = True	-- Loop-breaker that breaks a non-rule cycle
+isNonRuleLoopBreaker other	             = False
 
 isDeadOcc :: OccInfo -> Bool
 isDeadOcc IAmDead = True
@@ -423,10 +454,10 @@ isFragileOcc other	    = False
 \begin{code}
 instance Outputable OccInfo where
   -- only used for debugging; never parsed.  KSW 1999-07
-  ppr NoOccInfo  			  	  = empty
-  ppr RulesOnly  			  	  = ptext SLIT("RulesOnly")
-  ppr IAmALoopBreaker 				  = ptext SLIT("LoopBreaker")
-  ppr IAmDead					  = ptext SLIT("Dead")
+  ppr NoOccInfo  	   = empty
+  ppr RulesOnly  	   = ptext SLIT("RulesOnly")
+  ppr (IAmALoopBreaker ro) = ptext SLIT("LoopBreaker") <> if ro then char '!' else empty
+  ppr IAmDead		   = ptext SLIT("Dead")
   ppr (OneOcc inside_lam one_branch int_cxt)
 	= ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args
 	where

compiler/coreSyn/CoreUnfold.lhs

@@ -532,11 +532,11 @@ callSiteInline dflags active_inline occ id arg_infos interesting_cont
  	yes_or_no 
 	  | not active_inline = False
 	  | otherwise = case occ of
-				IAmDead		     -> pprTrace "callSiteInline: dead" (ppr id) False
-				IAmALoopBreaker      -> False
-				--OneOcc in_lam _ _    -> (not in_lam || is_cheap) && consider_safe True
-				other		     -> is_cheap && consider_safe False
-		-- we consider even the once-in-one-branch
+				IAmDead		      -> pprTrace "callSiteInline: dead" (ppr id) False
+				IAmALoopBreaker False -> False	-- Note [RulesOnly] in BasicTypes
+				--OneOcc in_lam _ _   -> (not in_lam || is_cheap) && consider_safe True
+				other		      -> is_cheap && consider_safe False
+		-- We consider even the once-in-one-branch
 		-- occurrences, because they won't all have been
 		-- caught by preInlineUnconditionally.  In particular,
 		-- if the occurrence is once inside a lambda, and the

compiler/main/TidyPgm.lhs

@@ -26,7 +26,7 @@ import Id		( idType, idInfo, idName, idCoreRules, isGlobalId,
 import IdInfo		{- loads of stuff -}
 import InstEnv		( Instance, DFunId, instanceDFunId, setInstanceDFunId )
 import NewDemand	( isBottomingSig, topSig )
-import BasicTypes	( Arity, isNeverActive )
+import BasicTypes	( Arity, isNeverActive, isNonRuleLoopBreaker )
 import Name		( Name, getOccName, nameOccName, mkInternalName,
 		  	  localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
 			  isWiredInName, getName
@@ -462,7 +462,7 @@ addExternal (id,rhs) needed
 
     idinfo	   = idInfo id
     dont_inline	   = isNeverActive (inlinePragInfo idinfo)
-    loop_breaker   = isLoopBreaker (occInfo idinfo)
+    loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
     spec_ids	   = specInfoFreeVars (specInfo idinfo)
     worker_info	   = workerInfo idinfo

compiler/simplCore/OccurAnal.lhs

@@ -35,7 +35,7 @@ import Maybes		( orElse )
 import Digraph		( stronglyConnCompR, SCC(..) )
 import PrelNames	( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
 import Unique		( Unique )
-import UniqFM		( keysUFM, lookupUFM_Directly )  
+import UniqFM		( keysUFM )  
 import Util		( zipWithEqual, mapAndUnzip )
 import Outputable
 \end{code}
@@ -79,14 +79,6 @@ Bindings
 ~~~~~~~~
 
 \begin{code}
-type IdWithOccInfo = Id			-- An Id with fresh PragmaInfo attached
-
-type Node details = (details, Unique, [Unique])	-- The Ints are gotten from the Unique,
-						-- which is gotten from the Id.
-type Details1	  = (Id, UsageDetails, CoreExpr)
-type Details2	  = (IdWithOccInfo, CoreExpr)
-
-
 occAnalBind :: OccEnv
 	    -> CoreBind
 	    -> UsageDetails		-- Usage details of scope
@@ -198,17 +190,22 @@ occAnalBind env (Rec pairs) body_usage
 	details			       = [details   | (details, _, _) <- cycle]
 	bndrs			       = [bndr      | (bndr, _, _)      <- details]
 	rhs_usages		       = [rhs_usage | (_, rhs_usage, _) <- details]
-	total_usage		       = foldr combineUsageDetails body_usage rhs_usages
+	rhs_usage		       = foldr1 combineUsageDetails rhs_usages
+	total_usage		       = rhs_usage `combineUsageDetails` body_usage
 	(combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
-	final_bind		       = Rec (doReorder edges)
+
+	new_cycle :: [Node Details2]
+	new_cycle  = zipWithEqual "reorder" mk_node tagged_bndrs cycle
+	final_bind = Rec (reOrderCycle rhs_usage new_cycle)
+	mk_node tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
+
+{-	An alternative; rebuild the edges.  No semantic difference, but perf might change
 
 	-- Hopefully 'bndrs' is a relatively small group now
 	-- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references
 	-- We've done dead-code elimination already, so no worries about un-referenced binders
-	edges :: [Node Details2]
-	edges = zipWithEqual "reorder" mk_edge tagged_bndrs details
 	keys = map idUnique bndrs
- 	mk_edge tagged_bndr (_, rhs_usage, rhs')
+ 	mk_node tagged_bndr (_, rhs_usage, rhs')
 	  = ((tagged_bndr, rhs'), idUnique tagged_bndr, used) 
 	  where
 	    used = [key | key <- keys, used_outside_rule rhs_usage key ]
@@ -217,15 +214,16 @@ occAnalBind env (Rec pairs) body_usage
 						Nothing		-> False
 						Just RulesOnly	-> False	-- Ignore rules
 						other		-> True
+-}
 \end{code}
 
 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 strongly connected component (there's guaranteed to be a cycle).  It returns the
 same pairs, but 
 	a) in a better order,
-	b) with some of the Ids having a IMustNotBeINLINEd pragma
+	b) with some of the Ids having a IAmALoopBreaker pragma
 
-The "no-inline" Ids are sufficient to break all cycles in the SCC.  This means
+The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means
 that the simplifier can guarantee not to loop provided it never records an inlining
 for these no-inline guys.
 
@@ -252,53 +250,34 @@ My solution was to make a=b bindings record b as Many, rather like INLINE bindin
 Perhaps something cleverer would suffice.
 ===============
 
-You might think that you can prevent non-termination simply by making
-sure that we simplify a recursive binding's RHS in an environment that
-simply clones the recursive Id.  But no.  Consider
-
-		letrec f = \x -> let z = f x' in ...
-
-		in
-		let n = f y
-		in
-		case n of { ... }
-
-We bind n to its *simplified* RHS, we then *re-simplify* it when
-we inline n.  Then we may well inline f; and then the same thing
-happens with z!
-
-I don't think it's possible to prevent non-termination by environment
-manipulation in this way.  Apart from anything else, successive
-iterations of the simplifier may unroll recursive loops in cases like
-that above.  The idea of beaking every recursive loop with an
-IMustNotBeINLINEd pragma is much much better.
-
 
 \begin{code}
-doReorder :: [Node Details2] -> [Details2]
--- Sorted into a plausible order.  Enough of the Ids have
---	dontINLINE pragmas that there are no loops left.
-doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes)
-
-reOrderRec :: SCC (Node Details2) -> [Details2]
-
-	-- Non-recursive case
-reOrderRec (AcyclicSCC (bind, _, _)) = [bind]
+type IdWithOccInfo = Id			-- An Id with fresh PragmaInfo attached
 
-	-- Common case of simple self-recursion
-reOrderRec (CyclicSCC [])
-  = panic "reOrderRec"
+type Node details = (details, Unique, [Unique])	-- The Ints are gotten from the Unique,
+						-- which is gotten from the Id.
+type Details1	  = (Id, UsageDetails, CoreExpr)
+type Details2	  = (IdWithOccInfo, CoreExpr)
 
-reOrderRec (CyclicSCC [bind])
-  = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+reOrderRec :: UsageDetails -> SCC (Node Details2) -> [Details2]
+-- Sorted into a plausible order.  Enough of the Ids have
+--	IAmALoopBreaker pragmas that there are no loops left.
+reOrderRec rhs_usg (AcyclicSCC (bind, _, _)) = [bind]
+reOrderRec rhs_usg (CyclicSCC cycle)  	     = reOrderCycle rhs_usg cycle
+
+reOrderCycle :: UsageDetails -> [Node Details2] -> [Details2]
+reOrderCycle rhs_usg []
+  = panic "reOrderCycle"
+reOrderCycle rhs_usg [bind]	-- Common case of simple self-recursion
+  = [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
   where
     ((tagged_bndr, rhs), _, _) = bind
 
-reOrderRec (CyclicSCC (bind : binds))
+reOrderCycle rhs_usg (bind : binds)
   = 	-- Choose a loop breaker, mark it no-inline,
 	-- do SCC analysis on the rest, and recursively sort them out
-    doReorder unchosen ++ 
-    [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+    concatMap (reOrderRec rhs_usg) (stronglyConnCompR unchosen) ++
+    [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
 
   where
     (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
@@ -355,6 +334,16 @@ reOrderRec (CyclicSCC (bind : binds))
 	-- But we won't because constructor args are marked "Many".
 
     not_fun_ty ty = not (isFunTy (dropForAlls ty))
+
+makeLoopBreaker :: UsageDetails -> Id -> Id
+-- Set the loop-breaker flag, recording whether the thing occurs only in 
+-- the RHS of a RULE (in this recursive group)
+makeLoopBreaker rhs_usg bndr
+  = setIdOccInfo bndr (IAmALoopBreaker rules_only)
+  where
+    rules_only = case lookupVarEnv rhs_usg bndr of
+		   Just RulesOnly -> True
+		   other	  -> False 
 \end{code}
 
 @occAnalRhs@ deals with the question of bindings where the Id is marked

compiler/simplCore/SimplUtils.lhs

@@ -721,7 +721,8 @@ postInlineUnconditionally
     -> Bool
 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
   | not active		   = False
-  | isLoopBreaker occ_info = False
+  | isLoopBreaker occ_info = False	-- If it's a loop-breaker of any kind, dont' inline
+					-- because it might be referred to "earlier"
   | isExportedId bndr      = False
   | exprIsTrivial rhs 	   = True
   | otherwise

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 )
@@ -600,14 +598,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 +636,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}