Add a check that the Windows DLL split is OK; fixes #7780

6 files changed, 138 insertions, 0 deletions

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 74bea9a5d8..1a032cc71f 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -404,6 +404,7 @@ compiler_stage3_SplitObjs = NO
 # There are too many symbols in the ghc package for a Windows DLL.
 # We therefore need to split some of the modules off into a separate
 # DLL. This clump are the modules reachable from DynFlags:
+compiler_stage2_dll0_START_MODULE = DynFlags
 compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes Binary Bitmap BlockId BreakArray BufWrite ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes Id IdInfo IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcType TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
 
 compiler_stage2_dll0_HS_OBJS = \
diff --git a/ghc.mk b/ghc.mk
index 5843d81802..adb7c58179 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -485,6 +485,7 @@ utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk
 
 utils/ghctags/dist-install/package-data.mk: compiler/stage2/package-data.mk
+utils/dll-split/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/hpc/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk
@@ -654,6 +655,7 @@ BUILD_DIRS += utils/ghc-pkg
 BUILD_DIRS += utils/deriveConstants
 BUILD_DIRS += utils/testremove
 BUILD_DIRS += $(MAYBE_GHCTAGS)
+BUILD_DIRS += utils/dll-split
 BUILD_DIRS += utils/ghc-pwd
 BUILD_DIRS += utils/ghc-cabal
 BUILD_DIRS += $(MAYBE_HPC)
diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk
index 724a698666..9277b551b2 100644
--- a/rules/build-package-way.mk
+++ b/rules/build-package-way.mk
@@ -56,6 +56,17 @@ $1_$2_$3_ALL_OBJS = $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_NON_HS_OBJS)
 
 ifeq "$3" "dyn"
 
+ifneq "$$($1_$2_dll0_MODULES)" ""
+$$($1_$2_$3_LIB)  : $1/$2/dll-split.stamp
+ifneq "$$($1_$2_$3_LIB0)" ""
+$$($1_$2_$3_LIB0) : $1/$2/dll-split.stamp
+endif
+endif
+
+$1/$2/dll-split.stamp: $$($1_$2_depfile_haskell) inplace/bin/dll-split$$(exeext)
+	inplace/bin/dll-split $$< "$$($1_$2_dll0_START_MODULE)" "$$($1_$2_dll0_MODULES)"
+	touch $$@
+
 # Link a dynamic library
 # On windows we have to supply the extra libs this one links to when building it.
 ifeq "$$(HostOS_CPP)" "mingw32"
diff --git a/utils/dll-split/Main.hs b/utils/dll-split/Main.hs
new file mode 100644
index 0000000000..336b6d9b26
--- /dev/null
+++ b/utils/dll-split/Main.hs
@@ -0,0 +1,85 @@
+
+{-# LANGUAGE PatternGuards #-}
+
+module Main (main) where
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import System.Environment
+import System.Exit
+import System.FilePath
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+              [depfile, startModule, reachableModules] ->
+                  doit depfile
+                       (Module startModule)
+                       (Set.fromList $ map Module $ words reachableModules)
+              _ -> error "dll-split: Bad args"
+
+doit :: FilePath -> Module -> Set Module -> IO ()
+doit depfile startModule expectedReachableMods
+ = do xs <- readFile depfile
+      let ys = catMaybes $ map mkEdge $ lines xs
+          mapping = mkMap ys
+          actualReachableMods = reachable mapping startModule
+      unless (actualReachableMods == expectedReachableMods) $ do
+          let extra     = actualReachableMods   Set.\\ expectedReachableMods
+              redundant = expectedReachableMods Set.\\ actualReachableMods
+              tellSet name set = unless (Set.null set) $
+                                     let ms = map moduleName (Set.toList set)
+                                     in putStrLn (name ++ ": " ++ unwords ms)
+          putStrLn ("Reachable modules from " ++ moduleName startModule
+                 ++ " out of date")
+          putStrLn "Please fix it, or building DLLs on Widnows may break (#7780)"
+          tellSet "Redundant modules" redundant
+          tellSet "Extra modules"     extra
+          exitFailure
+
+newtype Module = Module String
+    deriving (Eq, Ord)
+
+moduleName :: Module -> String
+moduleName (Module name) = name
+
+-- Given:
+-- compiler/stage2/build/X86/Regs.o : compiler/stage2/build/CodeGen/Platform.hi
+-- Produce:
+-- Just ("X86.Regs", "CodeGen.Platform")
+mkEdge :: String -> Maybe (Module, Module)
+mkEdge str = case words str of
+             [from, ":", to]
+              | Just from' <- getModule from
+              , Just to'   <- getModule to ->
+                 Just (from', to')
+             _ ->
+                 Nothing
+    where getModule xs
+              = case stripPrefix "compiler/stage2/build/" xs of
+                Just xs' ->
+                    let name = filePathToModuleName $ dropExtension xs'
+                    in Just $ Module name
+                Nothing  -> Nothing
+          filePathToModuleName = map filePathToModuleNameChar
+          filePathToModuleNameChar '/' = '.'
+          filePathToModuleNameChar c   = c
+
+mkMap :: [(Module, Module)] -> (Map Module (Set Module))
+mkMap edges = let groupedEdges = groupBy ((==) `on` fst) $ sort edges
+                  mkEdgeMap ys = (fst (head ys), Set.fromList (map snd ys))
+              in Map.fromList $ map mkEdgeMap groupedEdges
+
+reachable :: Map Module (Set Module) -> Module -> Set Module
+reachable mapping startModule = f Set.empty startModule
+    where f done m = if m `Set.member` done
+                     then done
+                     else foldl' f (m `Set.insert` done) (get m)
+          get m = Set.toList (Map.findWithDefault Set.empty m mapping)
+
diff --git a/utils/dll-split/dll-split.cabal b/utils/dll-split/dll-split.cabal
new file mode 100644
index 0000000000..bece0a4770
--- /dev/null
+++ b/utils/dll-split/dll-split.cabal
@@ -0,0 +1,21 @@
+Name: dll-split
+Version: 0.1
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: XXX
+Description:
+	XXX
+Category: Development
+build-type: Simple
+cabal-version: >=1.2
+
+Executable dll-split
+    Main-Is: Main.hs
+
+    Build-Depends: base       >= 4   && < 5,
+                   containers,
+                   filepath
+
diff --git a/utils/dll-split/ghc.mk b/utils/dll-split/ghc.mk
new file mode 100644
index 0000000000..324c7e04b1
--- /dev/null
+++ b/utils/dll-split/ghc.mk
@@ -0,0 +1,18 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+utils/dll-split_USES_CABAL                   = YES
+utils/dll-split_PACKAGE                      = dll-split
+utils/dll-split_dist-install_PROGNAME        = dll-split
+utils/dll-split_dist-install_INSTALL         = NO
+utils/dll-split_dist-install_INSTALL_INPLACE = YES
+$(eval $(call build-prog,utils/dll-split,dist-install,1))