Build and copy libffi shared libraries correctly and enable dynamically linking ghc.
[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 ctx <- programContext stage pkg -- TODO: see todo on programContext.
48 let allCtxs = if pkg == iserv
49 then [ vanillaContext stage pkg
50 , Context stage pkg profiling
51 , Context stage pkg dynamic
52 ]
53 else [ ctx ]
54 forM allCtxs $ \ctx -> do
55 name <- programName ctx
56 return (name <.> exe, ctx)
57
58 lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context
59 lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs
60
61 buildProgram :: FilePath -> Context -> [(Resource, Int)] -> Action ()
62 buildProgram bin ctx@(Context{..}) rs = do
63 -- Custom dependencies: this should be modeled better in the
64 -- Cabal file somehow.
65 -- TODO: Is this still needed? See 'runtimeDependencies'.
66 when (package == hsc2hs) $ do
67 -- 'Hsc2hs' needs the @template-hsc.h@ file.
68 template <- templateHscPath stage
69 need [template]
70 when (package == ghc) $ do
71 -- GHC depends on @settings@, @platformConstants@,
72 -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
73 -- @llvm-passes@.
74 need =<< ghcDeps stage
75 when (package == haddock) $ do
76 -- Haddock has a resource folder
77 need =<< haddockDeps stage
78
79 cross <- flag CrossCompiling
80 -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
81 case (cross, stage) of
82 (True, s) | s > Stage0 -> do
83 srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
84 copyFile (srcDir -/- takeFileName bin) bin
85 (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
86 srcDir <- stageLibPath Stage0 <&> (-/- "bin")
87 copyFile (srcDir -/- takeFileName bin) bin
88 _ -> buildBinary rs bin ctx
89
90 buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
91 buildBinary rs bin context@Context {..} = do
92 needLibrary =<< contextDependencies context
93 when (stage > Stage0) $ do
94 ways <- interpretInContext context (getLibraryWays <> getRtsWays)
95 needLibrary [ (rtsContext stage) { way = w } | w <- ways ]
96 cSrcs <- interpretInContext context (getContextData cSrcs)
97 cObjs <- mapM (objectPath context) cSrcs
98 hsObjs <- hsObjects context
99 let binDeps = cObjs ++ hsObjs
100 need binDeps
101 buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
102 synopsis <- pkgSynopsis package
103 putSuccess $ renderProgram
104 (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis