Commit 60b86b04 authored by ian@well-typed.com's avatar ian@well-typed.com

Fix the GHC package DLL-splitting

There's now an internal -dll-split flag, which we use to tell GHC how
the GHC package is split into 2 separate DLLs. This is used by
Packages.isDllName to determine whether a call is within the same
DLL, or whether it is a call to another DLL.
parent ff1a16a0
...@@ -838,12 +838,12 @@ idInfoLabelType info = ...@@ -838,12 +838,12 @@ idInfoLabelType info =
-- in a DLL, be it a data reference or not. -- in a DLL, be it a data reference or not.
labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool
labelDynamic dflags this_pkg _this_mod lbl = labelDynamic dflags this_pkg this_mod lbl =
case lbl of case lbl of
-- is the RTS in a DLL or not? -- is the RTS in a DLL or not?
RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId) RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId)
IdLabel n _ _ -> isDllName dflags this_pkg n IdLabel n _ _ -> isDllName dflags this_pkg this_mod n
-- When compiling in the "dyn" way, each package is to be linked into -- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library. -- its own shared library.
......
...@@ -65,9 +65,10 @@ cgTopRhsCon id con args ...@@ -65,9 +65,10 @@ cgTopRhsCon id con args
gen_code = gen_code =
do { dflags <- getDynFlags do { dflags <- getDynFlags
; this_mod <- getModuleName
; when (platformOS (targetPlatform dflags) == OSMinGW32) $ ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs. -- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return () ASSERT( not (isDllConApp dflags this_mod con args) ) return ()
; ASSERT( args `lengthIs` dataConRepRepArity con ) return () ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT -- LAY IT OUT
......
...@@ -610,6 +610,14 @@ data DynFlags = DynFlags { ...@@ -610,6 +610,14 @@ data DynFlags = DynFlags {
dynObjectSuf :: String, dynObjectSuf :: String,
dynHiSuf :: String, dynHiSuf :: String,
-- Packages.isDllName needs to know whether a call is within a
-- single DLL or not. Normally it does this by seeing if the call
-- is to the same package, but for the ghc package, we split the
-- package between 2 DLLs. The dllSplit tells us which sets of
-- modules are in which package.
dllSplitFile :: Maybe FilePath,
dllSplit :: Maybe [Set String],
outputFile :: Maybe String, outputFile :: Maybe String,
dynOutputFile :: Maybe String, dynOutputFile :: Maybe String,
outputHi :: Maybe String, outputHi :: Maybe String,
...@@ -1249,6 +1257,9 @@ defaultDynFlags mySettings = ...@@ -1249,6 +1257,9 @@ defaultDynFlags mySettings =
dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, dynObjectSuf = "dyn_" ++ phaseInputExt StopLn,
dynHiSuf = "dyn_hi", dynHiSuf = "dyn_hi",
dllSplitFile = Nothing,
dllSplit = Nothing,
pluginModNames = [], pluginModNames = [],
pluginModNameOpts = [], pluginModNameOpts = [],
...@@ -1848,9 +1859,23 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do ...@@ -1848,9 +1859,23 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3
liftIO $ setUnsafeGlobalDynFlags dflags4 dflags5 <- case dllSplitFile dflags4 of
Nothing -> return (dflags4 { dllSplit = Nothing })
Just f ->
case dllSplit dflags4 of
Just _ ->
-- If dllSplit is out of date then it would have
-- been set to Nothing. As it's a Just, it must be
-- up-to-date.
return dflags4
Nothing ->
do xs <- liftIO $ readFile f
let ss = map (Set.fromList . words) (lines xs)
return $ dflags4 { dllSplit = Just ss }
liftIO $ setUnsafeGlobalDynFlags dflags5
return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns) return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns)
updateWays :: DynFlags -> DynFlags updateWays :: DynFlags -> DynFlags
updateWays dflags updateWays dflags
...@@ -2029,6 +2054,8 @@ dynamic_flags = [ ...@@ -2029,6 +2054,8 @@ dynamic_flags = [
, Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib }))
, Flag "dynload" (hasArg parseDynLibLoaderMode) , Flag "dynload" (hasArg parseDynLibLoaderMode)
, Flag "dylib-install-name" (hasArg setDylibInstallName) , Flag "dylib-install-name" (hasArg setDylibInstallName)
-- -dll-split is an internal flag, used only during the GHC build
, Flag "dll-split" (hasArg (\f d -> d{ dllSplitFile = Just f, dllSplit = Nothing }))
------- Libraries --------------------------------------------------- ------- Libraries ---------------------------------------------------
, Flag "L" (Prefix addLibraryPath) , Flag "L" (Prefix addLibraryPath)
......
...@@ -1324,7 +1324,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram ...@@ -1324,7 +1324,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
myCoreToStg dflags this_mod prepd_binds = do myCoreToStg dflags this_mod prepd_binds = do
stg_binds stg_binds
<- {-# SCC "Core2Stg" #-} <- {-# SCC "Core2Stg" #-}
coreToStg dflags prepd_binds coreToStg dflags this_mod prepd_binds
(stg_binds2, cost_centre_info) (stg_binds2, cost_centre_info)
<- {-# SCC "Stg2Stg" #-} <- {-# SCC "Stg2Stg" #-}
......
...@@ -1039,13 +1039,24 @@ missingDependencyMsg (Just parent) ...@@ -1039,13 +1039,24 @@ missingDependencyMsg (Just parent)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- | Will the 'Name' come from a dynamically linked library? -- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> PackageId -> Name -> Bool isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that -- Despite the "dll", I think this function just means that
-- the synbol comes from another dynamically-linked package, -- the synbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows -- and applies on all platforms, not just Windows
isDllName dflags this_pkg name isDllName dflags this_pkg this_mod name
| gopt Opt_Static dflags = False | gopt Opt_Static dflags = False
| Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg | Just mod <- nameModule_maybe name
= if modulePackageId mod /= this_pkg
then True
else case dllSplit dflags of
Nothing -> False
Just ss ->
let findMod m = let modStr = moduleNameString (moduleName m)
in case find (modStr `Set.member`) ss of
Just i -> i
Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
in findMod mod /= findMod this_mod
| otherwise = False -- no, it is not even an external name | otherwise = False -- no, it is not even an external name
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -328,7 +328,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -328,7 +328,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- See Note [Which rules to expose] -- See Note [Which rules to expose]
; (tidy_env, tidy_binds) ; (tidy_env, tidy_binds)
<- tidyTopBinds hsc_env unfold_env tidy_occ_env binds <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env binds
; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds,
isExternalName (idName id)] isExternalName (idName id)]
...@@ -979,12 +979,13 @@ rules are externalised (see init_ext_ids in function ...@@ -979,12 +979,13 @@ rules are externalised (see init_ext_ids in function
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
tidyTopBinds :: HscEnv tidyTopBinds :: HscEnv
-> Module
-> UnfoldEnv -> UnfoldEnv
-> TidyOccEnv -> TidyOccEnv
-> CoreProgram -> CoreProgram
-> IO (TidyEnv, CoreProgram) -> IO (TidyEnv, CoreProgram)
tidyTopBinds hsc_env unfold_env init_occ_env binds tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
= do mkIntegerId <- liftM tyThingId = do mkIntegerId <- liftM tyThingId
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ tidy mkIntegerId init_env binds return $ tidy mkIntegerId init_env binds
...@@ -996,7 +997,7 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds ...@@ -996,7 +997,7 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
this_pkg = thisPackage dflags this_pkg = thisPackage dflags
tidy _ env [] = (env, []) tidy _ env [] = (env, [])
tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env env b
(env2, bs') = tidy mkIntegerId env1 bs (env2, bs') = tidy mkIntegerId env1 bs
in in
(env2, b':bs') (env2, b':bs')
...@@ -1004,22 +1005,23 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds ...@@ -1004,22 +1005,23 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
------------------------ ------------------------
tidyTopBind :: DynFlags tidyTopBind :: DynFlags
-> PackageId -> PackageId
-> Module
-> Id -> Id
-> UnfoldEnv -> UnfoldEnv
-> TidyEnv -> TidyEnv
-> CoreBind -> CoreBind
-> (TidyEnv, CoreBind) -> (TidyEnv, CoreBind)
tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs') = (tidy_env2, NonRec bndr' rhs')
where where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr Just (name',show_unfold) = lookupVarEnv unfold_env bndr
caf_info = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs caf_info = hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs
(bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr' subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2) tidy_env2 = (occ_env, subst2)
tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
= (tidy_env2, Rec prs') = (tidy_env2, Rec prs')
where where
prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
...@@ -1036,7 +1038,7 @@ tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) ...@@ -1036,7 +1038,7 @@ tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
-- the CafInfo for a recursive group says whether *any* rhs in -- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do). -- the group may refer indirectly to a CAF (because then, they all do).
caf_info caf_info
| or [ mayHaveCafRefs (hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs | (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs | otherwise = NoCafRefs
...@@ -1172,14 +1174,15 @@ it as a CAF. In these cases however, we would need to use an additional ...@@ -1172,14 +1174,15 @@ it as a CAF. In these cases however, we would need to use an additional
CAF list to keep track of non-collectable CAFs. CAF list to keep track of non-collectable CAFs.
\begin{code} \begin{code}
hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr hasCafRefs :: DynFlags -> PackageId -> Module
-> (Id, VarEnv Var) -> Arity -> CoreExpr
-> CafInfo -> CafInfo
hasCafRefs dflags this_pkg p arity expr hasCafRefs dflags this_pkg this_mod p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs | is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs | otherwise = NoCafRefs
where where
mentions_cafs = isFastTrue (cafRefsE dflags p expr) mentions_cafs = isFastTrue (cafRefsE dflags p expr)
is_dynamic_name = isDllName dflags this_pkg is_dynamic_name = isDllName dflags this_pkg this_mod
is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr)
-- NB. we pass in the arity of the expression, which is expected -- NB. we pass in the arity of the expression, which is expected
......
...@@ -91,7 +91,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds ...@@ -91,7 +91,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
(StgSCC _cc False{-not tick-} _push (StgConApp con args))) (StgSCC _cc False{-not tick-} _push (StgConApp con args)))
| not (isDllConApp dflags con args) | not (isDllConApp dflags mod_name con args)
-- Trivial _scc_ around nothing but static data -- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon -- Eliminate _scc_ ... and turn into StgRhsCon
......
...@@ -26,6 +26,7 @@ import CostCentre ( noCCS ) ...@@ -26,6 +26,7 @@ import CostCentre ( noCCS )
import VarSet import VarSet
import VarEnv import VarEnv
import Maybes ( maybeToBool ) import Maybes ( maybeToBool )
import Module
import Name ( getOccName, isExternalName, nameOccName ) import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS ) import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity ) import BasicTypes ( Arity )
...@@ -141,10 +142,10 @@ for x, solely to put in the SRTs lower down. ...@@ -141,10 +142,10 @@ for x, solely to put in the SRTs lower down.
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
coreToStg :: DynFlags -> CoreProgram -> IO [StgBinding] coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags pgm coreToStg dflags this_mod pgm
= return pgm' = return pgm'
where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr coreExprToStg expr
...@@ -153,35 +154,37 @@ coreExprToStg expr ...@@ -153,35 +154,37 @@ coreExprToStg expr
coreTopBindsToStg coreTopBindsToStg
:: DynFlags :: DynFlags
-> Module
-> IdEnv HowBound -- environment for the bindings -> IdEnv HowBound -- environment for the bindings
-> CoreProgram -> CoreProgram
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
coreTopBindsToStg _ env [] = (env, emptyFVInfo, []) coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags env (b:bs) coreTopBindsToStg dflags this_mod env (b:bs)
= (env2, fvs2, b':bs') = (env2, fvs2, b':bs')
where where
-- Notice the mutually-recursive "knot" here: -- Notice the mutually-recursive "knot" here:
-- env accumulates down the list of binds, -- env accumulates down the list of binds,
-- fvs accumulates upwards -- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
coreTopBindToStg coreTopBindToStg
:: DynFlags :: DynFlags
-> Module
-> IdEnv HowBound -> IdEnv HowBound
-> FreeVarsInfo -- Info about the body -> FreeVarsInfo -- Info about the body
-> CoreBind -> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding) -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
coreTopBindToStg dflags env body_fvs (NonRec id rhs) coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
= let = let
env' = extendVarEnv env id how_bound env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') = (stg_rhs, fvs') =
initLne env $ do initLne env $ do
(stg_rhs, fvs') <- coreToTopStgRhs dflags body_fvs (id,rhs) (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
return (stg_rhs, fvs') return (stg_rhs, fvs')
bind = StgNonRec id stg_rhs bind = StgNonRec id stg_rhs
...@@ -193,7 +196,7 @@ coreTopBindToStg dflags env body_fvs (NonRec id rhs) ...@@ -193,7 +196,7 @@ coreTopBindToStg dflags env body_fvs (NonRec id rhs)
-- assertion again! -- assertion again!
(env', fvs' `unionFVInfo` body_fvs, bind) (env', fvs' `unionFVInfo` body_fvs, bind)
coreTopBindToStg dflags env body_fvs (Rec pairs) coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
= ASSERT( not (null pairs) ) = ASSERT( not (null pairs) )
let let
binders = map fst pairs binders = map fst pairs
...@@ -204,7 +207,7 @@ coreTopBindToStg dflags env body_fvs (Rec pairs) ...@@ -204,7 +207,7 @@ coreTopBindToStg dflags env body_fvs (Rec pairs)
(stg_rhss, fvs') (stg_rhss, fvs')
= initLne env' $ do = initLne env' $ do
(stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags body_fvs) pairs (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
let fvs' = unionFVInfos fvss' let fvs' = unionFVInfos fvss'
return (stg_rhss, fvs') return (stg_rhss, fvs')
...@@ -233,15 +236,16 @@ consistentCafInfo id bind ...@@ -233,15 +236,16 @@ consistentCafInfo id bind
\begin{code} \begin{code}
coreToTopStgRhs coreToTopStgRhs
:: DynFlags :: DynFlags
-> Module
-> FreeVarsInfo -- Free var info for the scope of the binding -> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr) -> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo) -> LneM (StgRhs, FreeVarsInfo)
coreToTopStgRhs dflags scope_fv_info (bndr, rhs) coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
; lv_info <- freeVarsToLiveVars rhs_fvs ; lv_info <- freeVarsToLiveVars rhs_fvs
; let stg_rhs = mkTopStgRhs dflags rhs_fvs (mkSRT lv_info) bndr_info new_rhs ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) } rhs_fvs) }
...@@ -267,22 +271,22 @@ coreToTopStgRhs dflags scope_fv_info (bndr, rhs) ...@@ -267,22 +271,22 @@ coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
ptext (sLit "Id arity:") <+> ppr id_arity, ptext (sLit "Id arity:") <+> ppr id_arity,
ptext (sLit "STG arity:") <+> ppr stg_arity] ptext (sLit "STG arity:") <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> FreeVarsInfo mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> SRT -> StgBinderInfo -> StgExpr -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs -> StgRhs
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body) mkTopStgRhs _ _ rhs_fvs srt binder_info (StgLam bndrs body)
= StgRhsClosure noCCS binder_info = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs) (getFVs rhs_fvs)
ReEntrant ReEntrant
srt srt
bndrs body bndrs body
mkTopStgRhs dflags _ _ _ (StgConApp con args) mkTopStgRhs dflags this_mod _ _ _ (StgConApp con args)
| not (isDllConApp dflags con args) -- Dynamic StgConApps are updatable | not (isDllConApp dflags this_mod con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args = StgRhsCon noCCS con args
mkTopStgRhs _ rhs_fvs srt binder_info rhs mkTopStgRhs _ _ rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs) (getFVs rhs_fvs)
Updatable Updatable
......
...@@ -103,17 +103,17 @@ data GenStgArg occ ...@@ -103,17 +103,17 @@ data GenStgArg occ
-- | Does this constructor application refer to -- | Does this constructor application refer to
-- anything in a different *Windows* DLL? -- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically -- If so, we can't allocate it statically
isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags con args isDllConApp dflags this_mod con args
| platformOS (targetPlatform dflags) == OSMinGW32 | platformOS (targetPlatform dflags) == OSMinGW32
= isDllName dflags this_pkg (dataConName con) || any is_dll_arg args = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args
| otherwise = False | otherwise = False
where where
-- NB: typePrimRep is legit because any free variables won't have -- NB: typePrimRep is legit because any free variables won't have
-- unlifted type (there are no unlifted things at top level) -- unlifted type (there are no unlifted things at top level)
is_dll_arg :: StgArg -> Bool is_dll_arg :: StgArg -> Bool
is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
&& isDllName dflags this_pkg (idName v) && isDllName dflags this_pkg this_mod (idName v)
is_dll_arg _ = False is_dll_arg _ = False
this_pkg = thisPackage dflags this_pkg = thisPackage dflags
......
...@@ -107,7 +107,7 @@ ifneq "$$($1_NO_CHECK)" "YES" ...@@ -107,7 +107,7 @@ ifneq "$$($1_NO_CHECK)" "YES"
"$$(ghc-cabal_INPLACE)" check $1 "$$(ghc-cabal_INPLACE)" check $1
endif endif
endif endif
"$$(ghc-cabal_INPLACE)" configure $1 $2 --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) "$$(ghc-cabal_INPLACE)" configure $1 $2 "$$($1_$2_dll0_MODULES)" --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS)
ifeq "$$($1_$2_PROG)" "" ifeq "$$($1_$2_PROG)" ""
ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO" ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO"
$$(call cmd,$1_$2_GHC_PKG) update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config $$(call cmd,$1_$2_GHC_PKG) update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config
......
...@@ -123,6 +123,14 @@ $1_$2_$3_ALL_HC_OPTS = \ ...@@ -123,6 +123,14 @@ $1_$2_$3_ALL_HC_OPTS = \
$$(if $$(findstring YES,$$($1_$2_SplitObjs)),$$(if $$(findstring dyn,$3),,-split-objs),) \ $$(if $$(findstring YES,$$($1_$2_SplitObjs)),$$(if $$(findstring dyn,$3),,-split-objs),) \
$$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),$$(if $$(findstring v,$3),-dynamic-too)) $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),$$(if $$(findstring v,$3),-dynamic-too))
ifeq "$3" "dyn"
ifeq "$$(HostOS_CPP)" "mingw32"
ifneq "$$($1_$2_dll0_MODULES)" ""
$1_$2_$3_ALL_HC_OPTS += -dll-split $1/$2/dll-split
endif
endif
endif
ifeq "$3" "dyn" ifeq "$3" "dyn"
ifneq "$4" "0" ifneq "$4" "0"
ifeq "$$(TargetElf)" "YES" ifeq "$$(TargetElf)" "YES"
......
...@@ -50,8 +50,8 @@ main = do hSetBuffering stdout LineBuffering ...@@ -50,8 +50,8 @@ main = do hSetBuffering stdout LineBuffering
doRegister dir distDir ghc ghcpkg topdir doRegister dir distDir ghc ghcpkg topdir
myDestDir myPrefix myLibdir myDocdir myDestDir myPrefix myLibdir myDocdir
relocatableBuild args' relocatableBuild args'
"configure" : dir : distDir : config_args -> "configure" : dir : distDir : dll0Modules : config_args ->
generate dir distDir config_args generate dir distDir dll0Modules config_args
"sdist" : dir : distDir : [] -> "sdist" : dir : distDir : [] ->
doSdist dir distDir doSdist dir distDir
["--version"] -> ["--version"] ->
...@@ -298,8 +298,8 @@ mangleLbi "compiler" "stage2" lbi ...@@ -298,8 +298,8 @@ mangleLbi "compiler" "stage2" lbi
_ -> False _ -> False
mangleLbi _ _ lbi = lbi mangleLbi _ _ lbi = lbi
generate :: FilePath -> FilePath -> [String] -> IO () generate :: FilePath -> FilePath -> String -> [String] -> IO ()
generate directory distdir config_args generate directory distdir dll0Modules config_args
= withCurrentDirectory directory = withCurrentDirectory directory
$ do let verbosity = normal $ do let verbosity = normal
-- XXX We shouldn't just configure with the default flags -- XXX We shouldn't just configure with the default flags
...@@ -403,9 +403,12 @@ generate directory distdir config_args ...@@ -403,9 +403,12 @@ generate directory distdir config_args
wrappedLibraryDirs <- wrap libraryDirs wrappedLibraryDirs <- wrap libraryDirs
let variablePrefix = directory ++ '_':distdir let variablePrefix = directory ++ '_':distdir
mods = map display modules
otherMods = map display (otherModules bi)
allMods = mods ++ otherMods
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
variablePrefix ++ "_MODULES = " ++ unwords (map display modules), variablePrefix ++ "_MODULES = " ++ unwords mods,
variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)), variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd, variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), variablePrefix ++ "_HS_SRC_DIRS = "