#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
-import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
+import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
import CoreLint ( showPass, endPass )
)
import Maybes ( orElse )
import ErrUtils ( showPass, dumpIfSet_core )
-import UniqFM ( mapUFM )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Maybe ( isJust )
; 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_ids = findExternalSet omit_iface_prags binds_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
- -- rules are exported. So in fact we may export more than we
- -- need. (It's a sort of mutual recursion.)
+ -- 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
-- The type environment is a convenient source of such things.
; (final_env, tidy_binds)
- <- tidyTopBinds mod nc_var ext_ids init_env binds_in
+ <- tidyTopBinds dflags mod nc_var ext_ids init_env binds_in
; let tidy_rules = tidyIdRules final_env ext_rules
findExternalRules omit_iface_prags binds orphan_rules ext_ids
| omit_iface_prags = []
| otherwise
- = filter needed_rule (orphan_rules ++ local_rules)
+ = filter (not . internal_rule) (orphan_rules ++ local_rules)
where
local_rules = [ rule
| id <- bindersOfBinds binds,
id `elemVarEnv` ext_ids,
rule <- idCoreRules id
]
- needed_rule (id, rule)
- = not (isBuiltinRule rule)
+ internal_rule (IdCoreRule id is_orphan rule)
+ = 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)))
+ || (not is_orphan && internal_id id)
+ -- Rule for an Id in this module; internal if the
+ -- Id is not exported
+
+ || 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)
- internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
+ internal_id id = not (id `elemVarEnv` ext_ids)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-findExternalSet :: Bool -- omit interface pragmas
- -> [CoreBind] -> [IdCoreRule]
+findExternalSet :: Bool -- Omit interface pragmas
+ -> [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
+findExternalSet omit_iface_prags binds
+ = foldr find emptyVarEnv 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.)
-
find (NonRec id rhs) needed
| need_id needed id = addExternal omit_iface_prags (id,rhs) needed
| otherwise = needed
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
-tidyTopBinds :: Module
+tidyTopBinds :: DynFlags
+ -> 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 []
+tidyTopBinds dflags 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
+tidyTopBinds dflags mod nc_var ext_ids tidy_env (b:bs)
+ = do { (tidy_env1, b') <- tidyTopBind dflags mod nc_var ext_ids tidy_env b
+ ; (tidy_env2, bs') <- tidyTopBinds dflags mod nc_var ext_ids tidy_env1 bs
; return (tidy_env2, b':bs') }
------------------------
-tidyTopBind :: Module
+tidyTopBind :: DynFlags
+ -> 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 dflags 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 dflags subst1 (idArity bndr) rhs
-tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
+tidyTopBind dflags 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 dflags subst1 (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
CAF list to keep track of non-collectable CAFs.
\begin{code}
-hasCafRefs :: VarEnv Var -> Arity -> CoreExpr -> CafInfo
-hasCafRefs p arity expr
+hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
+hasCafRefs dflags 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 dflags 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