diff options
author | David Eichmann <EichmannD@gmail.com> | 2019-06-04 19:01:19 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-06-13 02:50:00 -0400 |
commit | e98d32a62977fe1057ebbb1b6ed8990438cb9896 (patch) | |
tree | 81204fa5fd3a5f1ebd1c834dc0445a22dbc88a92 | |
parent | a657543c4d676b7e6e0984b72b31dd95949855e4 (diff) | |
download | haskell-e98d32a62977fe1057ebbb1b6ed8990438cb9896.tar.gz |
Hadrian: Track RTS library symlink targets
This requires creating RTS library symlinks when registering, outside
of the rule for the registered library file.
-rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 20 | ||||
-rw-r--r-- | hadrian/src/Rules/Library.hs | 28 | ||||
-rw-r--r-- | hadrian/src/Rules/Program.hs | 4 | ||||
-rw-r--r-- | hadrian/src/Rules/Register.hs | 45 | ||||
-rw-r--r-- | hadrian/src/Rules/Rts.hs | 4 |
5 files changed, 53 insertions, 48 deletions
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs index a1386e68fc..48ba34964e 100644 --- a/hadrian/src/Hadrian/Utilities.hs +++ b/hadrian/src/Hadrian/Utilities.hs @@ -16,7 +16,7 @@ module Hadrian.Utilities ( BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, -- * File system operations - copyFile, copyFileUntracked, createFileLink, createFileLinkUntracked, fixFile, + copyFile, copyFileUntracked, createFileLink, fixFile, makeExecutable, moveFile, removeFile, createDirectory, copyDirectory, moveDirectory, removeDirectory, @@ -290,17 +290,6 @@ infixl 1 <&> isGeneratedSource :: FilePath -> Action Bool 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 -- missing. createFileLink :: FilePath -> FilePath -> Action () @@ -309,7 +298,12 @@ createFileLink linkTarget link = do then linkTarget else takeDirectory link -/- linkTarget 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. copyFile :: FilePath -> FilePath -> Action () diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs index aea855df11..75a2cb2c3e 100644 --- a/hadrian/src/Rules/Library.hs +++ b/hadrian/src/Rules/Library.hs @@ -11,7 +11,7 @@ import Expression hiding (way, package) import Oracles.ModuleFiles import Packages import Rules.Gmp -import Rules.Rts (needRtsLibffiTargets) +import Rules.Register import Target import Utilities @@ -85,7 +85,7 @@ buildDynamicLibUnix root suffix dynlibpath = do dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath let context = libDynContext dynlib deps <- contextDependencies context - need =<< mapM pkgRegisteredLibraryFile deps + registerPackages deps objs <- libraryObjects context build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath] @@ -144,28 +144,6 @@ libraryObjects context@Context{..} = do need $ 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. needLibrary :: [Context] -> Action () needLibrary cs = need =<< concatMapM (libraryTargets True) cs @@ -270,4 +248,4 @@ parseLibDynFilename ext = do -- | Get the package identifier given the package name and version. pkgId :: String -> [Integer] -> String -pkgId name version = name ++ "-" ++ intercalate "." (map show version)
\ No newline at end of file +pkgId name version = name ++ "-" ++ intercalate "." (map show version) diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs index 7efe6c42ae..96855a3927 100644 --- a/hadrian/src/Rules/Program.hs +++ b/hadrian/src/Rules/Program.hs @@ -15,6 +15,7 @@ import Settings.Default import Target import Utilities import Rules.Library +import Rules.Register -- | TODO: Drop code duplication buildProgramRules :: [(Resource, Int)] -> Rules () @@ -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. -- _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. - need =<< mapM pkgRegisteredLibraryFile - =<< contextDependencies ctx + registerPackages =<< contextDependencies ctx cross <- flag CrossCompiling -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@. diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs index 700756eaad..d815d40c98 100644 --- a/hadrian/src/Rules/Register.hs +++ b/hadrian/src/Rules/Register.hs @@ -1,7 +1,11 @@ -module Rules.Register (configurePackageRules, registerPackageRules) where +module Rules.Register ( + configurePackageRules, registerPackageRules, registerPackages, + libraryTargets + ) where import Base import Context +import Expression ( getContextData ) import Hadrian.BuildPath import Hadrian.Expression import Hadrian.Haskell.Cabal @@ -12,7 +16,9 @@ import Rules.Rts import Settings import Target import Utilities -import Rules.Library + +import Hadrian.Haskell.Cabal.Type +import qualified Text.Parsec as Parsec import Distribution.Version (Version) import qualified Distribution.Parsec as Cabal @@ -21,7 +27,6 @@ import qualified Distribution.Types.PackageId as Cabal import qualified Hadrian.Haskell.Cabal.Parse as Cabal import qualified System.Directory as IO -import qualified Text.Parsec as Parsec -- * Configuring @@ -63,6 +68,15 @@ parseToBuildSubdirectory root = do -- * 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 -> Rules () @@ -118,9 +132,6 @@ buildConf _ context@Context {..} conf = do Cabal.copyPackage 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 -- 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. @@ -171,3 +182,25 @@ 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 '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 diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs index b7f39609b9..c9669f520d 100644 --- a/hadrian/src/Rules/Rts.hs +++ b/hadrian/src/Rules/Rts.hs @@ -17,7 +17,7 @@ rtsRules = priority 3 $ do root -/- "//libHSrts_*-ghc*.dylib", root -/- "//libHSrts-ghc*.so", root -/- "//libHSrts-ghc*.dylib"] - |%> \ rtsLibFilePath' -> createFileLinkUntracked + |%> \ rtsLibFilePath' -> createFileLink (addRtsDummyVersion $ takeFileName rtsLibFilePath') rtsLibFilePath' @@ -175,4 +175,4 @@ replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let (error $ "Expected RTS library file to start with " ++ oldPrefix) (newPrefix ++) (stripPrefix oldPrefix oldFileName) - in replaceFileName oldFilePath newFileName
\ No newline at end of file + in replaceFileName oldFilePath newFileName |