314d1240d214c141c1e0eb17e617aa69befe8406
[hadrian.git] / src / Rules / Library.hs
1 module Rules.Library (libraryRules) where
2
3 import Hadrian.Haskell.Cabal
4 import Hadrian.Haskell.Cabal.PackageData as PD
5 import Hadrian.Package.Type
6
7 import Base
8 import Context
9 import Expression hiding (way, package)
10 import Flavour
11 import GHC.Packages
12 import Oracles.ModuleFiles
13 import Oracles.Setting (libsuf)
14 import Rules.Gmp
15 import Settings
16 import Target
17 import Utilities
18
19 import Data.Functor
20 import qualified System.Directory as IO
21 import qualified Text.Parsec as Parsec
22
23 -- * Library 'Rules'
24
25 libraryRules :: Rules ()
26 libraryRules = do
27 root <- buildRootRules
28
29 root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib"
30 root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so"
31 root -/- "//*.a" %> buildStaticLib root
32 priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root
33
34 -- * 'Action's for building libraries
35
36 -- | Build a static library ('LibA') under the given build root, whose
37 -- path is the second argument.
38 buildStaticLib :: FilePath -> FilePath -> Action ()
39 buildStaticLib root archivePath = do
40 l@(BuildPath _ stage _ (LibA pkgname _ way))
41 <- parsePath (parseBuildLibA root)
42 "<.a library (build) path parser>"
43 archivePath
44 let context = libAContext l
45 objs <- libraryObjects context
46 removeFile archivePath
47 build $ target context (Ar Pack stage) objs [archivePath]
48 synopsis <- pkgSynopsis context
49 putSuccess $ renderLibrary
50 (quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
51 archivePath synopsis
52
53 -- | Build a dynamic library ('LibDyn') under the given build root,
54 -- with the given suffix (@.so@ or @.dylib@, @.dll@ in the future),
55 -- where the complete path of the archive to build is given as the
56 -- third argument.
57 buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
58 buildDynamicLibUnix root suffix dynlibpath = do
59 dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
60 let context = libDynContext dynlib
61 deps <- contextDependencies context
62 need =<< mapM pkgLibraryFile deps
63 objs <- libraryObjects context
64 build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
65
66 -- | Build a "ghci library" ('LibGhci') under the given build root,
67 -- with the complete path of the file to build is given as the second
68 -- argument.
69 buildGhciLibO :: FilePath -> FilePath -> Action ()
70 buildGhciLibO root ghcilibPath = do
71 l@(BuildPath _ stage _ (LibGhci _ _ _))
72 <- parsePath (parseBuildLibGhci root)
73 "<.o ghci lib (build) path parser>"
74 ghcilibPath
75 let context = libGhciContext l
76 objs <- allObjects context
77 need objs
78 build $ target context (Ld stage) objs [ghcilibPath]
79
80 -- * Helpers
81
82 -- | Return all Haskell and non-Haskell object files for the
83 -- given 'Context'.
84 allObjects :: Context -> Action [FilePath]
85 allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
86
87 -- | Return all the non-Haskell object files for the given library
88 -- context (object files built from C, C-- and sometimes other things).
89 nonHsObjects :: Context -> Action [FilePath]
90 nonHsObjects context = do
91 cObjs <- cObjects context
92 cmmSrcs <- interpretInContext context (getPackageData PD.cmmSrcs)
93 cmmObjs <- mapM (objectPath context) cmmSrcs
94 eObjs <- extraObjects context
95 return $ cObjs ++ cmmObjs ++ eObjs
96
97 -- | Return all the C object files needed to build the given library
98 -- context.
99 cObjects :: Context -> Action [FilePath]
100 cObjects context = do
101 srcs <- interpretInContext context (getPackageData PD.cSrcs)
102 objs <- mapM (objectPath context) srcs
103 return $ if way context == threaded
104 then objs
105 else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
106
107 -- | Return extra object files needed to build the given library context. The
108 -- resulting list is non empty only when the package from the 'Context' is
109 -- /integer-gmp/.
110 extraObjects :: Context -> Action [FilePath]
111 extraObjects context
112 | package context == integerGmp = do
113 gmpPath <- gmpBuildPath
114 need [gmpPath -/- gmpLibraryH]
115 map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
116 | otherwise = return []
117
118 -- | Return all the object files to be put into the library
119 -- we're building for the given 'Context'.
120 libraryObjects :: Context -> Action [FilePath]
121 libraryObjects context@Context{..} = do
122 hsObjs <- hsObjects context
123 noHsObjs <- nonHsObjects context
124
125 -- This will create split objects if required (we don't track them
126 -- explicitly as this would needlessly bloat the Shake database).
127 need $ noHsObjs ++ hsObjs
128
129 split <- interpretInContext context =<< splitObjects <$> flavour
130 let getSplitObjs = concatForM hsObjs $ \obj -> do
131 let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
132 contents <- liftIO $ IO.getDirectoryContents dir
133 return . map (dir -/-) $ filter (not . all (== '.')) contents
134
135 (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
136
137 -- * Library paths types and parsers
138
139 -- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
140 data LibA = LibA String [Integer] Way
141 deriving (Eq, Show)
142
143 -- | > <so or dylib>
144 data DynLibExt = So | Dylib
145 deriving (Eq, Show)
146
147 -- | > libHS<pkg name>-<pkg version>-ghc<ghc version>[_<way suffix>].<so or dylib>
148 data LibDyn = LibDyn String [Integer] Way DynLibExt
149 deriving (Eq, Show)
150
151 -- | > HS<pkg name>-<pkg version>[_<way suffix>].o
152 data LibGhci = LibGhci String [Integer] Way
153 deriving (Eq, Show)
154
155 -- | A path of the form
156 --
157 -- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
158 --
159 -- where @something@ describes a library to be build for the given package.
160 --
161 -- @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn'
162 -- and 'LibGhci' successively in this module, depending on the type of library
163 -- we're giving the build rules for.
164 data BuildPath a
165 = BuildPath FilePath -- ^ > <build root>/
166 Stage -- ^ > stage<N>/
167 FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
168 a -- ^ > whatever comes after 'build/'
169 deriving (Eq, Show)
170
171 -- | Get the 'Context' corresponding to the build path for a given static library.
172 libAContext :: BuildPath LibA -> Context
173 libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way))
174 = Context stage pkg way
175 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
176
177 -- | Get the 'Context' corresponding to the build path for a given ghci library.
178 libGhciContext :: BuildPath LibGhci -> Context
179 libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way))
180 = Context stage pkg way
181 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
182
183 -- | Get the 'Context' corresponding to the build path for a given dynamic library.
184 libDynContext :: BuildPath LibDyn -> Context
185 libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _))
186 = Context stage pkg way
187 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
188
189 -- | Parse a build path for a library to be built under the given build root,
190 -- where the filename will be parsed with the given parser argument.
191 parseBuildPath
192 :: FilePath -- ^ build root
193 -> Parsec.Parsec String () a -- ^ what to parse after @build/@
194 -> Parsec.Parsec String () (BuildPath a)
195 parseBuildPath root afterBuild = do
196 _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
197 stage <- parseStage
198 _ <- Parsec.char '/'
199 pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/")
200 a <- afterBuild
201 return (BuildPath root stage pkgpath a)
202
203 -- | Parse a path to a static library to be built, making sure the path starts
204 -- with the given build root.
205 parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
206 parseBuildLibA root = parseBuildPath root parseLibAFilename
207 Parsec.<?> "build path for a static library"
208
209 -- | Parse a path to a ghci library to be built, making sure the path starts
210 -- with the given build root.
211 parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
212 parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
213 Parsec.<?> "build path for a ghci library"
214
215 -- | Parse a path to a dynamic library to be built, making sure the path starts
216 -- with the given build root.
217 parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
218 parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
219 Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
220
221 -- | Parse the filename of a static library to be built into a 'LibA' value.
222 parseLibAFilename :: Parsec.Parsec String () LibA
223 parseLibAFilename = do
224 _ <- Parsec.string "libHS"
225 (pkgname, pkgver) <- parsePkgId
226 way <- parseWaySuffix vanilla
227 _ <- Parsec.string ".a"
228 return (LibA pkgname pkgver way)
229
230 -- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
231 parseLibGhciFilename :: Parsec.Parsec String () LibGhci
232 parseLibGhciFilename = do
233 _ <- Parsec.string "HS"
234 (pkgname, pkgver) <- parsePkgId
235 way <- parseWaySuffix vanilla
236 _ <- Parsec.string ".o"
237 return (LibGhci pkgname pkgver way)
238
239 -- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
240 parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
241 parseLibDynFilename ext = do
242 _ <- Parsec.string "libHS"
243 (pkgname, pkgver) <- parsePkgId
244 _ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
245 way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
246 _ <- Parsec.string ("." ++ ext)
247 return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
248
249 -- To be kept in sync with Stage.hs's stageString function
250 -- | Parse @"stageX"@ into a 'Stage'.
251 parseStage :: Parsec.Parsec String () Stage
252 parseStage = (Parsec.string "stage" *> Parsec.choice
253 [ Parsec.string (show n) $> toEnum n
254 | n <- map fromEnum [minBound .. maxBound :: Stage]
255 ]) Parsec.<?> "stage string"
256
257 -- To be kept in sync with the show instances in
258 -- Way.Type, until we perhaps use some bidirectional
259 -- parsing/pretty printing approach or library.
260 -- | Parse a way suffix, returning the argument when no suffix is found
261 -- (the argument will be vanilla in most cases, but dynamic when we parse
262 -- the way suffix out of a shared library file name.
263 parseWaySuffix :: Way -> Parsec.Parsec String () Way
264 parseWaySuffix w = Parsec.choice
265 [ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
266 , pure w
267 ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
268
269 where parseWayUnit = Parsec.choice
270 [ Parsec.string "thr" *> pure Threaded
271 , Parsec.char 'd' *>
272 (Parsec.choice
273 [ Parsec.string "ebug" *> pure Debug
274 , Parsec.string "yn" *> pure Dynamic
275 ]
276 )
277 , Parsec.char 'p' *> pure Profiling
278 , Parsec.char 'l' *> pure Logging
279 ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
280
281 -- | Parse a @"pkgname-pkgversion"@ string into
282 -- the package name and the integers that make up the
283 -- package version.
284 parsePkgId :: Parsec.Parsec String () (String, [Integer])
285 parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
286
287 where parsePkgId' currName = do
288 s <- Parsec.many1 Parsec.alphaNum
289 _ <- Parsec.char '-'
290 let newName = if null currName then s else currName ++ "-" ++ s
291 Parsec.choice [ (newName,) <$> parsePkgVersion
292 , parsePkgId' newName
293 ]
294
295 -- | Parse "."-separated integers that describe a package's version.
296 parsePkgVersion :: Parsec.Parsec String () [Integer]
297 parsePkgVersion = fmap reverse (parsePkgVersion' []) Parsec.<?> "package version"
298
299 where parsePkgVersion' xs = do
300 n <- parseNatural
301 Parsec.choice
302 [ Parsec.try (Parsec.lookAhead (Parsec.char '.' *> (Parsec.letter <|> Parsec.char '_')))
303 $> (n:xs)
304 , Parsec.char '.' *> parsePkgVersion' (n:xs)
305 , pure $ (n:xs)
306 ]
307
308 -- | Parse a natural number.
309 parseNatural :: Parsec.Parsec String () Integer
310 parseNatural = (read <$> Parsec.many1 Parsec.digit)
311 Parsec.<?> "natural number"
312
313 -- | Runs the given parser against the given path,
314 -- erroring out when the parser fails (because it shouldn't
315 -- if the code from this module is correct).
316 parsePath
317 :: Parsec.Parsec String () a -- ^ parser to run
318 -> String -- ^ string describing the input source
319 -> FilePath -- ^ path to parse
320 -> Action a
321 parsePath p inp path = case Parsec.parse p inp path of
322 Left err -> fail $ "Rules.Library.parsePath: path="
323 ++ path ++ ", error:\n" ++ show err
324 Right a -> pure a