Hadrian: support dynamically linking ghc
[ghc.git] / hadrian / src / Settings / Builders / Ghc.hs
1 module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where
2
3 import Hadrian.Haskell.Cabal
4 import Hadrian.Haskell.Cabal.Type
5
6 import Flavour
7 import Packages
8 import Settings.Builders.Common
9 import Settings.Warnings
10 import qualified Context as Context
11
12 ghcBuilderArgs :: Args
13 ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies]
14
15 compileAndLinkHs :: Args
16 compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
17 mconcat [ arg "-Wall"
18 , commonGhcArgs
19 , splitObjects <$> flavour ? arg "-split-objs"
20 , ghcLinkArgs
21 , defaultGhcWarningsArgs
22 , builder (Ghc CompileHs) ? arg "-c"
23 , getInputs
24 , arg "-o", arg =<< getOutput ]
25
26 compileC :: Args
27 compileC = builder (Ghc CompileCWithGhc) ? do
28 way <- getWay
29 let ccArgs = [ getContextData ccOpts
30 , getStagedSettingList ConfCcArgs
31 , cIncludeArgs
32 , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] ]
33 mconcat [ arg "-Wall"
34 , ghcLinkArgs
35 , commonGhcArgs
36 , mconcat (map (map ("-optc" ++) <$>) ccArgs)
37 , defaultGhcWarningsArgs
38 , arg "-c"
39 , getInputs
40 , arg "-o"
41 , arg =<< getOutput ]
42
43 ghcLinkArgs :: Args
44 ghcLinkArgs = builder (Ghc LinkHs) ? do
45 pkg <- getPackage
46 libs <- pkg == hp2ps ? pure ["m"]
47 intLib <- getIntegerPackage
48 gmpLibs <- notStage0 ? intLib == integerGmp ? pure ["gmp"]
49 dynamic <- requiresDynamic
50
51 -- Relative path from the output (rpath $ORIGIN).
52 originPath <- dropFileName <$> getOutput
53 context <- getContext
54 libPath' <- expr (libPath context)
55 distDir <- expr Context.distDir
56 let
57 distPath = libPath' -/- distDir
58 originToLibsDir = makeRelativeNoSysLink originPath distPath
59
60 mconcat [ dynamic ? mconcat
61 [ arg "-dynamic"
62 -- TODO what about windows / OSX?
63 , notStage0 ? pure
64 [ "-optl-Wl,-rpath"
65 , "-optl-Wl," ++ ("$ORIGIN" -/- originToLibsDir) ]
66 ]
67 , (dynamic && isLibrary pkg) ?
68 pure [ "-shared", "-dynload", "deploy" ]
69 , arg "-no-auto-link-packages"
70 , nonHsMainPackage pkg ? arg "-no-hs-main"
71 , not (nonHsMainPackage pkg) ? arg "-rtsopts"
72 , pure [ "-optl-l" ++ lib | lib <- libs ++ gmpLibs ]
73 ]
74
75 findHsDependencies :: Args
76 findHsDependencies = builder (Ghc FindHsDependencies) ? do
77 ways <- getLibraryWays
78 mconcat [ arg "-M"
79 , commonGhcArgs
80 , arg "-include-pkg-deps"
81 , arg "-dep-makefile", arg =<< getOutput
82 , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ]
83 , getInputs ]
84
85 haddockGhcArgs :: Args
86 haddockGhcArgs = mconcat [ commonGhcArgs, getContextData hcOpts ]
87
88 -- | Common GHC command line arguments used in 'ghcBuilderArgs',
89 -- 'ghcCBuilderArgs', 'ghcMBuilderArgs' and 'haddockGhcArgs'.
90 commonGhcArgs :: Args
91 commonGhcArgs = do
92 way <- getWay
93 path <- getBuildPath
94 ghcVersion <- expr ghcVersionH
95 mconcat [ arg "-hisuf", arg $ hisuf way
96 , arg "-osuf" , arg $ osuf way
97 , arg "-hcsuf", arg $ hcsuf way
98 , wayGhcArgs
99 , packageGhcArgs
100 , includeGhcArgs
101 -- When compiling RTS for Stage1 or Stage2 we do not have it (yet)
102 -- in the package database. We therefore explicity supply the path
103 -- to the @ghc-version@ file, to prevent GHC from trying to open the
104 -- RTS package in the package database and failing.
105 , package rts ? notStage0 ? arg ("-ghcversion-file=" ++ ghcVersion)
106 , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
107 , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
108 , map ("-optP" ++) <$> getContextData cppOpts
109 , arg "-odir" , arg path
110 , arg "-hidir" , arg path
111 , arg "-stubdir" , arg path ]
112
113 -- TODO: Do '-ticky' in all debug ways?
114 wayGhcArgs :: Args
115 wayGhcArgs = do
116 way <- getWay
117 dynamic <- requiresDynamic
118 mconcat [ if dynamic
119 then pure ["-fPIC", "-dynamic"]
120 else arg "-static"
121 , (Threaded `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
122 , (Debug `wayUnit` way) ? arg "-optc-DDEBUG"
123 , (Profiling `wayUnit` way) ? arg "-prof"
124 , (Logging `wayUnit` way) ? arg "-eventlog"
125 , (way == debug || way == debugDynamic) ?
126 pure ["-ticky", "-DTICKY_TICKY"] ]
127
128 packageGhcArgs :: Args
129 packageGhcArgs = do
130 package <- getPackage
131 pkgId <- expr $ pkgIdentifier package
132 mconcat [ arg "-hide-all-packages"
133 , arg "-no-user-package-db"
134 , packageDatabaseArgs
135 , libraryPackage ? arg ("-this-unit-id " ++ pkgId)
136 , map ("-package-id " ++) <$> getContextData depIds ]
137
138 includeGhcArgs :: Args
139 includeGhcArgs = do
140 pkg <- getPackage
141 path <- getBuildPath
142 root <- getBuildRoot
143 context <- getContext
144 srcDirs <- getContextData srcDirs
145 autogen <- expr $ autogenPath context
146 mconcat [ arg "-i"
147 , arg $ "-i" ++ path
148 , arg $ "-i" ++ autogen
149 , pure [ "-i" ++ pkgPath pkg -/- dir | dir <- srcDirs ]
150 , cIncludeArgs
151 , arg $ "-I" ++ root -/- generatedDir
152 , arg $ "-optc-I" ++ root -/- generatedDir
153 , pure ["-optP-include", "-optP" ++ autogen -/- "cabal_macros.h"] ]
154
155 -- Check if building dynamically is required. GHC is a special case that needs
156 -- to be built dynamically if any of the RTS ways is dynamic.
157 requiresDynamic :: Expr Bool
158 requiresDynamic = do
159 pkg <- getPackage
160 way <- getWay
161 rtsWays <- getRtsWays
162 let
163 dynRts = any (Dynamic `wayUnit`) rtsWays
164 dynWay = Dynamic `wayUnit` way
165 return $ if pkg == ghc
166 then dynRts || dynWay
167 else dynWay