X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FTidyPgm.lhs;h=0af2ca760a498e7184a226384ce53e211ed33944;hb=0c53bd0e1b02dea0bde32cd7eb8ccb5ee2d3719e;hp=ca7bceda38b797be7d93fe27d4d3b9acea35e3ca;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;p=ghc-hetmet.git diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index ca7bced..0af2ca7 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -4,11 +4,11 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( simpleTidyPgm, optTidyPgm ) where +module TidyPgm( mkBootModDetails, tidyProgram ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) @@ -21,7 +21,7 @@ import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, isExportedId, mkVanillaGlobal, isLocalId, - idArity, idCafInfo + idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo ) import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) @@ -33,16 +33,19 @@ import Name ( Name, getOccName, nameOccName, mkInternalName, ) import NameSet ( NameSet, elemNameSet ) import IfaceEnv ( allocateGlobalBinder ) -import NameEnv ( filterNameEnv ) +import NameEnv ( filterNameEnv, mapNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import TcType ( isFFITy ) -import DataCon ( dataConName, dataConFieldLabels ) -import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, newTyConRep ) +import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe ) +import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, + newTyConRep, tyConSelIds, isAlgTyCon ) +import Class ( classSelIds ) import Module ( Module ) -import HscTypes ( HscEnv(..), NameCache( nsUniqs ), - TypeEnv, typeEnvIds, typeEnvElts, extendTypeEnvWithIds, mkTypeEnv, - ModGuts(..), ModGuts, TyThing(..) +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), + TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, + extendTypeEnvWithIds, lookupTypeEnv, + ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) ) import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) @@ -79,15 +82,12 @@ of TyThings. %************************************************************************ -Plan A: simpleTidyPgm: omit pragmas, make interfaces small +Plan A: mkBootModDetails: omit pragmas, make interfaces small ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Ignore the bindings * Drop all WiredIn things from the TypeEnv (we never want them in interface files) - (why are they there? I think mainly as a memo - to avoid repeatedly checking that we've loaded their - home interface; but I'm not certain) * Retain all TyCons and Classes in the TypeEnv, to avoid having to find which ones are mentioned in the @@ -107,63 +107,46 @@ Plan A: simpleTidyPgm: omit pragmas, make interfaces small * Drop rules altogether -* Leave the bindings untouched. There's no need to make the Ids - in the bindings into Globals, think, ever. - +* Tidy the bindings, to ensure that the Caf and Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting \begin{code} -simpleTidyPgm :: HscEnv -> ModGuts -> IO ModGuts +mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails -- This is Plan A: make a small type env when typechecking only, -- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files -simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_exports = exports, - mg_types = type_env, - mg_insts = ispecs }) +mkBootModDetails hsc_env (ModGuts { mg_module = mod, + mg_exports = exports, + mg_types = type_env, + mg_insts = ispecs }) = do { let dflags = hsc_dflags hsc_env - ; showPass dflags "Tidy Type Env" - - ; let { ispecs' = tidyInstances tidyExternalId ispecs - - ; things' = mapCatMaybes (tidyThing exports) - (typeEnvElts type_env) + ; showPass dflags "Tidy [hoot] type env" - ; type_env' = extendTypeEnvWithIds (mkTypeEnv things') - (map instanceDFunId ispecs') + ; 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 (mod_impl { mg_types = type_env' - , mg_insts = ispecs' - , mg_rules = [] }) + ; return (ModDetails { md_types = type_env', + md_insts = ispecs', + md_rules = [], + md_exports = exports }) } - -tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] -tidyInstances tidy_dfun ispecs - = map tidy ispecs where - tidy ispec = setInstanceDFunId ispec (tidy_dfun (instanceDFunId ispec)) -tidyThing :: NameSet -- Exports - -> TyThing -> Maybe TyThing -- Nothing => drop it -tidyThing exports thing - | isWiredInName (getName thing) - = Nothing - | otherwise - = case thing of - AClass cl -> Just thing +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) - ATyCon tc - | mustExposeTyCon exports tc -> Just thing - | otherwise -> Just (ATyCon (makeTyConAbstract tc)) - - ADataCon dc - | getName dc `elemNameSet` exports -> Just thing - | otherwise -> Nothing - - AnId id - | not (getName id `elemNameSet` exports) -> Nothing - | not (isLocalId id) -> Just thing -- Implicit Ids such as class ops, - -- data-con wrappers etc - | otherwise -> Just (AnId (tidyExternalId id)) +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, @@ -172,25 +155,6 @@ tidyExternalId :: Id -> Id tidyExternalId id = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo - -mustExposeTyCon :: NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as --- possible into the interface file. But we must expose the details of --- any data types whose constructors or fields are exported -mustExposeTyCon exports tc - = any exported_con (tyConDataCons tc) - -- Expose rep if any datacon or field is exported - - || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) - -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation - where - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) \end{code} @@ -266,35 +230,47 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -optTidyPgm :: HscEnv -> ModGuts -> IO ModGuts +tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram hsc_env + mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, + mg_types = type_env, mg_insts = insts_tc, + mg_binds = binds, + mg_rules = imp_rules, + mg_dir_imps = dir_imps, mg_deps = deps, + mg_home_mods = home_mods, + mg_foreign = foreign_stubs }) -optTidyPgm hsc_env - mod_impl@(ModGuts { mg_module = mod, - mg_types = env_tc, mg_insts = insts_tc, - mg_binds = binds_in, - mg_rules = imp_rules }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy Core" - ; let ext_ids = findExternalIds binds_in - ; let ext_rules = findExternalRules binds_in imp_rules ext_ids + ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; ext_ids = findExternalIds omit_prags binds + ; ext_rules + | omit_prags = [] + | otherwise = findExternalRules binds imp_rules ext_ids -- findExternalRules filters imp_rules to avoid binders that -- aren't externally visible; but the externally-visible binders -- are computed (by findExternalIds) assuming that all orphan -- rules are exported (they get their Exported flag set in the desugarer) -- So in fact we may export more than we need. -- (It's a sort of mutual recursion.) + } - ; (final_env, tidy_binds) <- tidyTopBinds hsc_env mod env_tc - ext_ids binds_in + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds - ; let { tidy_rules = tidyRules final_env ext_rules - ; tidy_type_env = tidyTypeEnv env_tc tidy_binds - ; tidy_ispecs = tidyInstances (tidyVarOcc final_env) insts_tc + ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds + ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc -- A DFunId will have a binding in tidy_binds, and so -- will now be in final_env, replete with IdInfo -- Its name will be unchanged since it was born, but - -- we want Global, IdInfo-rich DFunId in the tidy_ispecs + -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs + + ; tidy_rules = tidyRules tidy_env ext_rules + -- You might worry that the tidy_env contains IdInfo-rich stuff + -- and indeed it does, but if omit_prags is on, ext_rules is empty + + ; implicit_binds = getImplicitBinds type_env + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds @@ -302,16 +278,26 @@ optTidyPgm hsc_env "Tidy Core Rules" (pprRules tidy_rules) - ; return (mod_impl { mg_types = tidy_type_env, - mg_rules = tidy_rules, - mg_insts = tidy_ispecs, - mg_binds = tidy_binds }) + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + 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, + md_rules = tidy_rules, + md_insts = tidy_ispecs, + md_exports = exports }) } +lookup_dfun type_env dfun_id + = case lookupTypeEnv type_env (idName dfun_id) of + Just (AnId dfun_id') -> dfun_id' + other -> pprPanic "lookup_dfun" (ppr dfun_id) -tidyTypeEnv :: TypeEnv -- From typechecker - -> [CoreBind] -- Final Ids - -> TypeEnv +tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv -- The competed type environment is gotten from -- Dropping any wired-in things, and then @@ -325,22 +311,87 @@ tidyTypeEnv :: TypeEnv -- From typechecker -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv type_env tidy_binds - = extendTypeEnvWithIds (filterNameEnv keep_it type_env) final_ids +tidyTypeEnv omit_prags exports type_env tidy_binds + = let type_env1 = filterNameEnv keep_it type_env + type_env2 = extendTypeEnvWithIds type_env1 final_ids + type_env3 | omit_prags = mapNameEnv trim_thing type_env2 + | otherwise = type_env2 + in + type_env3 where - final_ids = [ id - | bind <- tidy_binds, - id <- bindersOf bind, - isExternalName (idName id)] + final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] - -- We keep GlobalIds, because they won't appear + -- We keep GlobalIds, because they won't appear -- in the bindings from which final_ids are derived! -- (The bindings bind LocalIds.) - keep_it thing | isWiredInName (getName thing) = False + 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 + + trim_thing thing + = case thing of + ATyCon tc | mustExposeTyCon exports tc -> thing + | otherwise -> ATyCon (makeTyConAbstract tc) + + AnId id | isImplicitId id -> thing + | otherwise -> AnId (id `setIdInfo` vanillaIdInfo) + + other -> thing + +mustExposeTyCon :: NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon exports tc + | not (isAlgTyCon tc) -- Synonyms + = True + | otherwise -- Newtype, datatype + = any exported_con (tyConDataCons tc) + -- Expose rep if any datacon or field is exported + + || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + where + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) + +tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] +tidyInstances tidy_dfun ispecs + = map tidy ispecs + where + tidy ispec = setInstanceDFunId ispec $ + tidy_dfun (instanceDFunId ispec) + +getImplicitBinds :: TypeEnv -> [CoreBind] +getImplicitBinds type_env + = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) + ++ concatMap other_implicit_ids (typeEnvElts type_env)) + -- Put the constructor wrappers first, because + -- other implicit bindings (notably the fromT functions arising + -- from generics) use the constructor wrappers. At least that's + -- what External Core likes + where + implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + + other_implicit_ids (ATyCon tc) = tyConSelIds tc + other_implicit_ids (AClass cl) = classSelIds cl + other_implicit_ids other = [] + + get_defn :: Id -> CoreBind + get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs) + where + rhs = unfoldingTemplate (idUnfolding id) + -- Don't forget to tidy the body ! Otherwise you get silly things like + -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl \end{code} + %************************************************************************ %* * \subsection{Step 1: finding externals} @@ -348,11 +399,16 @@ tidyTypeEnv type_env tidy_binds %************************************************************************ \begin{code} -findExternalIds :: [CoreBind] +findExternalIds :: Bool + -> [CoreBind] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalIds binds +findExternalIds omit_prags binds + | omit_prags + = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ] + + | otherwise = foldr find emptyVarEnv binds where find (NonRec id rhs) needed @@ -472,14 +528,14 @@ findExternalRules binds non_local_rules ext_ids tidyTopBinds :: HscEnv -> Module - -> TypeEnv + -> TypeEnv -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too -> [CoreBind] -> IO (TidyEnv, [CoreBind]) -tidyTopBinds hsc_env mod env_tc ext_ids binds - = go init_env binds +tidyTopBinds hsc_env mod type_env ext_ids binds + = tidy init_env binds where dflags = hsc_dflags hsc_env nc_var = hsc_NC hsc_env @@ -493,7 +549,7 @@ tidyTopBinds hsc_env mod env_tc ext_ids binds -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. init_env = (initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, + avoids = [getOccName name | bndr <- typeEnvIds type_env, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include @@ -503,10 +559,10 @@ tidyTopBinds hsc_env mod env_tc ext_ids binds -- since their names are "taken". -- The type environment is a convenient source of such things. - go env [] = return (env, []) - go env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b - ; (env2, bs') <- go env1 bs - ; return (env2, b':bs') } + tidy env [] = return (env, []) + tidy env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b + ; (env2, bs') <- tidy env1 bs + ; return (env2, b':bs') } ------------------------ tidyTopBind :: DynFlags @@ -622,9 +678,10 @@ tidyTopPair :: VarEnv Bool -- in the IdInfo of one early in the group tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) - = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - (bndr', rhs') + | isGlobalId bndr -- Injected binding for record selector, etc + = (bndr, tidyExpr rhs_tidy_env rhs) + | otherwise + = (bndr', rhs') where bndr' = mkVanillaGlobal name' ty' idinfo' ty' = tidyTopType (idType bndr)