From 24f4a27a09e78309bcd09832bca4284f67661a7a Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 29 Apr 1998 09:30:21 +0000
Subject: [PATCH] [project @ 1998-04-29 09:30:16 by simonpj] Alleged fix to
 SpecEnv muddle for recursive bindings

---
 ghc/compiler/simplCore/OccurAnal.lhs |    6 +++++-
 ghc/compiler/simplCore/SimplEnv.lhs  |   18 +++++++++---------
 2 files changed, 14 insertions(+), 10 deletions(-)

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}
 
 
-- 
1.7.10.4