X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FTidyPgm.lhs;h=86e55f9e0654c891e702223398c8554cbdd5d274;hb=3c96346b3685f83885cea7906b0dbc536d7695f6;hp=1df4e2a9c784e27d403dfa3c6c0cbe1309090e3a;hpb=6941708cc1d90f56fb99a9145502189d083371bb;p=ghc-hetmet.git diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 1df4e2a..86e55f9 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -4,62 +4,176 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( tidyCorePgm, tidyCoreExpr ) where +module TidyPgm( mkBootModDetails, tidyProgram ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) +import DynFlags ( DynFlag(..), dopt ) +import Packages ( HomeModules ) import CoreSyn -import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) -import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) -import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) -import PprCore ( pprIdRules ) +import CoreUnfold ( noUnfolding, mkTopUnfolding ) +import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) +import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules ) +import PprCore ( pprRules ) import CoreLint ( showPass, endPass ) -import CoreUtils ( exprArity, hasNoRedexes ) +import CoreUtils ( exprArity, rhsIsStatic ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, idCoreRules, - isExportedId, mkVanillaGlobal, isLocalId, - isImplicitId, idArity, setIdInfo, idCafInfo +import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, + isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector, + 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 ( getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe, + isWiredInName, getName ) -import RnEnv ( lookupOrigNameCache, newExternalName ) -import NameEnv ( lookupNameEnv, filterNameEnv ) +import NameSet ( NameSet, elemNameSet ) +import IfaceEnv ( allocateGlobalBinder ) +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, tyConSelIds, isAlgTyCon, isEnumerationTyCon ) +import Class ( classSelIds ) import Module ( Module ) -import HscTypes ( PersistentCompilerState( pcs_nc ), - NameCache( nsNames, nsUniqs ), - TypeEnv, extendTypeEnvList, typeEnvIds, - ModGuts(..), ModGuts, TyThing(..) +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), + TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, + extendTypeEnvWithIds, lookupTypeEnv, + ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) ) -import Maybes ( orElse ) +import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) -import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) -import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) \end{code} +Constructing the TypeEnv, Instances, Rules from which the ModIface is +constructed, and which goes on to subsequent modules in --make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +%************************************************************************ +%* * + Plan A: simpleTidyPgm +%* * +%************************************************************************ + + +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) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* 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} +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 + +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 [hoot] type env" + + ; 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_insts = ispecs', + md_rules = [], + md_exports = exports }) + } + where + +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) + +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, +-- makes it into a GlobalId with VanillaIdInfo, and tidies its type +-- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) +tidyExternalId id + = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) + mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo +\end{code} + + %************************************************************************ %* * -\subsection{What goes on} + Plan B: tidy bindings, make TypeEnv full of IdInfo %* * %************************************************************************ -[SLPJ: 19 Nov 00] +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Figure out which Ids are externally visible + +* Tidy the bindings, externalising appropriate Ids -The plan is this. +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) Step 1: Figure out external Ids ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -80,32 +194,31 @@ Step 2: Tidy the program Next we traverse the bindings top to bottom. For each *top-level* binder - 1. Make it into a GlobalId + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id 2. Give it a system-wide Unique. [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameCache kept in the PersistentCompilerState as the + We use the NameCache kept in the HscEnv as the source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache to ensure that the unique assigned is the same as the Id had in any previous compilation run. - 3. If it's an external Id, make it have a global Name, otherwise - make it have a local Name. + 3. If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator to decide whether to make the label externally visible - 4. Give external Ids a "tidy" occurrence name. This means + 4. Give external Ids a "tidy" OccName. This means we can print them in interface files without confusing "x" (unique 5) with "x" (unique 10). 5. Give it its UTTERLY FINAL IdInfo; in ptic, - * Its IdDetails becomes VanillaGlobal, reflecting the fact that - from now on we regard it as a global, not local, Id - * its unfolding, if it should have one * its arity, computed from the number of visible lambdas @@ -118,183 +231,174 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags - -> PersistentCompilerState - -> ModGuts - -> IO (PersistentCompilerState, ModGuts) - -tidyCorePgm dflags pcs - mod_impl@(ModGuts { mg_module = mod, - mg_types = env_tc, mg_insts = insts_tc, - mg_binds = binds_in, mg_rules = orphans_in }) - = do { showPass dflags "Tidy Core" - - ; let ext_ids = findExternalSet binds_in orphans_in - ; let ext_rules = findExternalRules binds_in orphans_in ext_ids - -- findExternalRules filters ext_rules to avoid binders that +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 }) + + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy Core" + + ; 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 findExternalSet) assuming that all orphan - -- rules are exported. So in fact we may export more than we - -- need. (It's a sort of mutual recursion.) - - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. - ; let orig_ns = pcs_nc pcs - init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, - let name = idName bndr, - isExternalName name] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. - - ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - init_tidy_env binds_in + -- 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.) + } - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds - ; let pcs' = pcs { pcs_nc = orig_ns' } + ; 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 (or not) DFunId in the tidy_ispecs - ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds + ; 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 - -- Dfuns are local Ids that might have - -- changed their unique during tidying. Remember - -- to lookup the id in the TypeEnv too, because - -- those Ids have had their IdInfo stripped if - -- necessary. - ; let lookup_dfun_id id = - case lookupVarEnv subst_env id of - Nothing -> dfun_panic - Just id -> - case lookupNameEnv tidy_type_env (idName id) of - Just (AnId id) -> id - _other -> dfun_panic - where - dfun_panic = pprPanic "lookup_dfun_id" (ppr id) - - tidy_dfun_ids = map lookup_dfun_id insts_tc - - ; let tidy_result = mod_impl { mg_types = tidy_type_env, - mg_rules = tidy_rules, - mg_insts = tidy_dfun_ids, - mg_binds = tidy_binds } + ; implicit_binds = getImplicitBinds type_env + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" - (pprIdRules tidy_rules) - - ; return (pcs', tidy_result) + (pprRules tidy_rules) + + ; 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 }) } -tidyCoreExpr :: CoreExpr -> IO CoreExpr -tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) -\end{code} - +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) -%************************************************************************ -%* * -\subsection{Write a new interface file} -%* * -%************************************************************************ - -\begin{code} -mkFinalTypeEnv :: 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 -- a) keeping the types and classes -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with Global names; +-- From (c) we keep only those Ids with External names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space --- --- However, we do keep things like constructors, which should not appear --- in interface files, because they are needed by importing modules when --- using the compilation manager -mkFinalTypeEnv type_env tidy_binds - = extendTypeEnvList (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 = [ AnId (strip_id_info id) - | bind <- tidy_binds, - id <- bindersOf bind, - isExternalName (idName id)] - - strip_id_info id - | opt_OmitInterfacePragmas = id `setIdInfo` vanillaIdInfo - | otherwise = id - -- If the interface file has no pragma info then discard all - -- info right here. - -- - -- This is not so important for *this* module, but it's - -- vital for ghc --make: - -- subsequent compilations must not see (e.g.) the arity if - -- the interface file does not contain arity - -- If they do, they'll exploit the arity; then the arity might - -- change, but the iface file doesn't change => recompilation - -- does not happen => disaster - -- - -- This IdInfo will live long-term in the Id => vanillaIdInfo makes - -- a conservative assumption about Caf-hood - -- - -- We're not worried about occurrences of these Ids in unfoldings, - -- because in OmitInterfacePragmas mode we're stripping all the - -- unfoldings anyway. - - -- We keep implicit Ids, because they won't appear - -- in the bindings from which final_ids are derived! - keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones - keep_it other = True -- Keep all TyCons and Classes -\end{code} + final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] -\begin{code} -findExternalRules :: [CoreBind] - -> [IdCoreRule] -- Orphan rules - -> IdEnv a -- Ids that are exported, so we need their rules - -> [IdCoreRule] - -- The complete rules are gotten by combining - -- a) the orphan rules - -- b) rules embedded in the top-level Ids -findExternalRules binds orphan_rules ext_ids - | opt_OmitInterfacePragmas = [] - | otherwise - = filter needed_rule (orphan_rules ++ local_rules) + -- 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 + + 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 + | 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 + + || (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 - local_rules = [ rule - | id <- bindersOfBinds binds, - id `elemVarEnv` ext_ids, - rule <- idCoreRules id - ] - needed_rule (id, rule) - = not (isBuiltinRule rule) - -- We can't print builtin rules in interface files - -- Since they are built in, an importing module - -- will have access to them anyway - - && not (any internal_id (varSetElems (ruleLhsFreeIds rule))) - -- Don't export a rule whose LHS mentions an Id that - -- is completely internal (i.e. not visible to an - -- importing module) + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) - internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids) +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) = 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 = [] + + 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} @@ -302,23 +406,18 @@ findExternalRules binds orphan_rules ext_ids %************************************************************************ \begin{code} -findExternalSet :: [CoreBind] -> [IdCoreRule] +findExternalIds :: Bool + -> [CoreBind] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalSet binds orphan_rules - = foldr find init_needed binds - where - orphan_rule_ids :: IdSet - orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule - | (_, rule) <- orphan_rules] - init_needed :: IdEnv Bool - init_needed = mapUFM (\_ -> False) orphan_rule_ids - -- The mapUFM is a bit cheesy. It is a cheap way - -- to turn the set of orphan_rule_ids, which we use to initialise - -- the sweep, into a mapping saying 'don't expose unfolding' - -- (When we come to the binding site we may change our mind, of course.) +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 | need_id needed id = addExternal (id,rhs) needed | otherwise = needed @@ -349,16 +448,15 @@ addExternal (id,rhs) needed -- "False" because we don't know we need the Id's unfolding -- We'll override it later when we find the binding site - new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet - | otherwise = worker_ids `unionVarSet` - unfold_ids `unionVarSet` - spec_ids + new_needed_ids = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) - spec_ids = rulesRhsFreeVars (specInfo idinfo) + spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding @@ -374,8 +472,7 @@ addExternal (id,rhs) needed show_unfold = not bottoming_fn && -- Not necessary not dont_inline && not loop_breaker && - rhs_is_small && -- Small enough - okToUnfoldInHiFile rhs -- No casms etc + rhs_is_small -- Small enough unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs | otherwise = emptyVarSet @@ -386,6 +483,34 @@ addExternal (id,rhs) needed \end{code} +\begin{code} +findExternalRules :: [CoreBind] + -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) + -> IdEnv a -- Ids that are exported, so we need their rules + -> [CoreRule] + -- The complete rules are gotten by combining + -- a) the non-local rules + -- b) rules embedded in the top-level Ids +findExternalRules binds non_local_rules ext_ids + = filter (not . internal_rule) (non_local_rules ++ local_rules) + where + local_rules = [ rule + | id <- bindersOfBinds binds, + id `elemVarEnv` ext_ids, + rule <- idCoreRules id + ] + + internal_rule rule + = any internal_id (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) + + internal_id id = not (id `elemVarEnv` ext_ids) +\end{code} + + + %************************************************************************ %* * \subsection{Step 2: top-level tidying} @@ -394,10 +519,8 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameCache, containing a unique supply and any pre-ordained Names. +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've @@ -409,91 +532,177 @@ type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} - -\begin{code} -tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external +tidyTopBinds :: HscEnv + -> HomeModules + -> Module + -> TypeEnv + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) + -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - caf_info = hasCafRefs subst1 (idArity bndr') rhs' - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs) - = (final_env, Rec prs') +tidyTopBinds hsc_env hmods mod type_env ext_ids binds + = tidy init_env binds where - (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs - rec_tidy_env = (occ,subst) + nc_var = hsc_NC hsc_env - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- 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 type_env, + let name = idName bndr, + isExternalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. - rhs' = tidyExpr rec_tidy_env rhs + tidy env [] = return (env, []) + 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 :: HomeModules + -> Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +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 hmods subst1 (idArity bndr) rhs + +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 + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } + where + bndrs = map fst 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 subst1 (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - -tidyTopBinder :: Module -> IdEnv Bool -> CafInfo - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -> CoreExpr -- RHS *before* tidying - -> CoreExpr -- RHS *after* tidying - -- The TidyEnv and the after-tidying RHS are - -- both are knot-tied: don't look at them! - -> TopTidyEnv -> Id -> (TopTidyEnv, Id) - -- NB: tidyTopBinder doesn't affect the unique supply - -tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- tidyTopName +-- This is where we set names to local/global based on whether they really are +-- externally visible (see comment at the top of this module). If the name +-- was previously local, we have to give it a unique occurrence name if +-- we intend to externalise it. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) -- This function is the heart of Step 2 -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group - -- The rhs is already tidied - - = ASSERT(isLocalId id) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - ((orig_env', occ_env', subst_env'), id') +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + | isGlobalId bndr -- Injected binding for record selector, etc + = (bndr, tidyExpr rhs_tidy_env rhs) + | otherwise + = (bndr', rhs') where - (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 - is_external - (idName id) - ty' = tidyTopType (idType id) - idinfo = tidyTopIdInfo rec_tidy_env is_external - (idInfo id) unfold_info arity - caf_info - - id' = mkVanillaGlobal name' ty' idinfo - - subst_env' = extendVarEnv subst_env2 id id' - - maybe_external = lookupVarEnv ext_ids id - is_external = isJust maybe_external + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding tidy_rhs + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because @@ -539,50 +748,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info -- They have already been extracted by findExternalRules --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. -tidyTopName mod ns occ_env external name - | global && internal = (ns, occ_env, localiseName name) - - | global && external = (ns, occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - | local && internal = (ns_w_local, occ_env', new_local_name) - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = case lookupOrigNameCache ns_names mod occ' of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns_w_global, occ_env', new_external_name) - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table (ns_w_global). - -- This is needed when *re*-compiling a module in GHCi; we want to - -- use the same name for externally-visible things as we did before. - - where - global = isExternalName name - local = not global - internal = not external - loc = nameSrcLoc name - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - - ns_names = nsNames ns - (us1, us2) = splitUniqSupply (nsUniqs ns) - uniq = uniqFromSupply us1 - new_local_name = mkInternalName uniq occ' loc - ns_w_local = ns { nsUniqs = us2 } - - (ns_w_global, new_external_name) = newExternalName ns mod occ' loc - ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) @@ -613,18 +778,18 @@ 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 :: VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs 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 || hasNoRedexes 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 -- CorePrep later on, and we don't want to duplicate that - -- knowledge in hasNoRedexes below. + -- knowledge in rhsIsStatic below. cafRefs p (Var id) -- imported Ids first: @@ -635,13 +800,13 @@ cafRefs p (Var id) Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) Nothing -> fastBool False -cafRefs p (Lit l) = fastBool False -cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a -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 (Type t) = fastBool False +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a +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 (Type t) = fastBool False cafRefss p [] = fastBool False cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es