From e517644d3a3272f4306654d0f50db28c664a9a8b Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 23 Nov 2007 15:35:19 +0000
Subject: [PATCH] Tidy and trim the type environment in mkBootModDetails

Should fix Trac #1833

We were failing to trim the type envt in mkBootModDetails, so several
functions all called (*), for example, were getting into the interface.
Result chaos.  It only actually bites when we do the retyping-loop thing,
which is why it's gone so long without a fix.
---
 compiler/main/TidyPgm.lhs |   70 +++++++++++++++++++++++++++++----------------
 1 file changed, 46 insertions(+), 24 deletions(-)

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index e327996..1f65d21 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -138,10 +138,9 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
 	; showPass dflags "Tidy [hoot] type env"
 
 	; let { insts'     = tidyInstances tidyExternalId insts
-	      ; type_env1  = filterNameEnv (not . isWiredInThing) type_env
-	      ; type_env2  = mapNameEnv tidyBootThing type_env1
-	      ; type_env'  = extendTypeEnvWithIds type_env2
-				(map instanceDFunId insts')
+	      ; dfun_ids   = map instanceDFunId insts'
+	      ; type_env1  = tidyBootTypeEnv (availsToNameSet exports) type_env
+	      ; type_env'  = extendTypeEnvWithIds type_env1 dfun_ids
 	      }
 	; return (ModDetails { md_types     = type_env'
 			     , md_insts     = insts'
@@ -153,13 +152,27 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
 	}
   where
 
-isWiredInThing :: TyThing -> Bool
-isWiredInThing thing = isWiredInName (getName thing)
+tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
+tidyBootTypeEnv exports type_env 
+  = tidyTypeEnv True exports type_env final_ids
+  where
+	-- Find the LocalIds in the type env that are exported
+	-- Make them into GlobalIds, and tidy their types
+	--
+	-- It's very important to remove the non-exported ones
+	-- because we don't tidy the OccNames, and if we don't remove
+	-- the non-exported ones we'll get many things with the
+	-- same name in the interface file, giving chaos.
+    final_ids = [ tidyExternalId id
+		| id <- typeEnvIds type_env
+		, isLocalId id
+		, keep_it id ]
+
+        -- default methods have their export flag set, but everything
+        -- else doesn't (yet), because this is pre-desugaring, so we
+        -- must test both.
+    keep_it id = isExportedId id || idName id `elemNameSet` exports
 
-tidyBootThing :: TyThing -> TyThing
--- Just externalise the Ids; keep everything
-tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
-tidyBootThing thing		       = thing
 
 tidyExternalId :: Id -> Id
 -- Takes an LocalId with an External Name, 
@@ -277,8 +290,10 @@ tidyProgram hsc_env
 						 binds
 
 	; let { export_set = availsToNameSet exports
+	      ; final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
+				    isExternalName (idName id)]
               ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env 
-					    tidy_binds
+					    final_ids
 	      ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
 		-- A DFunId will have a binding in tidy_binds, and so
 		-- will now be in final_env, replete with IdInfo
@@ -327,7 +342,8 @@ lookup_dfun type_env dfun_id
 	Just (AnId dfun_id') -> dfun_id'
 	_other -> pprPanic "lookup_dfun" (ppr dfun_id)
 
-tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
+--------------------------
+tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv
 
 -- The competed type environment is gotten from
 --	Dropping any wired-in things, and then
@@ -341,17 +357,14 @@ tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
 -- This truncates the type environment to include only the 
 -- exported Ids and things needed from them, which saves space
 
-tidyTypeEnv omit_prags exports type_env tidy_binds
+tidyTypeEnv omit_prags exports type_env final_ids
   = let type_env1 = filterNameEnv keep_it type_env
 	type_env2 = extendTypeEnvWithIds type_env1 final_ids
-	type_env3 | omit_prags = mapNameEnv trim_thing type_env2
+	type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2
 		  | otherwise  = type_env2
     in 
     type_env3
   where
-    final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
-			isExternalName (idName id)]
-
    	-- We keep GlobalIds, because they won't appear 
 	-- in the bindings from which final_ids are derived!
 	-- (The bindings bind LocalIds.)
@@ -359,15 +372,24 @@ tidyTypeEnv omit_prags exports type_env tidy_binds
     keep_it (AnId id) = isGlobalId id	-- Keep GlobalIds (e.g. class ops)
     keep_it _other    = True		-- Keep all TyCons, DataCons, and Classes
 
-    trim_thing thing
-	= case thing of
-	    ATyCon tc | mustExposeTyCon exports tc -> thing
-		      | otherwise -> ATyCon (makeTyConAbstract tc)
+--------------------------
+isWiredInThing :: TyThing -> Bool
+isWiredInThing thing = isWiredInName (getName thing)
+
+--------------------------
+trimThing :: NameSet -> TyThing -> TyThing
+-- Trim off inessentials, for boot files and no -O
+trimThing exports (ATyCon tc)
+   | not (mustExposeTyCon exports tc)
+   = ATyCon (makeTyConAbstract tc)
+
+trimThing _exports (AnId id)
+   | not (isImplicitId id) 
+   = AnId (id `setIdInfo` vanillaIdInfo)
 
-	    AnId id | isImplicitId id -> thing
-		    | otherwise	      -> AnId (id `setIdInfo` vanillaIdInfo)
+trimThing _exports other_thing 
+  = other_thing
 
-	    _other -> thing
 
 mustExposeTyCon :: NameSet	-- Exports
 		-> TyCon	-- The tycon
-- 
1.7.10.4