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.

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index e327996..1f65d21 100644 (file)
--- 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
        ; 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'
              }
        ; return (ModDetails { md_types     = type_env'
                             , md_insts     = insts'

@@ -153,13 +152,27 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
        }
   where
 
        }
   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, 
 
 tidyExternalId :: Id -> Id
 -- Takes an LocalId with an External Name, 

@@ -277,8 +290,10 @@ tidyProgram hsc_env
                                                 binds
 
        ; let { export_set = availsToNameSet exports
                                                 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_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
              ; 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)
 
        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
 
 -- 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
 
 -- 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
   = 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
                  | 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.)
        -- 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
 
     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
 
 mustExposeTyCon :: NameSet     -- Exports
                -> TyCon        -- The tycon