blob: c3f5a15a4a31545659baa6d8e73a31b076e11515 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
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 compiler/ghc.mk, or building DLLs on Windows 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)
|
