summaryrefslogtreecommitdiff
path: root/hadrian/src/Rules/Register.hs
blob: e7162046143e6bb7c02588457918f106fa1d8f42 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
module Rules.Register (
    configurePackageRules, registerPackageRules, registerPackages,
    libraryTargets
    ) where

import Base
import Context
import Expression ( getContextData )
import Oracles.Setting
import Hadrian.BuildPath
import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Oracles.Flag (platformSupportsGhciObjects)
import Packages
import Rules.Rts
import Settings
import Target
import Utilities

import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec      as Parsec
import qualified Data.Set         as Set

import Distribution.Version (Version)
import qualified Distribution.Parsec as Cabal
import qualified Distribution.Types.PackageName as Cabal
import qualified Distribution.Types.PackageId as Cabal

import qualified Hadrian.Haskell.Cabal.Parse as Cabal
import qualified System.Directory            as IO

-- * Configuring

-- | Configure a package and build its @setup-config@ file, as well as files in
-- the @build/pkgName/build/autogen@ directory.
configurePackageRules :: Rules ()
configurePackageRules = do
    root <- buildRootRules
    root -/- "**/setup-config" %> \out -> do
        (stage, path) <- parsePath (parseSetupConfig root) "<setup config path parser>" out
        let pkg = unsafeFindPackageByPath path
        let ctx = Context stage pkg vanilla Inplace
        buildP <- buildPath ctx
        when (pkg == ghcBignum) $ do
          isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend
          when isGmp $
            need [buildP -/- "include/ghc-gmp.h"]
        Cabal.configurePackage ctx

    root -/- "**/autogen/cabal_macros.h" %> \out -> do
        (stage, path) <- parsePath (parseToBuildSubdirectory root) "<cabal macros path parser>" out
        let pkg = unsafeFindPackageByPath path
        Cabal.buildAutogenFiles (Context stage pkg vanilla Inplace)

    root -/- "**/autogen/Paths_*.hs" %> \out ->
        need [takeDirectory out -/- "cabal_macros.h"]

parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
parseSetupConfig root = do
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgPath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/setup-config")
    return (stage, pkgPath)

parseToBuildSubdirectory :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
parseToBuildSubdirectory root = do
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgPath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/build/")
    return (stage, pkgPath)

-- * Registering

registerPackages :: [Context] -> Action ()
registerPackages ctxs = do
    need =<< mapM pkgRegisteredLibraryFile ctxs

    -- Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
    forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do
        ways <- interpretInContext ctx (getLibraryWays <> getRtsWays)
        needRtsSymLinks (stage ctx) ways

-- | Register a package and initialise the corresponding package database if
-- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
registerPackageRules :: [(Resource, Int)] -> Stage -> Inplace -> Rules ()
registerPackageRules rs stage iplace = do
    root <- buildRootRules

    -- Initialise the package database.
    root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- packageDbStamp %> \stamp -> do
        -- This command initialises the package.cache file to avoid a race where
        -- a package gets registered but there's not a package.cache file (which
        -- leads to errors in GHC).
        buildWithResources rs $
            target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] []
        writeFileLines stamp []

    -- Register a package.
    root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- "*.conf" %> \conf -> do
        historyDisable

        pkgName <- getPackageNameFromConfFile conf
        let pkg = unsafeFindPackageByName pkgName

        when (pkg == compiler) $ need =<< ghcLibDeps stage iplace

        -- Only used in guard when Stage0 {} but can be GlobalLibs or InTreeLibs
        isBoot <- (pkg `notElem`) <$> stagePackages stage

        let ctx = Context stage pkg vanilla iplace
        case stage of
            Stage0 _ | isBoot -> copyConf  rs ctx conf
            _               ->
              -- See Note [Inplace vs Final package databases]
              case iplace of
                Inplace -> buildConfInplace rs ctx conf
                Final   -> buildConfFinal rs ctx conf

buildConfFinal :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildConfFinal rs context@Context {..} _conf = do
    depPkgIds <- cabalDependencies context
    ensureConfigured context
    ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
    stamps <- mapM pkgStampFile [ context { way = w } | w <- Set.toList ways ]
    confs <- mapM (\pkgId -> packageDbPath (PackageDbLoc stage Final) <&> (-/- pkgId <.> "conf")) depPkgIds
    -- Important to need these together to avoid introducing a linearisation. This is not the most critical place
    -- though because needing the stamp file, will cause all dependent object files to be built anyway (even if other packages)
    -- so the .conf file being needed will probably not have to build so much (only stuff which is not use transitively). It's
    -- still better though to need both together to give hadrian the best chance possible to build things in parallel.
    need (stamps ++ confs)

    -- We might need some package-db resource to limit read/write, see packageRules.
    path <- buildPath context

    -- Special package cases (these should ideally be rolled into Cabal).
    when (package == rts) $ do
        jsTarget <- isJsTarget

        -- If Cabal knew about "generated-headers", we could read them from the
        -- 'configuredCabal' information, and just "need" them here.
        let common_headers =
              [ path -/- "include/DerivedConstants.h"
              , path -/- "include/ghcautoconf.h"
              , path -/- "include/ghcplatform.h"
              ]
            -- headers only required for the native RTS
            native_headers =
             [ path -/- "include/rts/EventLogConstants.h"
             , path -/- "include/rts/EventTypes.h"
             ]
            headers
              | jsTarget  = common_headers
              | otherwise = common_headers ++ native_headers

        need headers

    -- we need to generate this file for GMP
    when (package == ghcBignum) $ do
        bignum <- interpretInContext context getBignumBackend
        when (bignum == "gmp") $
            need [path -/- "include/ghc-gmp.h"]

    -- Copy and register the package.
    Cabal.copyPackage context
    Cabal.registerPackage rs context

    -- We declare that this rule also produces files matching:
    --   - <root>/stage<N>/lib/<arch>-<os>-ghc-<version>/*libHS<pkgid>*
    --     (for .so files, Cabal's registration mechanism places them there)
    --   - <root>/stage<N>/lib/<arch>-<os>-ghc-<version>/<pkgid>/**
    --     (for interface files, static libs, ghci libs, includes, ...)
    --
    -- so that if any change ends up modifying a library (but not its .conf
    -- file), we still rebuild things that depend on it.
    dir <- (-/-) <$> libPath context <*> distDir stage
    pkgid <- pkgIdentifier package
    files <- liftIO $
      (++) <$> getDirectoryFilesIO "." [dir -/- "*libHS"++pkgid++"*"]
           <*> getDirectoryFilesIO "." [dir -/- pkgid -/- "**"]
    produces files

buildConfInplace :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildConfInplace rs context@Context {..} _conf = do
    depPkgIds <- cabalDependencies context
    ensureConfigured context
    need =<< mapM (\pkgId -> packageDbPath (PackageDbLoc stage Inplace) <&> (-/- pkgId <.> "conf")) depPkgIds

    path <- buildPath context

    -- Special package cases (these should ideally be rolled into Cabal).
    when (package == rts) $
        -- If Cabal knew about "generated-headers", we could read them from the
        -- 'configuredCabal' information, and just "need" them here.
        need [ path -/- "include/DerivedConstants.h"
             , path -/- "include/ghcautoconf.h"
             , path -/- "include/ghcplatform.h"
             , path -/- "include/rts/EventLogConstants.h"
             , path -/- "include/rts/EventTypes.h"
             ]

    -- we need to generate this file for GMP
    when (package == ghcBignum) $ do
        bignum <- interpretInContext context getBignumBackend
        when (bignum == "gmp") $
            need [path -/- "include/ghc-gmp.h"]

    -- Write an "inplace" package conf which points into the build directories
    -- for finding the build products
    Cabal.writeInplacePkgConf context
    conf <- pkgInplaceConfig context
    buildWithResources rs $
      target context (GhcPkg Update stage) [conf] []


copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
copyConf rs context@Context {..} conf = do
    depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
        target context (GhcPkg Dependencies stage) [pkgName package] []
    need =<< mapM (\pkgId -> packageDbPath (PackageDbLoc stage iplace) <&> (-/- pkgId <.> "conf")) depPkgIds
    -- We should unregister if the file exists since @ghc-pkg@ will complain
    -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
    -- Also, we don't always do the unregistration + registration to avoid
    -- repeated work after a full build.
    -- We do not track 'doesFileExist' since we are going to create the file if
    -- it is currently missing. TODO: Is this the right thing to do?
    -- See https://github.com/snowleopard/hadrian/issues/569.
    unlessM (liftIO $ IO.doesFileExist conf) $ do
        buildWithResources rs $
            target context (GhcPkg Unregister stage) [pkgName package] []
        buildWithResources rs $
            target context (GhcPkg Copy stage) [pkgName package] [conf]
  where
    stdOutToPkgIds :: String -> [String]
    stdOutToPkgIds = drop 1 . concatMap words . lines

getPackageNameFromConfFile :: FilePath -> Action String
getPackageNameFromConfFile conf
    | takeBaseName conf == "rts" = return "rts"
    | otherwise = case parseCabalName (takeBaseName conf) of
        Left err -> error $ "getPackageNameFromConfFile: Couldn't parse " ++
                            takeBaseName conf ++ ": " ++ err
        Right (name, _) -> return name

parseCabalName :: String -> Either String (String, Version)
parseCabalName = fmap f . Cabal.eitherParsec
  where
    f :: Cabal.PackageId -> (String, Version)
    f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)

-- | Return extra library targets.
extraTargets :: Context -> Action [FilePath]
extraTargets context
    | package context == rts  = needRtsLibffiTargets (Context.stage context)
    | otherwise               = return []

-- | Given a library 'Package' this action computes all of its targets. Needing
-- all the targets should build the library such that it is ready to be
-- registered into the package database.
-- See 'Rules.packageTargets' for the explanation of the @includeGhciLib@
-- parameter.
libraryTargets :: Bool -> Context -> Action [FilePath]
libraryTargets includeGhciLib context@Context {..} = do
    libFile  <- pkgLibraryFile     context
    ghciLib  <- pkgGhciLibraryFile context
    ghciObjsSupported <- platformSupportsGhciObjects
    ghci     <- if ghciObjsSupported && includeGhciLib && not (wayUnit Dynamic way)
                then interpretInContext context $ getContextData buildGhciLib
                else return False
    extra    <- extraTargets context
    return $ [ libFile ]
          ++ [ ghciLib | ghci ]
          ++ extra