\section{Tidying up Core}
\begin{code}
-module TidyPgm( tidyCorePgm, tidyCoreExpr ) where
+module TidyPgm( mkBootModDetails, tidyProgram ) where
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), dopt )
+import DynFlags ( DynFlag(..), dopt )
+import Packages ( HomeModules )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
-import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
-import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
-import PprCore ( pprIdRules )
+import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
+import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules )
+import PprCore ( pprRules )
import CoreLint ( showPass, endPass )
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 ( Name, getOccName, nameOccName, mkInternalName,
- localiseName, isExternalName, nameSrcLoc, nameParent_maybe
+ localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
+ isWiredInName, getName
)
+import NameSet ( NameSet, elemNameSet )
import IfaceEnv ( allocateGlobalBinder )
-import NameEnv ( lookupNameEnv, 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, tyConSelIds, isAlgTyCon, isEnumerationTyCon )
+import Class ( classSelIds )
import Module ( Module )
-import HscTypes ( HscEnv(..), NameCache( 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 Maybe ( isJust )
\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
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 :: HscEnv -> ModGuts -> IO ModGuts
-
-tidyCorePgm hsc_env
- mod_impl@(ModGuts { mg_module = mod,
- mg_types = env_tc, mg_insts = insts_tc,
- mg_binds = binds_in, mg_rules = orphans_in })
- = do { let { dflags = hsc_dflags hsc_env
- ; nc_var = hsc_NC hsc_env }
+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_iface_prags = dopt Opt_OmitInterfacePragmas dflags
- ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in
- ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids
- -- findExternalRules filters ext_rules to avoid binders that
+ ; 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.)
+ -- 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.)
+ }
- -- 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 init_env = (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.
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds
- ; (final_env, tidy_binds)
- <- tidyTopBinds mod nc_var ext_ids init_env binds_in
+ ; 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_rules = tidyIdRules final_env ext_rules
+ ; 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
- ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds
-
- -- 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 (_, subst_env ) = final_env
- 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 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}
-
-
-%************************************************************************
-%* *
-\subsection{Write a new interface file}
-%* *
-%************************************************************************
+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)
-\begin{code}
-mkFinalTypeEnv :: Bool -- Omit interface pragmas
- -> 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,
-- 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 omit_iface_prags 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
- | omit_iface_prags = 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 :: Bool -- Omit interface pragmas
- -> [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 omit_iface_prags binds orphan_rules ext_ids
- | omit_iface_prags = []
- | 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 :: Bool -- omit interface pragmas
- -> [CoreBind] -> [IdCoreRule]
+findExternalIds :: Bool
+ -> [CoreBind]
-> IdEnv Bool -- In domain => external
-- Range = True <=> show unfolding
-- Step 1 from the notes above
-findExternalSet omit_iface_prags 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 omit_iface_prags (id,rhs) needed
+ | need_id needed id = addExternal (id,rhs) needed
| otherwise = needed
find (Rec prs) needed = find_prs prs needed
| otherwise = find_prs other_prs new_needed
where
(needed_prs, other_prs) = partition (need_pr needed) prs
- new_needed = foldr (addExternal omit_iface_prags) needed needed_prs
+ new_needed = foldr addExternal needed needed_prs
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
need_pr needed_set (id,rhs) = need_id needed_set id
-addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
+addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
-- with it and its dependents (free vars etc)
-addExternal omit_iface_prags (id,rhs) needed
+addExternal (id,rhs) needed
= extendVarEnv (foldVarSet add_occ needed new_needed_ids)
id show_unfold
where
-- "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 | omit_iface_prags = 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
\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}
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
-tidyTopBinds :: Module
- -> IORef NameCache -- For allocating new unique names
+tidyTopBinds :: HscEnv
+ -> HomeModules
+ -> Module
+ -> TypeEnv
-> IdEnv Bool -- Domain = Ids that should be external
-- True <=> their unfolding is external too
- -> TidyEnv -> [CoreBind]
+ -> [CoreBind]
-> IO (TidyEnv, [CoreBind])
-tidyTopBinds mod nc_var ext_ids tidy_env []
- = return (tidy_env, [])
-tidyTopBinds mod nc_var ext_ids tidy_env (b:bs)
- = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b
- ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs
- ; return (tidy_env2, b':bs') }
+tidyTopBinds hsc_env hmods mod type_env ext_ids binds
+ = tidy init_env binds
+ where
+ nc_var = hsc_NC hsc_env
+
+ -- 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.
+
+ 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 :: Module
+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 mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
+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 subst1 (idArity bndr) rhs
+ caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs
-tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
+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
-- 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
-- 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 want to
+ -- This is needed when *re*-compiling a module in GHCi; we must
-- use the same name for externally-visible things as we did before.
-- in the IdInfo of one early in the group
tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
- = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local
- -- until the CoreTidy phase" --GHC comentary
- (bndr', rhs')
+ | isGlobalId bndr -- Injected binding for record selector, etc
+ = (bndr, tidyExpr rhs_tidy_env rhs)
+ | otherwise
+ = (bndr', rhs')
where
bndr' = mkVanillaGlobal name' ty' idinfo'
ty' = tidyTopType (idType bndr)
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 || rhsIsStatic 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
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