Library.hs 10.3 KB
Newer Older
David Eichmann's avatar
David Eichmann committed
1
module Rules.Library (libraryRules, needLibrary, libraryTargets) where
2

3
import Hadrian.BuildPath
4
import Hadrian.Haskell.Cabal
5
import Hadrian.Haskell.Cabal.Type
6
import qualified Text.Parsec      as Parsec
Ben Gamari's avatar
Ben Gamari committed
7

8
import Base
9
import Context
10
import Expression hiding (way, package)
11
import Oracles.ModuleFiles
12
import Packages
13
import Rules.Gmp
14
import Rules.Register
15
import Target
16
import Utilities
17

18
-- * Library 'Rules'
19

20 21
libraryRules :: Rules ()
libraryRules = do
22 23 24 25
    root <- buildRootRules
    root -/- "//libHS*-*.dylib"       %> buildDynamicLibUnix root "dylib"
    root -/- "//libHS*-*.so"          %> buildDynamicLibUnix root "so"
    root -/- "//*.a"                  %> buildStaticLib      root
26
    priority 2 $ do
27 28 29 30
        root -/- "stage*/lib//libHS*-*.dylib" %> registerDynamicLibUnix root "dylib"
        root -/- "stage*/lib//libHS*-*.so"    %> registerDynamicLibUnix root "so"
        root -/- "stage*/lib//*.a"            %> registerStaticLib  root
        root -/- "//HS*-*.o"   %> buildGhciLibO root
31
        root -/- "//HS*-*.p_o" %> buildGhciLibO root
Zhen Zhang's avatar
Zhen Zhang committed
32

33 34
-- * 'Action's for building libraries

35 36 37 38 39 40 41 42 43 44 45 46 47
-- | Register (with ghc-pkg) a static library ('LibA') under the given build
-- root, whose path is the second argument.
registerStaticLib :: FilePath -> FilePath -> Action ()
registerStaticLib root archivePath = do
    -- Simply need the ghc-pkg database .conf file.
    GhcPkgPath _ stage _ (LibA name version _)
        <- parsePath (parseGhcPkgLibA root)
                    "<.a library (register) path parser>"
                    archivePath
    need [ root -/- relativePackageDbPath stage
                -/- (pkgId name version) ++ ".conf"
         ]

48 49
-- | Build a static library ('LibA') under the given build root, whose path is
-- the second argument.
50 51
buildStaticLib :: FilePath -> FilePath -> Action ()
buildStaticLib root archivePath = do
52 53 54 55 56 57 58 59
    l@(BuildPath _ stage _ (LibA pkgname _ way))
        <- parsePath (parseBuildLibA root)
                     "<.a library (build) path parser>"
                     archivePath
    let context = libAContext l
    objs <- libraryObjects context
    removeFile archivePath
    build $ target context (Ar Pack stage) objs [archivePath]
60
    synopsis <- pkgSynopsis (package context)
61 62 63 64
    putSuccess $ renderLibrary
        (quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
        archivePath synopsis

65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
-- | Register (with ghc-pkg) a dynamic library ('LibDyn') under the given build
-- root, with the given suffix (@.so@ or @.dylib@, @.dll@ in the future), where
-- the complete path of the registered dynamic library is given as the third
-- argument.
registerDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
registerDynamicLibUnix root suffix dynlibpath = do
    -- Simply need the ghc-pkg database .conf file.
    (GhcPkgPath _ stage _ (LibDyn name version _ _))
        <- parsePath (parseGhcPkgLibDyn root suffix)
                            "<dyn register lib parser>"
                            dynlibpath
    need [ root -/- relativePackageDbPath stage
                -/- pkgId name version ++ ".conf"
         ]

80 81 82
-- | Build a dynamic library ('LibDyn') under the given build root, with the
-- given suffix (@.so@ or @.dylib@, @.dll@ in the future), where the complete
-- path of the archive to build is given as the third argument.
83 84
buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
buildDynamicLibUnix root suffix dynlibpath = do
85 86 87
    dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
    let context = libDynContext dynlib
    deps <- contextDependencies context
88
    registerPackages deps
89 90 91 92 93
    objs <- libraryObjects context
    build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]

-- | Build a "GHCi library" ('LibGhci') under the given build root, with the
-- complete path of the file to build is given as the second argument.
94 95
buildGhciLibO :: FilePath -> FilePath -> Action ()
buildGhciLibO root ghcilibPath = do
96 97 98 99 100 101 102 103
    l@(BuildPath _ stage _ (LibGhci _ _ _))
        <- parsePath (parseBuildLibGhci root)
                     "<.o ghci lib (build) path parser>"
                     ghcilibPath
    let context = libGhciContext l
    objs <- allObjects context
    need objs
    build $ target context (Ld stage) objs [ghcilibPath]
104 105 106

-- * Helpers

107
-- | Return all Haskell and non-Haskell object files for the given 'Context'.
108 109 110
allObjects :: Context -> Action [FilePath]
allObjects context = (++) <$> nonHsObjects context <*> hsObjects context

111 112
-- | Return all the non-Haskell object files for the given library context
-- (object files built from C, C-- and sometimes other things).
113 114 115
nonHsObjects :: Context -> Action [FilePath]
nonHsObjects context = do
    cObjs   <- cObjects context
116
    cmmSrcs <- interpretInContext context (getContextData cmmSrcs)
117
    cmmObjs <- mapM (objectPath context) cmmSrcs
118 119 120
    eObjs   <- extraObjects context
    return $ cObjs ++ cmmObjs ++ eObjs

121
-- | Return all the C object files needed to build the given library context.
122 123
cObjects :: Context -> Action [FilePath]
cObjects context = do
124
    srcs <- interpretInContext context (getContextData cSrcs)
125
    objs <- mapM (objectPath context) srcs
126
    return $ if Threaded `wayUnit` way context
127 128
        then objs
        else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
129

130
-- | Return extra object files needed to build the given library context. The
131 132
-- resulting list is currently non-empty only when the package from the
-- 'Context' is @integer-gmp@.
133
extraObjects :: Context -> Action [FilePath]
134
extraObjects context
135 136
    | package context == integerGmp = gmpObjects
    | otherwise                     = return []
137

138 139
-- | Return all the object files to be put into the library we're building for
-- the given 'Context'.
140 141 142 143 144
libraryObjects :: Context -> Action [FilePath]
libraryObjects context@Context{..} = do
    hsObjs   <- hsObjects    context
    noHsObjs <- nonHsObjects context
    need $ noHsObjs ++ hsObjs
Ben Gamari's avatar
Ben Gamari committed
145
    return (noHsObjs ++ hsObjs)
146

David Eichmann's avatar
David Eichmann committed
147 148 149 150
-- | Coarse-grain 'need': make sure all given libraries are fully built.
needLibrary :: [Context] -> Action ()
needLibrary cs = need =<< concatMapM (libraryTargets True) cs

151 152 153
-- * Library paths types and parsers

-- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
154
data LibA = LibA String [Integer] Way deriving (Eq, Show)
155 156

-- | > <so or dylib>
157
data DynLibExt = So | Dylib deriving (Eq, Show)
158

159
-- | > libHS<pkg name>-<pkg version>[_<way suffix>]-ghc<ghc version>.<so|dylib>
160
data LibDyn = LibDyn String [Integer] Way DynLibExt deriving (Eq, Show)
161 162

-- | > HS<pkg name>-<pkg version>[_<way suffix>].o
163
data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show)
164 165 166

-- | Get the 'Context' corresponding to the build path for a given static library.
libAContext :: BuildPath LibA -> Context
167 168 169
libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) =
    Context stage pkg way
  where
170
    pkg = library pkgname pkgpath
171

172
-- | Get the 'Context' corresponding to the build path for a given GHCi library.
173
libGhciContext :: BuildPath LibGhci -> Context
174 175 176
libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way)) =
    Context stage pkg way
  where
177
    pkg = library pkgname pkgpath
178 179 180

-- | Get the 'Context' corresponding to the build path for a given dynamic library.
libDynContext :: BuildPath LibDyn -> Context
181 182 183
libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) =
    Context stage pkg way
  where
184
    pkg = library pkgname pkgpath
185

186 187 188 189 190 191 192 193 194 195
-- | Parse a path to a registered ghc-pkg static library to be built, making
-- sure the path starts with the given build root.
parseGhcPkgLibA :: FilePath -> Parsec.Parsec String () (GhcPkgPath LibA)
parseGhcPkgLibA root
    = parseGhcPkgPath root
        (do -- Skip past pkgId directory.
            _ <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/")
            parseLibAFilename)
        Parsec.<?> "ghc-pkg path for a static library"

196
-- | Parse a path to a static library to be built, making sure the path starts
197
-- with the given build root.
198 199
parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
parseBuildLibA root = parseBuildPath root parseLibAFilename
200
    Parsec.<?> "build path for a static library"
201 202

-- | Parse a path to a ghci library to be built, making sure the path starts
203
-- with the given build root.
204 205
parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
206
    Parsec.<?> "build path for a ghci library"
207 208

-- | Parse a path to a dynamic library to be built, making sure the path starts
209
-- with the given build root.
210 211
parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
212
    Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
213

214 215 216 217 218 219
-- | Parse a path to a registered ghc-pkg dynamic library, making sure the path
-- starts with the given package database root.
parseGhcPkgLibDyn :: FilePath -> String -> Parsec.Parsec String () (GhcPkgPath LibDyn)
parseGhcPkgLibDyn root ext = parseGhcPkgPath root (parseLibDynFilename ext)
    Parsec.<?> ("ghc-pkg path for a dynamic library with extension " ++ ext)

220 221 222
-- | Parse the filename of a static library to be built into a 'LibA' value.
parseLibAFilename :: Parsec.Parsec String () LibA
parseLibAFilename = do
223 224 225 226 227
    _ <- Parsec.string "libHS"
    (pkgname, pkgver) <- parsePkgId
    way <- parseWaySuffix vanilla
    _ <- Parsec.string ".a"
    return (LibA pkgname pkgver way)
228 229 230 231

-- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
parseLibGhciFilename :: Parsec.Parsec String () LibGhci
parseLibGhciFilename = do
232 233
    _ <- Parsec.string "HS"
    (pkgname, pkgver) <- parsePkgId
234 235 236
    _ <- Parsec.string "."
    way <- parseWayPrefix vanilla
    _ <- Parsec.string "o"
237
    return (LibGhci pkgname pkgver way)
238 239 240 241

-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
parseLibDynFilename ext = do
242 243 244
    _ <- Parsec.string "libHS"
    (pkgname, pkgver) <- parsePkgId
    way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
245
    _ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
246 247
    _ <- Parsec.string ("." ++ ext)
    return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
248 249 250

-- | Get the package identifier given the package name and version.
pkgId :: String -> [Integer] -> String
251
pkgId name version = name ++ "-" ++ intercalate "." (map show version)