Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
b9a1ac09
Commit
b9a1ac09
authored
Jun 21, 2005
by
simonmar
Browse files
[project @ 2005-06-21 11:57:00 by simonmar]
fix Windows build
parent
0c53bd0e
Changes
4
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 ::
DynFlag
s -> CoreExpr -> Bool
rhsIsStatic ::
HomeModule
s -> 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
dflag
s rhs = is_static False rhs
rhsIsStatic
hmod
s 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
dflag
s (idName f))
| not (isDllName
hmod
s (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_dep
s this_mod prepd_binds
myCoreToStg dflags
home_mod
s this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
coreToStg
dflag
s prepd_binds
coreToStg
home_mod
s prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-}
stg2stg dflags
pkg_dep
s this_mod stg_binds
stg2stg dflags
home_mod
s 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
dflag
s mod nc_var ext_ids env b
tidy env (b:bs) = do { (env1, b') <- tidyTopBind
hmod
s mod nc_var ext_ids env b
; (env2, bs') <- tidy env1 bs
; return (env2, b':bs') }
------------------------
tidyTopBind ::
DynFlag
s
tidyTopBind ::
HomeModule
s
-> 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
dflag
s mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
tidyTopBind
hmod
s 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
dflag
s subst1 (idArity bndr) rhs
caf_info = hasCafRefs
hmod
s subst1 (idArity bndr) rhs
tidyTopBind
dflag
s mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
tidyTopBind
hmod
s 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
dflag
s subst1 (idArity bndr) rhs)
| or [ mayHaveCafRefs (hasCafRefs
hmod
s 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 ::
DynFlag
s -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs
dflag
s p arity expr
hasCafRefs ::
HomeModule
s -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs
hmod
s p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic
dflag
s expr)
is_caf = not (arity > 0 || rhsIsStatic
hmod
s 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
DynFl
ags (
DynFlag
s )
import
Pack
ag
e
s (
HomeModule
s )
import StaticFlags ( opt_RuntimeTypes )
import Outputable
...
...
@@ -140,10 +140,10 @@ for x, solely to put in the SRTs lower down.
%************************************************************************
\begin{code}
coreToStg ::
DynFlag
s -> [CoreBind] -> IO [StgBinding]
coreToStg
dflag
s pgm
coreToStg ::
HomeModule
s -> [CoreBind] -> IO [StgBinding]
coreToStg
hmod
s pgm
= return pgm'
where (_, _, pgm') = coreTopBindsToStg
dflag
s emptyVarEnv pgm
where (_, _, pgm') = coreTopBindsToStg
hmod
s emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
...
...
@@ -151,35 +151,35 @@ coreExprToStg expr
coreTopBindsToStg
::
DynFlag
s
::
HomeModule
s
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
coreTopBindsToStg
dflag
s env [] = (env, emptyFVInfo, [])
coreTopBindsToStg
dflag
s env (b:bs)
coreTopBindsToStg
hmod
s env [] = (env, emptyFVInfo, [])
coreTopBindsToStg
hmod
s env (b:bs)
= (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg
dflag
s env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg
dflag
s env1 bs
(env1, fvs2, b' ) = coreTopBindToStg
hmod
s env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg
hmod
s env1 bs
coreTopBindToStg
::
DynFlag
s
::
HomeModule
s
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
coreTopBindToStg
dflag
s env body_fvs (NonRec id rhs)
coreTopBindToStg
hmod
s 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
dflag
s body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
coreToTopStgRhs
hmod
s 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
dflag
s env body_fvs (Rec pairs)
coreTopBindToStg
hmod
s 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
dflag
s body_fvs) pairs
mapAndUnzipLne (coreToTopStgRhs
hmod
s 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
::
DynFlag
s
::
HomeModule
s
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
coreToTopStgRhs
dflag
s scope_fv_info (bndr, rhs)
coreToTopStgRhs
hmod
s 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
dflag
s rhs
is_static = rhsIsStatic
hmod
s rhs
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment