hadrian: eliminate most of the remaining big rule enumerations
[ghc.git] / hadrian / src / Rules / Program.hs
1 module Rules.Program (buildProgramRules) where
2
3 import Hadrian.Haskell.Cabal
4 import Hadrian.Haskell.Cabal.Type
5
6 import Base
7 import Context
8 import Expression hiding (stage, way)
9 import Oracles.Flag
10 import Oracles.ModuleFiles
11 import Packages
12 import Settings
13 import Settings.Default
14 import Target
15 import Utilities
16
17 -- | TODO: Drop code duplication
18 buildProgramRules :: [(Resource, Int)] -> Rules ()
19 buildProgramRules rs = do
20 root <- buildRootRules
21 forM_ [Stage0 ..] $ \stage ->
22 [ root -/- stageString stage -/- "bin" -/- "*"
23 , root -/- stageString stage -/- "lib/bin" -/- "*" ] |%> \bin -> do
24 programContexts <- getProgramContexts stage
25 case lookupProgramContext bin programContexts of
26 Nothing -> error $ "Unknown program " ++ show bin
27 Just ctx -> buildProgram bin ctx rs
28
29 getProgramContexts :: Stage -> Action [(FilePath, Context)]
30 getProgramContexts stage = do
31 -- This is quite inefficient, but we can't access 'programName' from
32 -- 'Rules', because it is an 'Action' depending on an oracle.
33 sPackages <- filter isProgram <$> stagePackages stage
34 tPackages <- testsuitePackages
35 -- TODO: Shall we use Stage2 for testsuite packages instead?
36 let allPackages = sPackages
37 ++ if stage == Stage1 then tPackages else []
38 fmap concat . forM allPackages $ \pkg -> do
39 -- the iserv pkg results in three different programs at
40 -- the moment, ghc-iserv (built the vanilla way),
41 -- ghc-iserv-prof (built the profiling way), and
42 -- ghc-iserv-dyn (built the dynamic way).
43 -- The testsuite requires all to be present, so we
44 -- make sure that we cover these
45 -- "prof-build-under-other-name" cases.
46 -- iserv gets its names from Packages.hs:programName
47 let allCtxs = [ vanillaContext stage pkg
48 , Context stage pkg profiling
49 , Context stage pkg dynamic
50 ]
51 forM allCtxs $ \ctx -> do
52 name <- programName ctx
53 return (name <.> exe, ctx)
54
55 lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context
56 lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs
57
58 buildProgram :: FilePath -> Context -> [(Resource, Int)] -> Action ()
59 buildProgram bin ctx@(Context{..}) rs = do
60 -- Custom dependencies: this should be modeled better in the
61 -- Cabal file somehow.
62 -- TODO: Is this still needed? See 'runtimeDependencies'.
63 when (package == hsc2hs) $ do
64 -- 'Hsc2hs' needs the @template-hsc.h@ file.
65 template <- templateHscPath stage
66 need [template]
67 when (package == ghc) $ do
68 -- GHC depends on @settings@, @platformConstants@,
69 -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
70 -- @llvm-passes@.
71 need =<< ghcDeps stage
72
73 cross <- flag CrossCompiling
74 -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
75 case (cross, stage) of
76 (True, s) | s > Stage0 -> do
77 srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
78 copyFile (srcDir -/- takeFileName bin) bin
79 (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
80 srcDir <- stageLibPath Stage0 <&> (-/- "bin")
81 copyFile (srcDir -/- takeFileName bin) bin
82 _ -> buildBinary rs bin ctx
83
84 buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
85 buildBinary rs bin context@Context {..} = do
86 needLibrary =<< contextDependencies context
87 when (stage > Stage0) $ do
88 ways <- interpretInContext context (getLibraryWays <> getRtsWays)
89 needLibrary [ rtsContext { way = w } | w <- ways ]
90 cSrcs <- interpretInContext context (getContextData cSrcs)
91 cObjs <- mapM (objectPath context) cSrcs
92 hsObjs <- hsObjects context
93 let binDeps = cObjs ++ hsObjs
94 need binDeps
95 buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
96 synopsis <- pkgSynopsis package
97 putSuccess $ renderProgram
98 (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis