From: simonpj <unknown>
Date: Fri, 8 Sep 2000 11:09:38 +0000 (+0000)
Subject: [project @ 2000-09-08 11:09:38 by simonpj]
X-Git-Tag: Approximately_9120_patches~3766
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a5314715619bdcc39271854e7b7d81e1e3a5a779;p=ghc-hetmet.git

[project @ 2000-09-08 11:09:38 by simonpj]
Fix the loop in SimplUtils.interestingArg
---

diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index d9d9279..94c40da 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -60,7 +60,8 @@ import UniqSet		( elemUniqSet_Directly )
 import UniqSupply	( UniqSupply, uniqFromSupply, splitUniqSupply )
 import Var		( Var, Id, TyVar, isTyVar )
 import Outputable
-import PprCore		()	-- Instances
+import PprCore		()		-- Instances
+import UniqFM		( ufmToList )	-- Yuk (add a new op to VarEnv)
 import Util		( mapAccumL, foldl2, seqList, ($!) )
 \end{code}
 
@@ -168,7 +169,17 @@ data Subst = Subst InScopeSet		-- In scope
 	--
 	-- INVARIANT 2: No variable is both in scope and in the domain of the substitution
 	--		Equivalently, the substitution is idempotent
-	--
+	--	[Sep 2000: Lies, all lies.  The substitution now does contain
+	--		   mappings x77 -> DoneId x77 occ
+	--		   to record x's occurrence information.]
+	-- 	[Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
+	--	 Consider let x = case k of I# x77 -> ... in
+	--		  let y = case k of I# x77 -> ... in ...
+	--	 and suppose the body is strict in both x and y.  Then the simplifier
+	--	 will pull the first (case k) to the top; so the second (case k) will
+	--	 cancel out, mapping x77 to, well, x77!  But one is an in-Id and the 
+	--	 other is an out-Id. So the substitution is idempotent in the sense
+	--	 that we *must not* repeatedly apply it.]
 
 type IdSubst    = Subst
 \end{code}
@@ -180,7 +191,7 @@ The general plan about the substitution and in-scope set for Ids is as follows
   That is added back in later.  So new_id is the minimal thing it's 
   correct to substitute.
 
-* substId adds a binding (DoneVar new_id occ) to the substitution if 
+* substId adds a binding (DoneId new_id occ) to the substitution if 
 	EITHER the Id's unique has changed
 	OR     the Id has interesting occurrence information
   So in effect you can only get to interesting occurrence information
@@ -321,6 +332,25 @@ setSubstEnv :: Subst 		-- Take in-scope part from here
 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
 \end{code}
 
+Pretty printing, for debugging only
+
+\begin{code}
+instance Outputable SubstResult where
+  ppr (DoneEx e)   = ptext SLIT("DoneEx") <+> ppr e
+  ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
+  ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
+  ppr (DoneTy t)   = ptext SLIT("DoneTy") <+> ppr t
+
+instance Outputable SubstEnv where
+  ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
+	where
+	   ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
+
+instance Outputable Subst where
+  ppr (Subst (InScope in_scope _) se) 
+	=  ptext SLIT("<InScope =") <+> braces   (fsep (map ppr (rngVarEnv in_scope)))
+	$$ ptext SLIT(" Subst   =") <+> ppr se <> char '>'
+\end{code}
 
 %************************************************************************
 %*									*
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 235593c..85c1c4d 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -24,7 +24,7 @@ import CmdLineOpts	( switchIsOn, SimplifierSwitch(..),
 import CoreSyn
 import CoreUnfold	( isValueUnfolding )
 import CoreUtils	( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
-import Subst		( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
+import Subst		( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
 import Id		( Id, idType, isId, idName, 
 			  idOccInfo, idUnfolding, idStrictness,
 			  mkId, idInfo
@@ -265,27 +265,24 @@ interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
 	-- (i.e. they are probably lambda bound): f x y z
 	-- There is little point in inlining f here.
 interestingArg in_scope arg subst
-  = analyse arg
+  = analyse (substExpr (mkSubst in_scope subst) arg)
+	-- 'analyse' only looks at the top part of the result
+	-- and substExpr is lazy, so this isn't nearly as brutal
+	-- as it looks.
   where
-    analyse (Var v)
-	= case lookupIdSubst (mkSubst in_scope subst) v of
-	    ContEx subst arg -> interestingArg in_scope arg subst
-	    DoneEx arg	     -> analyse arg
-	    DoneId v' _      -> hasSomeUnfolding (idUnfolding v')
+    analyse (Var v)	      = hasSomeUnfolding (idUnfolding v)
 				-- Was: isValueUnfolding (idUnfolding v')
 				-- But that seems over-pessimistic
-
-	-- NB: it's too pessimistic to return False for ContEx/DoneEx
-	-- Consider 	let x = 3 in f x
-	-- The substitution will contain (x -> ContEx 3)
-	-- It's also too optimistic to return True for the ContEx/DoneEx case
-	-- Consider (\x. f x y) y
-	-- The substitution will contain (x -> ContEx y).
-
     analyse (Type _)	      = False
     analyse (App fn (Type _)) = analyse fn
     analyse (Note _ a)	      = analyse a
     analyse other	      = True
+	-- Consider 	let x = 3 in f x
+	-- The substitution will contain (x -> ContEx 3), and we want to
+	-- to say that x is an interesting argument.
+	-- But consider also (\x. f x y) y
+	-- The substitution will contain (x -> ContEx y), and we want to say
+	-- that x is not interesting (assuming y has no unfolding)
 \end{code}
 
 Comment about interestingCallContext