[project @ 2000-04-21 14:40:48 by simonpj]

Remove a way to make the simplifier go into an
infinite loop.   This has been there for some weeks;
and George's UniForm tickled it.  I'm amazed nothing
else has done so.  I'll add a test.

The bad case happened when you go

	let xs = 1:xs
	in
	foldr k z xs

Then we kept firing the foldr/cons rule.

Solution: we don't attach an unfolding *at all* to
loop breakers (Simplify.completeBinding)

ghc/compiler/basicTypes/BasicTypes.lhs

@@ -29,7 +29,7 @@ module BasicTypes(
 
 	TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
-	OccInfo(..), seqOccInfo, isFragileOccInfo,
+	OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker,
 	InsideLam, insideLam, notInsideLam,
 	OneBranch, oneBranch, notOneBranch
 
@@ -204,6 +204,10 @@ type OneBranch = Bool	-- True <=> Occurs in only one case branch
 oneBranch    = True
 notOneBranch = False
 
+isLoopBreaker :: OccInfo -> Bool
+isLoopBreaker IAmALoopBreaker = True
+isLoopBreaker other	      = False
+
 isFragileOccInfo :: OccInfo -> Bool
 isFragileOccInfo (OneOcc _ _) = True
 isFragileOccInfo other	      = False

ghc/compiler/coreSyn/CoreUnfold.lhs

@@ -515,7 +515,7 @@ callSiteInline :: Bool			-- True <=> the Id is black listed
 callSiteInline black_listed inline_call occ id arg_infos interesting_cont
   = case idUnfolding id of {
 	NoUnfolding -> Nothing ;
-	OtherCon _  -> Nothing ;
+	OtherCon cs -> Nothing ;
 	CompulsoryUnfolding unf_template | black_listed -> Nothing 
 					 | otherwise 	-> Just unf_template ;
 		-- Constructors have compulsory unfoldings, but

ghc/compiler/coreSyn/PprCore.lhs

@@ -10,7 +10,7 @@
 \begin{code}
 module PprCore (
 	pprCoreExpr, pprParendExpr, pprIfaceUnfolding, 
-	pprCoreBinding, pprCoreBindings, pprIdBndr,
+	pprCoreBinding, pprCoreBindings,
 	pprCoreRules, pprCoreRule
     ) where
 
@@ -22,7 +22,7 @@ import Id		( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
 			  idInfo, idInlinePragma, idDemandInfo, idOccInfo
 			)
 import Var		( isTyVar )
-import IdInfo		( IdInfo, megaSeqIdInfo,
+import IdInfo		( IdInfo, megaSeqIdInfo, occInfo,
 			  arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
 			  demandInfo, updateInfo, ppUpdateInfo, specInfo, 
 			  strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
@@ -342,7 +342,7 @@ pprIdBndr id = ppr id <+>
 	       (megaSeqIdInfo (idInfo id) `seq`
 			-- Useful for poking on black holes
 	        ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
-				      ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
+			    ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
 \end{code}
 
 
@@ -355,16 +355,15 @@ ppIdInfo info
 	    ppUpdateInfo u,
 	    ppWorkerInfo (workerInfo info),
 	    ppStrictnessInfo s,
-	    ppr d,
 	    ppCafInfo c,
             ppCprInfo m,
-	    ppr (lbvarInfo info),
 	    pprIfaceCoreRules p
-	-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
+	-- Inline pragma, occ, demand, lbvar info
+	-- printed out with all binders (when debug is on); 
+	-- see PprCore.pprIdBndr
 	]
   where
     a = arityInfo info
-    d = demandInfo info
     s = strictnessInfo info
     u = updateInfo info
     c = cafInfo info

ghc/compiler/coreSyn/Subst.lhs

@@ -295,20 +295,21 @@ substPred subst (IParam n ty)    = IParam n (subst_ty subst ty)
 subst_ty subst ty
    = go ty
   where
-    go (TyConApp tc tys)	  = let args = map go tys
-				    in  args `seqList` TyConApp tc args
-    go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
-    go (NoteTy (FTVNote _) ty2)   = go ty2		-- Discard the free tyvar note
-    go (FunTy arg res)   	  = (FunTy $! (go arg)) $! (go res)
+    go (TyConApp tc tys)	   = let args = map go tys
+				     in  args `seqList` TyConApp tc args
+    go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote $! (go ty1)) $! (go ty2)
+    go (NoteTy (FTVNote _) ty2)    = go ty2		-- Discard the free tyvar note
     go (NoteTy (UsgNote usg)  ty2) = (NoteTy $! UsgNote usg) $! go ty2  	-- Keep usage annot
     go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2  	-- Keep uvar bdr
     go (NoteTy (IPNote nm) ty2)	   = (NoteTy $! IPNote nm) $! go ty2		-- Keep ip note
-    go (AppTy fun arg)   	  = mkAppTy (go fun) $! (go arg)
-    go ty@(TyVarTy tv)   	  = case (lookupSubst subst tv) of
+
+    go (FunTy arg res)   	   = (FunTy $! (go arg)) $! (go res)
+    go (AppTy fun arg)   	   = mkAppTy (go fun) $! (go arg)
+    go ty@(TyVarTy tv)   	   = case (lookupSubst subst tv) of
 	       				Nothing 	   -> ty
        					Just (DoneTy ty')  -> ty'
 					
-    go (ForAllTy tv ty)		  = case substTyVar subst tv of
+    go (ForAllTy tv ty)		   = case substTyVar subst tv of
 					(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
 \end{code}
 
@@ -530,13 +531,12 @@ substWorker :: Subst -> WorkerInfo -> WorkerInfo
 substWorker subst NoWorker
   = NoWorker
 substWorker subst (HasWorker w a)
-  = case lookupSubst subst w of
-	Nothing		       -> HasWorker w a
-	Just (DoneId w1 _)     -> HasWorker w1 a
-	Just (DoneEx (Var w1)) -> HasWorker w1 a
-	Just (DoneEx other)    -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
+  = case lookupIdSubst subst w of
+	(DoneId w1 _)     -> HasWorker w1 a
+	(DoneEx (Var w1)) -> HasWorker w1 a
+	(DoneEx other)    -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
 				  NoWorker	-- Worker has got substituted away altogether
-	Just (ContEx se1 e)    -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
+	(ContEx se1 e)    -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
 				  NoWorker	-- Ditto
 			
 substRules :: Subst -> CoreRules -> CoreRules
@@ -549,8 +549,7 @@ substRules subst rules
 substRules subst (Rules rules rhs_fvs)
   = seqRules new_rules `seq` new_rules
   where
-    new_rules = Rules (map do_subst rules)
-		      (subst_fvs (substEnv subst) rhs_fvs)
+    new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
 
     do_subst rule@(BuiltinRule _) = rule
     do_subst (Rule name tpl_vars lhs_args rhs)
@@ -560,13 +559,12 @@ substRules subst (Rules rules rhs_fvs)
 	where
 	  (subst', tpl_vars') = substBndrs subst tpl_vars
 
-    subst_fvs se fvs
-	= foldVarSet (unionVarSet . subst_fv) emptyVarSet rhs_fvs
-	where
-	  subst_fv fv = case lookupSubstEnv se fv of
-				Nothing			  -> unitVarSet fv
-				Just (DoneId fv' _)	  -> unitVarSet fv'
-				Just (DoneEx expr)	  -> exprFreeVars expr
-				Just (DoneTy ty)  	  -> tyVarsOfType ty 
-				Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
+substVarSet subst fvs 
+  = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
+  where
+    subst_fv subst fv = case lookupIdSubst subst fv of
+			    DoneId fv' _    -> unitVarSet fv'
+			    DoneEx expr	    -> exprFreeVars expr
+			    DoneTy ty  	    -> tyVarsOfType ty 
+			    ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
 \end{code}

ghc/compiler/main/MkIface.lhs

@@ -14,7 +14,9 @@ import IO		( Handle, hPutStr, openFile,
 			  hClose, hPutStrLn, IOMode(..) )
 
 import HsSyn
-import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes	( Fixity(..), FixityDirection(..), NewOrData(..), 
+			  OccInfo, isLoopBreaker
+			)
 import RnMonad
 import RnEnv		( availName )
 
@@ -32,7 +34,7 @@ import IdInfo		( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inli
 			  strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
 			  cafInfo, ppCafInfo, specInfo,
 			  cprInfo, ppCprInfo, pprInlinePragInfo,
-			  occInfo, OccInfo(..),
+			  occInfo, 
 			  workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
 			)
 import CoreSyn		( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
@@ -366,9 +368,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
 
 
     ------------  Occ info  --------------
-    loop_breaker  = case occInfo core_idinfo of
-			IAmALoopBreaker -> True
-			other		-> False
+    loop_breaker  = isLoopBreaker (occInfo core_idinfo)
 
     ------------  Unfolding  --------------
     inline_pragma  = inlinePragInfo core_idinfo

ghc/compiler/simplCore/Simplify.lhs

@@ -36,7 +36,7 @@ import Id		( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe,
 import IdInfo		( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), 
 		 	  ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
 			  specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo,
-			  CprInfo(..), cprInfo
+			  CprInfo(..), cprInfo, occInfo
 			)
 import Demand		( Demand, isStrict, wwLazy )
 import DataCon		( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity,
@@ -66,7 +66,7 @@ import Subst		( Subst, mkSubst, emptySubst, substTy, substExpr,
 import TyCon		( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
 import TysPrim		( realWorldStatePrimTy )
 import PrelInfo		( realWorldPrimId )
-import BasicTypes	( TopLevelFlag(..), isTopLevel )
+import BasicTypes	( TopLevelFlag(..), isTopLevel, isLoopBreaker )
 import Maybes		( maybeToBool )
 import Util		( zipWithEqual, lengthExceeds )
 import PprCore
@@ -551,9 +551,16 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
 	old_info      = idInfo old_bndr
 	new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
 		        `setArityInfo` ArityAtLeast (exprArity new_rhs)
-			`setUnfoldingInfo` mkUnfolding top_lvl new_rhs
 
-	final_id = new_bndr `setIdInfo` new_bndr_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 we can get into an infinite loop
+	info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info
+		   | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+	final_id = new_bndr `setIdInfo` info_w_unf
      in
 	-- These seqs forces the Id, and hence its IdInfo,
 	-- and hence any inner substitutions
@@ -980,8 +987,8 @@ postInlineUnconditionally :: Bool  	-- Black listed
 postInlineUnconditionally black_listed occ_info bndr rhs
   | isExportedId bndr	|| 
     black_listed 	|| 
-    loop_breaker	= False			-- Don't inline these
-  | otherwise	        = exprIsTrivial rhs	-- Duplicating is free
+    isLoopBreaker occ_info = False		-- Don't inline these
+  | otherwise	           = exprIsTrivial rhs	-- Duplicating is free
 	-- Don't inline even WHNFs inside lambdas; doing so may
 	-- simply increase allocation when the function is called
 	-- This isn't the last chance; see NOTE above.
@@ -993,10 +1000,6 @@ postInlineUnconditionally black_listed occ_info bndr rhs
 	-- NB: Even NOINLINEis ignored here: if the rhs is trivial
 	-- it's best to inline it anyway.  We often get a=E; b=a
 	-- from desugaring, with both a and b marked NOINLINE.
-  where
-    loop_breaker = case occ_info of
-			IAmALoopBreaker -> True
-			other		-> False
 \end{code}