From b9a1ac0970ebff0832746d1b689855bfa42db241 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 21 Jun 2005 11:57:00 +0000 Subject: [PATCH] [project @ 2005-06-21 11:57:00 by simonmar] fix Windows build --- ghc/compiler/coreSyn/CoreUtils.lhs | 9 ++++----- ghc/compiler/main/HscMain.lhs | 6 +++--- ghc/compiler/main/TidyPgm.lhs | 27 ++++++++++++++------------- ghc/compiler/stgSyn/CoreToStg.lhs | 34 +++++++++++++++++----------------- 4 files changed, 38 insertions(+), 38 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 1951d8c..d4948aa 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -46,8 +46,7 @@ import Var ( Var ) 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, @@ -1159,7 +1158,7 @@ If this happens we simply make the RHS into an updatable thunk, 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. @@ -1220,7 +1219,7 @@ rhsIsStatic :: DynFlags -> CoreExpr -> Bool -- 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 @@ -1247,7 +1246,7 @@ rhsIsStatic dflags rhs = is_static False rhs 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) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 29131b3..10c946b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -568,13 +568,13 @@ myParseModule dflags src_filename maybe_src_buf }} -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} diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 0af2ca7..62a2c82 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,8 @@ module TidyPgm( mkBootModDetails, tidyProgram ) where #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 ) @@ -256,7 +257,7 @@ tidyProgram hsc_env -- (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 @@ -527,6 +528,7 @@ findExternalRules binds non_local_rules ext_ids -- * 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 @@ -534,10 +536,9 @@ tidyTopBinds :: HscEnv -> [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 @@ -560,12 +561,12 @@ tidyTopBinds hsc_env mod type_env ext_ids binds -- 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 @@ -573,16 +574,16 @@ tidyTopBind :: DynFlags -> 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 @@ -595,7 +596,7 @@ tidyTopBind dflags mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec 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 @@ -771,13 +772,13 @@ it as a CAF. In these cases however, we would need to use an additional 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 734e5fd..d241e58 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -32,7 +32,7 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameUserString, occNameFS ) import BasicTypes ( Arity ) -import DynFlags ( DynFlags ) +import Packages ( HomeModules ) import StaticFlags ( opt_RuntimeTypes ) import Outputable @@ -140,10 +140,10 @@ for x, solely to put in the SRTs lower down. %************************************************************************ \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 @@ -151,35 +151,35 @@ 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') ) @@ -190,7 +190,7 @@ coreTopBindToStg dflags env body_fvs (NonRec id rhs) -- 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 @@ -200,7 +200,7 @@ coreTopBindToStg dflags env body_fvs (Rec 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') @@ -232,18 +232,18 @@ consistentCafInfo id bind \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 -- 1.7.10.4