Commit e98d32a6 authored by David Eichmann's avatar David Eichmann 🏋 Committed by Marge Bot
Browse files

Hadrian: Track RTS library symlink targets

This requires creating RTS library symlinks when registering, outside
of the rule for the registered library file.
parent a657543c
Pipeline #7053 passed with stages
in 307 minutes and 40 seconds
...@@ -16,7 +16,7 @@ module Hadrian.Utilities ( ...@@ -16,7 +16,7 @@ module Hadrian.Utilities (
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
-- * File system operations -- * File system operations
copyFile, copyFileUntracked, createFileLink, createFileLinkUntracked, fixFile, copyFile, copyFileUntracked, createFileLink, fixFile,
makeExecutable, moveFile, removeFile, createDirectory, copyDirectory, makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
moveDirectory, removeDirectory, moveDirectory, removeDirectory,
...@@ -290,17 +290,6 @@ infixl 1 <&> ...@@ -290,17 +290,6 @@ infixl 1 <&>
isGeneratedSource :: FilePath -> Action Bool isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file) isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-- | Link a file (without tracking the link target). Create the target directory
-- if missing.
createFileLinkUntracked :: FilePath -> FilePath -> Action ()
createFileLinkUntracked linkTarget link = do
let dir = takeDirectory link
liftIO $ IO.createDirectoryIfMissing True dir
putProgressInfo =<< renderCreateFileLink linkTarget link
quietly . liftIO $ do
IO.removeFile link <|> return ()
IO.createFileLink linkTarget link
-- | Link a file tracking the link target. Create the target directory if -- | Link a file tracking the link target. Create the target directory if
-- missing. -- missing.
createFileLink :: FilePath -> FilePath -> Action () createFileLink :: FilePath -> FilePath -> Action ()
...@@ -309,7 +298,12 @@ createFileLink linkTarget link = do ...@@ -309,7 +298,12 @@ createFileLink linkTarget link = do
then linkTarget then linkTarget
else takeDirectory link -/- linkTarget else takeDirectory link -/- linkTarget
need [source] need [source]
createFileLinkUntracked linkTarget link let dir = takeDirectory link
liftIO $ IO.createDirectoryIfMissing True dir
putProgressInfo =<< renderCreateFileLink linkTarget link
quietly . liftIO $ do
IO.removeFile link <|> return ()
IO.createFileLink linkTarget link
-- | Copy a file tracking the source. Create the target directory if missing. -- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action () copyFile :: FilePath -> FilePath -> Action ()
......
...@@ -11,7 +11,7 @@ import Expression hiding (way, package) ...@@ -11,7 +11,7 @@ import Expression hiding (way, package)
import Oracles.ModuleFiles import Oracles.ModuleFiles
import Packages import Packages
import Rules.Gmp import Rules.Gmp
import Rules.Rts (needRtsLibffiTargets) import Rules.Register
import Target import Target
import Utilities import Utilities
...@@ -85,7 +85,7 @@ buildDynamicLibUnix root suffix dynlibpath = do ...@@ -85,7 +85,7 @@ buildDynamicLibUnix root suffix dynlibpath = do
dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
let context = libDynContext dynlib let context = libDynContext dynlib
deps <- contextDependencies context deps <- contextDependencies context
need =<< mapM pkgRegisteredLibraryFile deps registerPackages deps
objs <- libraryObjects context objs <- libraryObjects context
build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath] build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
...@@ -144,28 +144,6 @@ libraryObjects context@Context{..} = do ...@@ -144,28 +144,6 @@ libraryObjects context@Context{..} = do
need $ noHsObjs ++ hsObjs need $ noHsObjs ++ hsObjs
return (noHsObjs ++ hsObjs) return (noHsObjs ++ hsObjs)
-- | 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 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
libraryTargets :: Bool -> Context -> Action [FilePath]
libraryTargets includeGhciLib context@Context {..} = do
libFile <- pkgLibraryFile context
ghciLib <- pkgGhciLibraryFile context
ghci <- if includeGhciLib && not (wayUnit Dynamic way)
then interpretInContext context $ getContextData buildGhciLib
else return False
extra <- extraTargets context
return $ [ libFile ]
++ [ ghciLib | ghci ]
++ extra
-- | Coarse-grain 'need': make sure all given libraries are fully built. -- | Coarse-grain 'need': make sure all given libraries are fully built.
needLibrary :: [Context] -> Action () needLibrary :: [Context] -> Action ()
needLibrary cs = need =<< concatMapM (libraryTargets True) cs needLibrary cs = need =<< concatMapM (libraryTargets True) cs
......
...@@ -15,6 +15,7 @@ import Settings.Default ...@@ -15,6 +15,7 @@ import Settings.Default
import Target import Target
import Utilities import Utilities
import Rules.Library import Rules.Library
import Rules.Register
-- | TODO: Drop code duplication -- | TODO: Drop code duplication
buildProgramRules :: [(Resource, Int)] -> Rules () buildProgramRules :: [(Resource, Int)] -> Rules ()
...@@ -96,8 +97,7 @@ buildProgram bin ctx@(Context{..}) rs = do ...@@ -96,8 +97,7 @@ buildProgram bin ctx@(Context{..}) rs = do
-- but when building the program, we link against the *ghc-pkg registered* library e.g. -- but when building the program, we link against the *ghc-pkg registered* library e.g.
-- _build/stage1/lib/x86_64-linux-ghc-8.9.0.20190430/libHShaskeline-0.7.5.0-ghc8.9.0.20190430.so -- _build/stage1/lib/x86_64-linux-ghc-8.9.0.20190430/libHShaskeline-0.7.5.0-ghc8.9.0.20190430.so
-- so we use pkgRegisteredLibraryFile instead. -- so we use pkgRegisteredLibraryFile instead.
need =<< mapM pkgRegisteredLibraryFile registerPackages =<< contextDependencies ctx
=<< contextDependencies ctx
cross <- flag CrossCompiling cross <- flag CrossCompiling
-- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@. -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
......
module Rules.Register (configurePackageRules, registerPackageRules) where module Rules.Register (
configurePackageRules, registerPackageRules, registerPackages,
libraryTargets
) where
import Base import Base
import Context import Context
import Expression ( getContextData )
import Hadrian.BuildPath import Hadrian.BuildPath
import Hadrian.Expression import Hadrian.Expression
import Hadrian.Haskell.Cabal import Hadrian.Haskell.Cabal
...@@ -12,7 +16,9 @@ import Rules.Rts ...@@ -12,7 +16,9 @@ import Rules.Rts
import Settings import Settings
import Target import Target
import Utilities import Utilities
import Rules.Library
import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec as Parsec
import Distribution.Version (Version) import Distribution.Version (Version)
import qualified Distribution.Parsec as Cabal import qualified Distribution.Parsec as Cabal
...@@ -21,7 +27,6 @@ import qualified Distribution.Types.PackageId as Cabal ...@@ -21,7 +27,6 @@ import qualified Distribution.Types.PackageId as Cabal
import qualified Hadrian.Haskell.Cabal.Parse as Cabal import qualified Hadrian.Haskell.Cabal.Parse as Cabal
import qualified System.Directory as IO import qualified System.Directory as IO
import qualified Text.Parsec as Parsec
-- * Configuring -- * Configuring
...@@ -63,6 +68,15 @@ parseToBuildSubdirectory root = do ...@@ -63,6 +68,15 @@ parseToBuildSubdirectory root = do
-- * Registering -- * 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 -- | Register a package and initialise the corresponding package database if
-- need be. Note that we only register packages in 'Stage0' and 'Stage1'. -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
registerPackageRules :: [(Resource, Int)] -> Stage -> Rules () registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
...@@ -118,9 +132,6 @@ buildConf _ context@Context {..} conf = do ...@@ -118,9 +132,6 @@ buildConf _ context@Context {..} conf = do
Cabal.copyPackage context Cabal.copyPackage context
Cabal.registerPackage context Cabal.registerPackage context
-- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
when (package == rts) (needRtsSymLinks stage ways)
-- The above two steps produce an entry in the package database, with copies -- The above two steps produce an entry in the package database, with copies
-- of many of the files we have build, e.g. Haskell interface files. We need -- of many of the files we have build, e.g. Haskell interface files. We need
-- to record this side effect so that Shake can cache these files too. -- to record this side effect so that Shake can cache these files too.
...@@ -171,3 +182,25 @@ parseCabalName = fmap f . Cabal.eitherParsec ...@@ -171,3 +182,25 @@ parseCabalName = fmap f . Cabal.eitherParsec
where where
f :: Cabal.PackageId -> (String, Version) f :: Cabal.PackageId -> (String, Version)
f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id) 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 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
libraryTargets :: Bool -> Context -> Action [FilePath]
libraryTargets includeGhciLib context@Context {..} = do
libFile <- pkgLibraryFile context
ghciLib <- pkgGhciLibraryFile context
ghci <- if includeGhciLib && not (wayUnit Dynamic way)
then interpretInContext context $ getContextData buildGhciLib
else return False
extra <- extraTargets context
return $ [ libFile ]
++ [ ghciLib | ghci ]
++ extra
...@@ -17,7 +17,7 @@ rtsRules = priority 3 $ do ...@@ -17,7 +17,7 @@ rtsRules = priority 3 $ do
root -/- "//libHSrts_*-ghc*.dylib", root -/- "//libHSrts_*-ghc*.dylib",
root -/- "//libHSrts-ghc*.so", root -/- "//libHSrts-ghc*.so",
root -/- "//libHSrts-ghc*.dylib"] root -/- "//libHSrts-ghc*.dylib"]
|%> \ rtsLibFilePath' -> createFileLinkUntracked |%> \ rtsLibFilePath' -> createFileLink
(addRtsDummyVersion $ takeFileName rtsLibFilePath') (addRtsDummyVersion $ takeFileName rtsLibFilePath')
rtsLibFilePath' rtsLibFilePath'
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment