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