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

3 files changed, 124 insertions, 0 deletions

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))