X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=976c32e1669ddccba547c6846db0fb9b988aca65;hb=a35f75aa20bf0a329be0b782986c3e12155b4d49;hp=86e55f9e0654c891e702223398c8554cbdd5d274;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 86e55f9..976c32e 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -8,8 +8,7 @@ module TidyPgm( mkBootModDetails, tidyProgram ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), dopt ) -import Packages ( HomeModules ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) @@ -27,7 +26,7 @@ import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) -import BasicTypes ( Arity, isNeverActive ) +import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker ) import Name ( Name, getOccName, nameOccName, mkInternalName, localiseName, isExternalName, nameSrcLoc, nameParent_maybe, isWiredInName, getName @@ -40,16 +39,20 @@ import Type ( tidyTopType ) import TcType ( isFFITy ) import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe ) import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, - newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon ) + newTyConRep, tyConSelIds, isAlgTyCon, + isEnumerationTyCon, isOpenTyCon ) import Class ( classSelIds ) import Module ( Module ) import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, extendTypeEnvWithIds, lookupTypeEnv, - ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) + mkDetailsFamInstCache, + ModGuts(..), TyThing(..), ModDetails(..), + Dependencies(..) ) import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) +import PackageConfig ( PackageId ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Maybe ( isJust ) @@ -134,10 +137,11 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod, ; type_env' = extendTypeEnvWithIds type_env2 (map instanceDFunId ispecs') } - ; return (ModDetails { md_types = type_env', - md_insts = ispecs', - md_rules = [], - md_exports = exports }) + ; return (ModDetails { md_types = type_env', + md_insts = ispecs', + md_fam_insts = mkDetailsFamInstCache type_env', + md_rules = [], + md_exports = exports }) } where @@ -238,7 +242,6 @@ tidyProgram hsc_env 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 @@ -257,7 +260,7 @@ tidyProgram hsc_env -- (It's a sort of mutual recursion.) } - ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env 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 @@ -271,25 +274,27 @@ tidyProgram hsc_env -- and indeed it does, but if omit_prags is on, ext_rules is empty ; implicit_binds = getImplicitBinds type_env + ; all_tidy_binds = implicit_binds ++ tidy_binds ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprRules tidy_rules) ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, - cg_binds = implicit_binds ++ tidy_binds, + cg_binds = all_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, md_rules = tidy_rules, md_insts = tidy_ispecs, + md_fam_insts = mkDetailsFamInstCache + tidy_type_env, md_exports = exports }) } @@ -352,6 +357,8 @@ mustExposeTyCon exports tc | 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.) + | isOpenTyCon tc -- open type family + = True | otherwise -- Newtype, datatype = any exported_con (tyConDataCons tc) -- Expose rep if any datacon or field is exported @@ -444,9 +451,10 @@ addExternal (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where - add_occ id needed = extendVarEnv needed id False + add_occ id needed | id `elemVarEnv` needed = needed + | otherwise = extendVarEnv needed id False -- "False" because we don't know we need the Id's unfolding - -- We'll override it later when we find the binding site + -- Don't override existing bindings; we might have already set it to True new_needed_ids = worker_ids `unionVarSet` unfold_ids `unionVarSet` @@ -454,7 +462,7 @@ addExternal (id,rhs) needed idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) - loop_breaker = isLoopBreaker (occInfo idinfo) + loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo @@ -534,7 +542,6 @@ findExternalRules binds non_local_rules ext_ids -- * 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 @@ -542,7 +549,7 @@ tidyTopBinds :: HscEnv -> [CoreBind] -> IO (TidyEnv, [CoreBind]) -tidyTopBinds hsc_env hmods mod type_env ext_ids binds +tidyTopBinds hsc_env mod type_env ext_ids binds = tidy init_env binds where nc_var = hsc_NC hsc_env @@ -566,13 +573,15 @@ tidyTopBinds hsc_env hmods mod type_env ext_ids binds -- since their names are "taken". -- The type environment is a convenient source of such things. + this_pkg = thisPackage (hsc_dflags hsc_env) + tidy env [] = return (env, []) - tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b + tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b ; (env2, bs') <- tidy env1 bs ; return (env2, b':bs') } ------------------------ -tidyTopBind :: HomeModules +tidyTopBind :: PackageId -> Module -> IORef NameCache -- For allocating new unique names -> IdEnv Bool -- Domain = Ids that should be external @@ -580,16 +589,16 @@ tidyTopBind :: HomeModules -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) -tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) +tidyTopBind this_pkg 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 hmods subst1 (idArity bndr) rhs + caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs -tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) +tidyTopBind this_pkg 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 @@ -602,7 +611,7 @@ tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec 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 hmods subst1 (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -778,13 +787,13 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs hmods p arity expr +hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (arity > 0 || rhsIsStatic hmods expr) + is_caf = not (arity > 0 || rhsIsStatic this_pkg 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 @@ -806,6 +815,7 @@ cafRefs p (Lam x e) = cafRefs p e cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) cafRefs p (Note n e) = cafRefs p e +cafRefs p (Cast e co) = cafRefs p e cafRefs p (Type t) = fastBool False cafRefss p [] = fastBool False