#include "HsVersions.h"
-import DynFlags ( DynFlags, DynFlag(..), dopt )
+import DynFlags ( DynFlag(..), dopt )
+import Packages ( HomeModules )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
- isExportedId, mkVanillaGlobal, isLocalId,
+ isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector,
idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo
)
import IdInfo {- loads of stuff -}
import NewDemand ( isBottomingSig, topSig )
import BasicTypes ( Arity, isNeverActive )
import Name ( Name, getOccName, nameOccName, mkInternalName,
- localiseName, isExternalName, nameSrcLoc, nameParent_maybe
+ localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
+ isWiredInName, getName
)
import NameSet ( NameSet, elemNameSet )
import IfaceEnv ( allocateGlobalBinder )
import TcType ( isFFITy )
import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon,
- newTyConRep, tyConSelIds, isAlgTyCon )
+ newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon )
import Class ( classSelIds )
import Module ( Module )
import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
- ; let { ispecs' = tidyInstances tidyExternalId ispecs
- ; type_env1 = mapNameEnv tidyBootThing type_env
- ; type_env' = extendTypeEnvWithIds type_env1
+ ; let { ispecs' = tidyInstances tidyExternalId ispecs
+ ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
+ ; type_env2 = mapNameEnv tidyBootThing type_env1
+ ; type_env' = extendTypeEnvWithIds type_env2
(map instanceDFunId ispecs')
}
; return (ModDetails { md_types = type_env',
md_rules = [],
md_exports = exports })
}
+ where
+
+isWiredInThing :: TyThing -> Bool
+isWiredInThing thing = isWiredInName (getName thing)
tidyBootThing :: TyThing -> TyThing
-- Just externalise the Ids; keep everything
mg_binds = binds,
mg_rules = imp_rules,
mg_dir_imps = dir_imps, mg_deps = deps,
+ mg_home_mods = home_mods,
mg_foreign = foreign_stubs })
= do { let dflags = hsc_dflags hsc_env
-- (It's a sort of mutual recursion.)
}
- ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds
; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
cg_binds = implicit_binds ++ tidy_binds,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
+ cg_home_mods = home_mods,
cg_dep_pkgs = dep_pkgs deps },
ModDetails { md_types = tidy_type_env,
-- We keep GlobalIds, because they won't appear
-- in the bindings from which final_ids are derived!
-- (The bindings bind LocalIds.)
+ keep_it thing | isWiredInThing thing = False
keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
keep_it other = True -- Keep all TyCons, DataCons, and Classes
mustExposeTyCon exports tc
| not (isAlgTyCon tc) -- Synonyms
= True
+ | isEnumerationTyCon tc -- For an enumeration, exposing the constructors
+ = True -- won't lead to the need for further exposure
+ -- (This includes data types with no constructors.)
| otherwise -- Newtype, datatype
= any exported_con (tyConDataCons tc)
-- Expose rep if any datacon or field is exported
where
implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
- other_implicit_ids (ATyCon tc) = tyConSelIds tc
+ other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
+ -- The "naughty" ones are not real functions at all
+ -- They are there just so we can get decent error messages
+ -- See Note [Naughty record selectors] in MkId.lhs
other_implicit_ids (AClass cl) = classSelIds cl
other_implicit_ids other = []
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
tidyTopBinds :: HscEnv
+ -> HomeModules
-> Module
-> TypeEnv
-> IdEnv Bool -- Domain = Ids that should be external
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
-tidyTopBinds hsc_env mod type_env ext_ids binds
+tidyTopBinds hsc_env hmods mod type_env ext_ids binds
= tidy init_env binds
where
- dflags = hsc_dflags hsc_env
nc_var = hsc_NC hsc_env
-- We also make sure to avoid any exported binders. Consider
-- The type environment is a convenient source of such things.
tidy env [] = return (env, [])
- tidy env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b
+ tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b
; (env2, bs') <- tidy env1 bs
; return (env2, b':bs') }
------------------------
-tidyTopBind :: DynFlags
+tidyTopBind :: HomeModules
-> Module
-> IORef NameCache -- For allocating new unique names
-> IdEnv Bool -- Domain = Ids that should be external
-> TidyEnv -> CoreBind
-> IO (TidyEnv, CoreBind)
-tidyTopBind dflags mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
+tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
= do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
; subst2 = extendVarEnv subst1 bndr bndr'
; tidy_env2 = (occ_env2, subst2) }
; return (tidy_env2, NonRec bndr' rhs') }
where
- caf_info = hasCafRefs dflags subst1 (idArity bndr) rhs
+ caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs
-tidyTopBind dflags mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
+tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
= do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
names' prs
-- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do).
caf_info
- | or [ mayHaveCafRefs (hasCafRefs dflags subst1 (idArity bndr) rhs)
+ | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
CAF list to keep track of non-collectable CAFs.
\begin{code}
-hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
-hasCafRefs dflags p arity expr
+hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
+hasCafRefs hmods p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (arity > 0 || rhsIsStatic dflags expr)
+ is_caf = not (arity > 0 || rhsIsStatic hmods expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
projects / ghc-hetmet.git / blobdiff