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.

9 files changed, 88 insertions, 42 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index c14c958218..1bcb695020 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -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.
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index d2a25ebd6c..9bfa22b344 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 61d64e407c..7dc0ef6536 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index a618a74e1a..caa68d5ddf 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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" #-}
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 54d9d1b66b..cc8dfe3eb7 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -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
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 72b887a588..6bb28613b6 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -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
diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs
index 77e2cb78c0..5417ad491e 100644
--- a/compiler/profiling/SCCfinal.lhs
+++ b/compiler/profiling/SCCfinal.lhs
@@ -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
 
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index ac253f3e95..1e737f91e9 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -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
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index fe8b1fc975..3fa8c68c16 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -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