Commit 7b44e519 authored by Ian Lynagh's avatar Ian Lynagh

Remove a little more CPP

parent e94e97a1
......@@ -69,11 +69,9 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
= do { dflags <- getDynFlags
; when (platformOS (targetPlatform dflags) == OSMinGW32) $ do {
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
; this_pkg <- getThisPackage
; ASSERT( not (isDllConApp this_pkg con args) ) return ()
}
ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
-- LAY IT OUT
......
......@@ -59,11 +59,9 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
cgTopRhsCon id con args
= do {
dflags <- getDynFlags
; when (platformOS (targetPlatform dflags) == OSMinGW32) $ do {
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
this_pkg <- getThisPackage
; ASSERT( not (isDllConApp this_pkg con args) ) return ()
}
ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
-- LAY IT OUT
......
......@@ -1219,7 +1219,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
coreToStg (thisPackage dflags) prepd_binds
coreToStg dflags prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
stg2stg dflags this_mod stg_binds
......
......@@ -45,13 +45,12 @@ import DynFlags
\begin{code}
stgMassageForProfiling
:: DynFlags
-> PackageId
-> Module -- module name
-> UniqSupply -- unique supply
-> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
stgMassageForProfiling dflags this_pkg mod_name us stg_binds
stgMassageForProfiling dflags mod_name us stg_binds
= let
((local_ccs, extern_ccs, cc_stacks),
stg_binds2)
......@@ -100,7 +99,7 @@ stgMassageForProfiling dflags this_pkg mod_name us stg_binds
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args)))
| not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args)
| not (isSccCountCostCentre cc) && not (isDllConApp dflags con args)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
......
......@@ -72,8 +72,7 @@ stg2stg dflags module_name binds
{-# SCC "ProfMassage" #-}
let
(collected_CCs, binds3)
= stgMassageForProfiling dflags this_pkg module_name us1 binds
this_pkg = thisPackage dflags
= stgMassageForProfiling dflags module_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
......
......@@ -30,11 +30,11 @@ import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
import Literal
import Module
import Outputable
import MonadUtils
import FastString
import Util
import DynFlags
import ForeignCall
import PrimOp ( PrimCall(..) )
\end{code}
......@@ -140,10 +140,10 @@ for x, solely to put in the SRTs lower down.
%************************************************************************
\begin{code}
coreToStg :: PackageId -> CoreProgram -> IO [StgBinding]
coreToStg this_pkg pgm
coreToStg :: DynFlags -> CoreProgram -> IO [StgBinding]
coreToStg dflags pgm
= return pgm'
where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
......@@ -151,36 +151,36 @@ coreExprToStg expr
coreTopBindsToStg
:: PackageId
:: DynFlags
-> IdEnv HowBound -- environment for the bindings
-> CoreProgram
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg this_pkg env (b:bs)
coreTopBindsToStg dflags env (b:bs)
= (env2, fvs2, b':bs')
where
-- Notice the mutually-recursive "knot" here:
-- env accumulates down the list of binds,
-- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
(env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
coreTopBindToStg
:: PackageId
:: DynFlags
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
coreTopBindToStg dflags env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
initLne env $ do
(stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
(stg_rhs, fvs') <- coreToTopStgRhs dflags body_fvs (id,rhs)
return (stg_rhs, fvs')
bind = StgNonRec id stg_rhs
......@@ -192,7 +192,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
-- assertion again!
(env', fvs' `unionFVInfo` body_fvs, bind)
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
coreTopBindToStg dflags env body_fvs (Rec pairs)
= ASSERT( not (null pairs) )
let
binders = map fst pairs
......@@ -203,7 +203,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
(stg_rhss, fvs')
= initLne env' $ do
(stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
(stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags body_fvs) pairs
let fvs' = unionFVInfos fvss'
return (stg_rhss, fvs')
......@@ -231,16 +231,16 @@ consistentCafInfo id bind
\begin{code}
coreToTopStgRhs
:: PackageId
:: DynFlags
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
; lv_info <- freeVarsToLiveVars rhs_fvs
; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
; let stg_rhs = mkTopStgRhs dflags rhs_fvs (mkSRT lv_info) bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
......@@ -266,7 +266,7 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
ptext (sLit "Id arity:") <+> ppr id_arity,
ptext (sLit "STG arity:") <+> ppr stg_arity]
mkTopStgRhs :: PackageId -> FreeVarsInfo
mkTopStgRhs :: DynFlags -> FreeVarsInfo
-> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
......@@ -277,8 +277,8 @@ mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
srt
bndrs body
mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
| not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable
mkTopStgRhs dflags _ _ _ (StgConApp con args)
| not (isDllConApp dflags con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args
mkTopStgRhs _ rhs_fvs srt binder_info rhs
......
......@@ -62,15 +62,15 @@ import TyCon ( TyCon )
import UniqSet
import Unique ( Unique )
import Bitmap
import DynFlags
import Platform
import StaticFlags ( opt_SccProfilingOn )
import Module
import FastString
#if mingw32_TARGET_OS
import Packages ( isDllName )
import Type ( typePrimRep )
import TyCon ( PrimRep(..) )
#endif
\end{code}
%************************************************************************
......@@ -110,19 +110,22 @@ isStgTypeArg :: StgArg -> Bool
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg _ = False
isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
#if mingw32_TARGET_OS
isDllConApp this_pkg con args
= isDllName this_pkg (dataConName con) || any is_dll_arg args
isDllConApp dflags con args
| platformOS (targetPlatform dflags) == OSMinGW32
= isDllName this_pkg (dataConName con) || any is_dll_arg args
| otherwise = False
where
is_dll_arg ::StgArg -> Bool
is_dll_arg :: StgArg -> Bool
is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
&& isDllName this_pkg (idName v)
is_dll_arg _ = False
this_pkg = thisPackage dflags
isAddrRep :: PrimRep -> Bool
-- True of machine adddresses; these are the things that don't
-- work across DLLs.
......@@ -140,10 +143,6 @@ isAddrRep AddrRep = True
isAddrRep PtrRep = True
isAddrRep _ = False
#else
isDllConApp _ _ _ = False
#endif
stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
stgArgType (StgVarArg v) = idType v
......
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