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 =
-- in a DLL, be it a data reference or not.
labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool
labelDynamic dflags this_pkg _this_mod lbl =
labelDynamic dflags this_pkg this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
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
-- its own shared library.
......
......@@ -65,9 +65,10 @@ cgTopRhsCon id con args
gen_code =
do { dflags <- getDynFlags
; this_mod <- getModuleName
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- 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 ()
-- LAY IT OUT
......
......@@ -610,6 +610,14 @@ data DynFlags = DynFlags {
dynObjectSuf :: 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,
dynOutputFile :: Maybe String,
outputHi :: Maybe String,
......@@ -1249,6 +1257,9 @@ defaultDynFlags mySettings =
dynObjectSuf = "dyn_" ++ phaseInputExt StopLn,
dynHiSuf = "dyn_hi",
dllSplitFile = Nothing,
dllSplit = Nothing,
pluginModNames = [],
pluginModNameOpts = [],
......@@ -1848,9 +1859,23 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
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 dflags
......@@ -2029,6 +2054,8 @@ dynamic_flags = [
, Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib }))
, Flag "dynload" (hasArg parseDynLibLoaderMode)
, 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 ---------------------------------------------------
, Flag "L" (Prefix addLibraryPath)
......
......@@ -1324,7 +1324,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
myCoreToStg dflags this_mod prepd_binds = do
stg_binds
<- {-# SCC "Core2Stg" #-}
coreToStg dflags prepd_binds
coreToStg dflags this_mod prepd_binds
(stg_binds2, cost_centre_info)
<- {-# SCC "Stg2Stg" #-}
......
......@@ -1039,13 +1039,24 @@ missingDependencyMsg (Just parent)
-- -----------------------------------------------------------------------------
-- | 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
-- the synbol comes from another dynamically-linked package,
-- 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
| 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
-- -----------------------------------------------------------------------------
......
......@@ -328,7 +328,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- See Note [Which rules to expose]
; (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,
isExternalName (idName id)]
......@@ -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
tidyTopBinds :: HscEnv
-> Module
-> UnfoldEnv
-> TidyOccEnv
-> 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
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ tidy mkIntegerId init_env binds
......@@ -996,7 +997,7 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
this_pkg = thisPackage dflags
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
in
(env2, b':bs')
......@@ -1004,22 +1005,23 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds
------------------------
tidyTopBind :: DynFlags
-> PackageId
-> Module
-> Id
-> UnfoldEnv
-> 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')
where
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)
subst2 = extendVarEnv subst1 bndr bndr'
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')
where
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)
-- 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 this_pkg (mkIntegerId, subst1) (idArity bndr) rhs)
| or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
......@@ -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.
\begin{code}
hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr
hasCafRefs :: DynFlags -> PackageId -> Module
-> (Id, VarEnv Var) -> Arity -> CoreExpr
-> CafInfo
hasCafRefs dflags this_pkg p arity expr
hasCafRefs dflags this_pkg this_mod p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
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)
-- NB. we pass in the arity of the expression, which is expected
......
......@@ -91,7 +91,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
(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
-- Eliminate _scc_ ... and turn into StgRhsCon
......
......@@ -26,6 +26,7 @@ import CostCentre ( noCCS )
import VarSet
import VarEnv
import Maybes ( maybeToBool )
import Module
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
......@@ -141,10 +142,10 @@ for x, solely to put in the SRTs lower down.
%************************************************************************
\begin{code}
coreToStg :: DynFlags -> CoreProgram -> IO [StgBinding]
coreToStg dflags pgm
coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags this_mod pgm
= return pgm'
where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
......@@ -153,35 +154,37 @@ coreExprToStg expr
coreTopBindsToStg
:: DynFlags
-> Module
-> IdEnv HowBound -- environment for the bindings
-> CoreProgram
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags env (b:bs)
coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags this_mod 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 dflags env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
(env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
coreTopBindToStg
:: DynFlags
-> Module
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
coreTopBindToStg dflags env body_fvs (NonRec id rhs)
coreTopBindToStg dflags this_mod 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 dflags body_fvs (id,rhs)
(stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
return (stg_rhs, fvs')
bind = StgNonRec id stg_rhs
......@@ -193,7 +196,7 @@ coreTopBindToStg dflags env body_fvs (NonRec id rhs)
-- assertion again!
(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) )
let
binders = map fst pairs
......@@ -204,7 +207,7 @@ coreTopBindToStg dflags env body_fvs (Rec pairs)
(stg_rhss, fvs')
= 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'
return (stg_rhss, fvs')
......@@ -233,15 +236,16 @@ consistentCafInfo id bind
\begin{code}
coreToTopStgRhs
:: DynFlags
-> Module
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> 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
; 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
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
......@@ -267,22 +271,22 @@ coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
ptext (sLit "Id arity:") <+> ppr id_arity,
ptext (sLit "STG arity:") <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> FreeVarsInfo
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body)
mkTopStgRhs _ _ rhs_fvs srt binder_info (StgLam bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
mkTopStgRhs dflags _ _ _ (StgConApp con args)
| not (isDllConApp dflags con args) -- Dynamic StgConApps are updatable
mkTopStgRhs dflags this_mod _ _ _ (StgConApp con args)
| not (isDllConApp dflags this_mod con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args
mkTopStgRhs _ rhs_fvs srt binder_info rhs
mkTopStgRhs _ _ rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
......
......@@ -103,17 +103,17 @@ data GenStgArg occ
-- | Does this constructor application refer to
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool
isDllConApp dflags con args
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags this_mod con args
| 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
where
-- NB: typePrimRep is legit because any free variables won't have
-- unlifted type (there are no unlifted things at top level)
is_dll_arg :: StgArg -> Bool
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
this_pkg = thisPackage dflags
......
......@@ -107,7 +107,7 @@ ifneq "$$($1_NO_CHECK)" "YES"
"$$(ghc-cabal_INPLACE)" check $1
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)" ""
ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO"
$$(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 = \
$$(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))
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"
ifneq "$4" "0"
ifeq "$$(TargetElf)" "YES"
......
......@@ -50,8 +50,8 @@ main = do hSetBuffering stdout LineBuffering
doRegister dir distDir ghc ghcpkg topdir
myDestDir myPrefix myLibdir myDocdir
relocatableBuild args'
"configure" : dir : distDir : config_args ->
generate dir distDir config_args
"configure" : dir : distDir : dll0Modules : config_args ->
generate dir distDir dll0Modules config_args
"sdist" : dir : distDir : [] ->
doSdist dir distDir
["--version"] ->
......@@ -298,8 +298,8 @@ mangleLbi "compiler" "stage2" lbi
_ -> False
mangleLbi _ _ lbi = lbi
generate :: FilePath -> FilePath -> [String] -> IO ()
generate directory distdir config_args
generate :: FilePath -> FilePath -> String -> [String] -> IO ()
generate directory distdir dll0Modules config_args
= withCurrentDirectory directory
$ do let verbosity = normal
-- XXX We shouldn't just configure with the default flags
......@@ -403,9 +403,12 @@ generate directory distdir config_args
wrappedLibraryDirs <- wrap libraryDirs
let variablePrefix = directory ++ '_':distdir
mods = map display modules
otherMods = map display (otherModules bi)
allMods = mods ++ otherMods
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
variablePrefix ++ "_MODULES = " ++ unwords mods,
variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
variablePrefix ++ "_DEPS = " ++ unwords deps,
......@@ -449,6 +452,11 @@ generate directory distdir config_args
writeFile (distdir ++ "/haddock-prologue.txt") $
if null (description pd) then synopsis pd
else description pd
unless (null dll0Modules) $
do let dll0Mods = words dll0Modules
dllMods = allMods \\ dll0Mods
dllModSets = map unwords [dll0Mods, dllMods]
writeFile (distdir ++ "/dll-split") $ unlines dllModSets
where
escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
wrap = mapM wrap1
......
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