Skip to content

GitLab

Commit b9a1ac09 authored by simonmar's avatar simonmar
Browse files

[project @ 2005-06-21 11:57:00 by simonmar] 

fix Windows build
parent 0c53bd0e
Hide whitespace changes
Inline Side-by-side
ghc/compiler/coreSyn/CoreUtils.lhs
View file @ b9a1ac09
......@@ -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)
......
ghc/compiler/main/HscMain.lhs
View file @ b9a1ac09
......@@ -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}
......
ghc/compiler/main/TidyPgm.lhs
View file @ b9a1ac09
......@@ -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
......
ghc/compiler/stgSyn/CoreToStg.lhs
View file @ b9a1ac09
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment