import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Packages ( isDllName )
-import DynFlags ( DynFlags )
+import Packages ( isDllName, HomeModules )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
and 'exectute' it rather than allocating it statically.
\begin{code}
-rhsIsStatic :: DynFlags -> CoreExpr -> Bool
+rhsIsStatic :: HomeModules -> CoreExpr -> Bool
-- This function is called only on *top-level* right-hand sides
-- Returns True if the RHS can be allocated statically, with
-- no thunks involved at all.
-- When opt_RuntimeTypes is on, we keep type lambdas and treat
-- them as making the RHS re-entrant (non-updatable).
-rhsIsStatic dflags rhs = is_static False rhs
+rhsIsStatic hmods rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
- | not (isDllName dflags (idName f))
+ | not (isDllName hmods (idName f))
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
}}
-myCoreToStg dflags pkg_deps this_mod prepd_binds
+myCoreToStg dflags home_mods this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
- coreToStg dflags prepd_binds
+ coreToStg home_mods prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-}
- stg2stg dflags pkg_deps this_mod stg_binds
+ stg2stg dflags home_mods this_mod stg_binds
return (stg_binds2, cost_centre_info)
\end{code}
#include "HsVersions.h"
-import DynFlags ( DynFlags, DynFlag(..), dopt )
+import DynFlags ( DynFlag(..), dopt )
+import Packages ( HomeModules )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
-- (It's a sort of mutual recursion.)
}
- ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds
; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
tidyTopBinds :: HscEnv
+ -> HomeModules
-> Module
-> TypeEnv
-> IdEnv Bool -- Domain = Ids that should be external
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
-tidyTopBinds hsc_env mod type_env ext_ids binds
+tidyTopBinds hsc_env hmods mod type_env ext_ids binds
= tidy init_env binds
where
- dflags = hsc_dflags hsc_env
nc_var = hsc_NC hsc_env
-- We also make sure to avoid any exported binders. Consider
-- The type environment is a convenient source of such things.
tidy env [] = return (env, [])
- tidy env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b
+ 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 :: DynFlags
+tidyTopBind :: HomeModules
-> Module
-> IORef NameCache -- For allocating new unique names
-> IdEnv Bool -- Domain = Ids that should be external
-> TidyEnv -> CoreBind
-> IO (TidyEnv, CoreBind)
-tidyTopBind dflags 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 dflags subst1 (idArity bndr) rhs
+ caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs
-tidyTopBind dflags 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 dflags subst1 (idArity bndr) rhs)
+ | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
CAF list to keep track of non-collectable CAFs.
\begin{code}
-hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
-hasCafRefs dflags 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 dflags 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
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameUserString, occNameFS )
import BasicTypes ( Arity )
-import DynFlags ( DynFlags )
+import Packages ( HomeModules )
import StaticFlags ( opt_RuntimeTypes )
import Outputable
%************************************************************************
\begin{code}
-coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
-coreToStg dflags pgm
+coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
+coreToStg hmods pgm
= return pgm'
- where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg
- :: DynFlags
+ :: HomeModules
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-coreTopBindsToStg dflags env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg dflags env (b:bs)
+coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg hmods env (b:bs)
= (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
- (env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b
- (env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
+ (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
coreTopBindToStg
- :: DynFlags
+ :: HomeModules
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg dflags env body_fvs (NonRec id rhs)
+coreTopBindToStg hmods env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet (manifestArity rhs)
(stg_rhs, fvs') =
initLne env (
- coreToTopStgRhs dflags body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
returnLne (stg_rhs, fvs')
)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
-coreTopBindToStg dflags env body_fvs (Rec pairs)
+coreTopBindToStg hmods env body_fvs (Rec pairs)
= let
(binders, rhss) = unzip pairs
(stg_rhss, fvs')
= initLne env' (
- mapAndUnzipLne (coreToTopStgRhs dflags body_fvs) pairs
+ mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
\begin{code}
coreToTopStgRhs
- :: DynFlags
+ :: HomeModules
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
+coreToTopStgRhs hmods scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
- is_static = rhsIsStatic dflags rhs
+ is_static = rhsIsStatic hmods rhs
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
projects / ghc-hetmet.git / commitdiff