#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
+import CmdLineOpts ( DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
import IdInfo {- loads of stuff -}
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
)
-import RnEnv ( lookupOrigNameCache, newExternalName )
+import IfaceEnv ( allocateGlobalBinder )
import NameEnv ( lookupNameEnv, filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType )
import Module ( Module )
-import HscTypes ( PersistentCompilerState( pcs_nc ),
- NameCache( nsNames, nsUniqs ),
+import HscTypes ( HscEnv(..), NameCache( nsUniqs ),
TypeEnv, extendTypeEnvList, typeEnvIds,
ModGuts(..), ModGuts, TyThing(..)
)
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}
[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
RHSs, so that they print nicely in interfaces.
\begin{code}
-tidyCorePgm :: DynFlags
- -> PersistentCompilerState
- -> ModGuts
- -> IO (PersistentCompilerState, ModGuts)
+tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts
-tidyCorePgm dflags pcs
+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 { showPass dflags "Tidy Core"
+ = do { let { dflags = hsc_dflags hsc_env
+ ; nc_var = hsc_NC hsc_env }
+ ; showPass dflags "Tidy Core"
- ; let ext_ids = findExternalSet binds_in orphans_in
- ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
+ ; 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
-- aren't externally visible; but the externally-visible binders
-- are computed (by findExternalSet) assuming that all orphan
-- 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 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
-- 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
+ ; (final_env, tidy_binds)
+ <- tidyTopBinds mod nc_var ext_ids init_env binds_in
- ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
+ ; let tidy_rules = tidyIdRules final_env ext_rules
- ; let pcs' = pcs { pcs_nc = orig_ns' }
-
- ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds
+ ; 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 lookup_dfun_id id =
+ ; let (_, subst_env ) = final_env
+ lookup_dfun_id id =
case lookupVarEnv subst_env id of
Nothing -> dfun_panic
Just id ->
"Tidy Core Rules"
(pprIdRules tidy_rules)
- ; return (pcs', tidy_result)
+ ; return tidy_result
}
tidyCoreExpr :: CoreExpr -> IO CoreExpr
%************************************************************************
\begin{code}
-mkFinalTypeEnv :: TypeEnv -- From typechecker
+mkFinalTypeEnv :: Bool -- Omit interface pragmas
+ -> TypeEnv -- From typechecker
-> [CoreBind] -- Final Ids
-> TypeEnv
-- 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
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
-mkFinalTypeEnv type_env tidy_binds
+mkFinalTypeEnv omit_iface_prags type_env tidy_binds
= extendTypeEnvList (filterNameEnv keep_it type_env) final_ids
where
final_ids = [ AnId (strip_id_info id)
isExternalName (idName id)]
strip_id_info id
- | opt_OmitInterfacePragmas = id `setIdInfo` vanillaIdInfo
- | otherwise = id
+ | omit_iface_prags = id `setIdInfo` vanillaIdInfo
+ | otherwise = id
-- If the interface file has no pragma info then discard all
-- info right here.
--
\end{code}
\begin{code}
-findExternalRules :: [CoreBind]
+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 binds orphan_rules ext_ids
- | opt_OmitInterfacePragmas = []
+findExternalRules omit_iface_prags binds orphan_rules ext_ids
+ | omit_iface_prags = []
| otherwise
= filter needed_rule (orphan_rules ++ local_rules)
where
%************************************************************************
\begin{code}
-findExternalSet :: [CoreBind] -> [IdCoreRule]
+findExternalSet :: Bool -- omit interface pragmas
+ -> [CoreBind] -> [IdCoreRule]
-> IdEnv Bool -- In domain => external
-- Range = True <=> show unfolding
-- Step 1 from the notes above
-findExternalSet binds orphan_rules
+findExternalSet omit_iface_prags binds orphan_rules
= foldr find init_needed binds
where
orphan_rule_ids :: IdSet
-- (When we come to the binding site we may change our mind, of course.)
find (NonRec id rhs) needed
- | need_id needed id = addExternal (id,rhs) needed
+ | need_id needed id = addExternal omit_iface_prags (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 needed needed_prs
+ new_needed = foldr (addExternal omit_iface_prags) 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 :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
+addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
-- with it and its dependents (free vars etc)
-addExternal (id,rhs) needed
+addExternal omit_iface_prags (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 | opt_OmitInterfacePragmas = emptyVarSet
- | otherwise = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
- spec_ids
+ new_needed_ids | omit_iface_prags = emptyVarSet
+ | otherwise = worker_ids `unionVarSet`
+ unfold_ids `unionVarSet`
+ spec_ids
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragInfo idinfo)
\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}
+tidyTopBinds :: 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])
+tidyTopBinds mod nc_var ext_ids tidy_env []
+ = return (tidy_env, [])
-\begin{code}
+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') }
+
+------------------------
tidyTopBind :: Module
- -> IdEnv Bool -- Domain = Ids that should be external
+ -> IORef NameCache -- For allocating new unique names
+ -> IdEnv Bool -- Domain = Ids that should be external
-- True <=> their unfolding is external too
- -> TopTidyEnv -> CoreBind
- -> (TopTidyEnv, CoreBind)
-
-tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs)
- = ((orig,occ,subst) , NonRec bndr' rhs')
+ -> TidyEnv -> CoreBind
+ -> IO (TidyEnv, CoreBind)
+
+tidyTopBind 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
- ((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')
+ caf_info = hasCafRefs subst1 (idArity bndr) rhs
+
+tidyTopBind 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
- (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
- rec_tidy_env = (occ,subst)
-
- 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
-
- rhs' = tidyExpr rec_tidy_env rhs
+ 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)
| (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 want to
+ -- 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)
+ = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local
+ -- until the CoreTidy phase" --GHC comentary
+ (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)
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)
+-- gaw 2004
+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
projects / ghc-hetmet.git / blobdiff