From c24011d1744b4fdd81847136ddfe7eda9fda2229 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 28 Apr 2005 23:00:52 +0000 Subject: [PATCH] [project @ 2005-04-28 23:00:52 by simonpj] Further wibbles to the new tidying plumbing --- ghc/compiler/basicTypes/NameEnv.lhs | 4 +- ghc/compiler/main/HscMain.lhs | 9 +- ghc/compiler/main/TidyPgm.lhs | 314 ++++++++++++++++++----------------- 3 files changed, 165 insertions(+), 162 deletions(-) diff --git a/ghc/compiler/basicTypes/NameEnv.lhs b/ghc/compiler/basicTypes/NameEnv.lhs index 537e597..a125f61 100644 --- a/ghc/compiler/basicTypes/NameEnv.lhs +++ b/ghc/compiler/basicTypes/NameEnv.lhs @@ -11,7 +11,7 @@ module NameEnv ( foldNameEnv, filterNameEnv, plusNameEnv, plusNameEnv_C, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv + elemNameEnv, mapNameEnv ) where #include "HsVersions.h" @@ -47,6 +47,7 @@ lookupNameEnv :: NameEnv a -> Name -> Maybe a lookupNameEnv_NF :: NameEnv a -> Name -> a foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 emptyNameEnv = emptyUFM foldNameEnv = foldUFM @@ -63,6 +64,7 @@ delListFromNameEnv = delListFromUFM elemNameEnv = elemUFM unitNameEnv = unitUFM filterNameEnv = filterUFM +mapNameEnv = mapUFM lookupNameEnv = lookupUFM lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index bd6bc43..13af006 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -61,7 +61,7 @@ import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar import Flattening ( flatten ) import SimplCore -import TidyPgm ( optTidyPgm, simpleTidyPgm ) +import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import TyCon ( isDataTyCon ) @@ -356,7 +356,7 @@ hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing = return HscFail hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) - = do { (_cg_guts, details) <- simpleTidyPgm hsc_env ds_result + = do { details <- mkBootModDetails hsc_env ds_result ; (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} @@ -428,11 +428,8 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) ------------------- -- TIDY ------------------- - ; let omit_prags = dopt Opt_OmitInterfacePragmas dflags ; (cg_guts, details) <- {-# SCC "CoreTidy" #-} - if omit_prags - then simpleTidyPgm hsc_env simpl_result - else optTidyPgm hsc_env simpl_result + tidyProgram hsc_env simpl_result -- Alive at this point: -- tidy_result, pcs_final diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index b4f560c..8937903 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,30 +21,29 @@ import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, isExportedId, mkVanillaGlobal, isLocalId, - idArity, idCafInfo, idUnfolding + idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo ) import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) import Name ( Name, getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc, nameParent_maybe, - isWiredInName, getName + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) 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, dataConWrapId_maybe ) import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, - newTyConRep, isDataTyCon, tyConSelIds, isAlgTyCon ) + newTyConRep, tyConSelIds, isAlgTyCon ) import Class ( classSelIds ) import Module ( Module ) import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, - extendTypeEnvWithIds, mkTypeEnv, + extendTypeEnvWithIds, lookupTypeEnv, ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) ) import Maybes ( orElse, mapCatMaybes ) @@ -82,15 +81,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 @@ -116,65 +112,35 @@ Plan A: simpleTidyPgm: omit pragmas, make interfaces small distinct OccNames in case of object-file splitting \begin{code} -simpleTidyPgm :: HscEnv -> ModGuts - -> IO (CgGuts, ModDetails) +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_module = mod, - mg_exports = exports, - mg_types = type_env, - mg_insts = ispecs, - mg_binds = binds }) +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" + ; showPass dflags "Tidy [hoot] type env" ; let { ispecs' = tidyInstances tidyExternalId ispecs - - ; things' = mapCatMaybes (tidyThing exports) - (typeEnvElts type_env) - - ; type_env' = extendTypeEnvWithIds (mkTypeEnv things') - (map instanceDFunId ispecs') - ; ext_ids = mkVarEnv [ (id, False) | id <- typeEnvIds type_env'] + ; type_env1 = mapNameEnv tidyBootThing type_env + ; type_env' = extendTypeEnvWithIds type_env1 + (map instanceDFunId ispecs') } - - ; (_, cg_guts) <- tidyCgStuff hsc_env ext_ids mod_impl - - ; return (cg_guts, ModDetails { md_types = type_env' - , md_insts = ispecs' - , md_rules = [] - , md_exports = exports }) + ; 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 - - 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, @@ -183,28 +149,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 - | 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) \end{code} @@ -280,52 +224,72 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -optTidyPgm :: HscEnv -> ModGuts - -> IO (CgGuts, ModDetails) - -optTidyPgm hsc_env - mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, - mg_types = env_tc, mg_insts = insts_tc, - mg_binds = binds_in, - mg_rules = imp_rules }) +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_foreign = foreign_stubs }) + = 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, cg_guts) <- tidyCgStuff hsc_env ext_ids mod_impl + ; (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 (cg_binds cg_guts) - ; 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 (cg_binds cg_guts) + ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprRules tidy_rules) - ; return (cg_guts, ModDetails { md_types = tidy_type_env - , md_rules = tidy_rules - , md_insts = tidy_ispecs - , md_exports = exports }) + ; 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_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 @@ -339,22 +303,86 @@ 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 (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} @@ -362,11 +390,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 @@ -484,27 +517,16 @@ findExternalRules binds non_local_rules ext_ids -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyCgStuff :: HscEnv - -> IdEnv Bool -- Domain = Ids that should be external +tidyTopBinds :: HscEnv + -> Module + -> TypeEnv + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> ModGuts - -> IO (TidyEnv, CgGuts) - --- * Tidy the bindings --- * Add bindings for the "implicit" Ids - -tidyCgStuff hsc_env ext_ids - (ModGuts { mg_module = mod, mg_binds = binds, mg_types = type_env, - mg_dir_imps = dir_imps, mg_deps = deps, - mg_foreign = foreign_stubs }) - = do { (env, binds') <- tidy init_env (map get_defn implicit_ids ++ binds) - ; return (env, CgGuts { cg_module = mod, - cg_tycons = filter isAlgTyCon tycons, - cg_binds = binds', - cg_dir_imps = dir_imps, - cg_foreign = foreign_stubs, - cg_dep_pkgs = dep_pkgs deps }) - } + -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) + +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 @@ -533,24 +555,6 @@ tidyCgStuff hsc_env ext_ids ; (env2, bs') <- tidy env1 bs ; return (env2, b':bs') } - tycons = typeEnvTyCons type_env - - implicit_ids :: [Id] - implicit_ids = concatMap implicit_con_ids tycons - ++ 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. - - 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 (unfoldingTemplate (idUnfolding id)) - ------------------------ tidyTopBind :: DynFlags -> Module -- 1.7.10.4