\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, rhsIsNonUpd )
+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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
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}
%************************************************************************
\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
-- "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
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
\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}
\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
-- 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
-- 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)
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 || rhsIsNonUpd 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 rhsIsNonUpd below.
+ -- knowledge in rhsIsStatic below.
cafRefs p (Var id)
-- imported Ids first:
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
projects / ghc-hetmet.git / blobdiff