From: simonpj <unknown>
Date: Wed, 29 Apr 1998 09:30:21 +0000 (+0000)
Subject: [project @ 1998-04-29 09:30:16 by simonpj]
X-Git-Tag: Approx_2487_patches~764
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=24f4a27a09e78309bcd09832bca4284f67661a7a;p=ghc-hetmet.git

[project @ 1998-04-29 09:30:16 by simonpj]
Alleged fix to SpecEnv muddle for recursive bindings
---

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 74a36af..791eee6 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -22,7 +22,7 @@ import CmdLineOpts	( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
 import Digraph		( stronglyConnCompR, SCC(..) )
 import Id		( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
-			  omitIfaceSigForId, isSpecPragmaId,
+			  omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
 			  idType, idUnique, Id,
 			  emptyIdSet, unionIdSets, mkIdSet,
 			  elementOfIdSet,
@@ -33,6 +33,7 @@ import Id		( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
 			  mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
 			)
 import Specialise       ( idSpecVars )
+import SpecEnv		( isEmptySpecEnv )
 import Name		( isExported, isLocallyDefined )
 import Type		( splitFunTy_maybe, splitForAllTys )
 import Maybes		( maybeToBool )
@@ -459,6 +460,9 @@ reOrderRec env (CyclicSCC binds)
 	  || inlineMe env bndr		-- Dont pick INLINE thing
 	  || isOneFunOcc occ_info	-- Dont pick single-occ thing
 	  || not_fun_ty (idType bndr)	-- Dont pick data-ty thing
+	  || not (isEmptySpecEnv (getIdSpecialisation bndr))
+		-- Avoid things with a SpecEnv; we'd like
+		-- to take advantage of the SpecEnv in the subsuequent bindings
 
 	-- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
 	-- We stick to just FunOccs because if we're not going to be able
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 95bd9c8..3c511f4 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -413,15 +413,15 @@ lookupUnfolding env id
 	Just (_,_,info) -> info
 	Nothing		-> NoUnfolding
 
-modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
-	         -> (OutId, BinderInfo, Unfolding) 
-	         -> (OutId, BinderInfo, Unfolding)
-modifyOutEnvItem (id, occ, info1) (_, _, info2)
-  = case (info1, info2) of
-		(OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
-		(OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
-		(_,            NoUnfolding)  -> (id,occ, info1)
-		other	       		     -> (id,occ, info2)
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)	-- Existing
+	         -> (OutId, BinderInfo, Unfolding) 	-- New
+	         -> (OutId, BinderInfo, Unfolding)	
+modifyOutEnvItem (_, _, info1) (id, occ, info2)
+  = (id, occ, case (info1, info2) of
+		(OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
+		(OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
+		(_,            NoUnfolding)  -> info1
+		other	       		     -> info2)
 \end{code}