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

Refactor Libffi and RTS rules

This removes a hack that copies libffi files to the rts
build directory. This was done in a libffi rule, but now
an rts rule correctly needs and copies the relevant
files from the libffi build dir to the rts build dir.

Issues: #16272 #16304
parent 8fc654c3
Pipeline #5893 failed with stages
in 285 minutes and 2 seconds
......@@ -16,7 +16,7 @@ module Hadrian.Utilities (
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
-- * File system operations
copyFile, copyFileUntracked, createFileLinkUntracked, fixFile,
copyFile, copyFileUntracked, createFileLink, createFileLinkUntracked, fixFile,
makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
moveDirectory, removeDirectory,
......@@ -289,14 +289,25 @@ infixl 1 <&>
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-- | Link a file tracking the source. Create the target directory if missing.
-- | 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 linkTarget
let dir = takeDirectory link
liftIO $ IO.createDirectoryIfMissing True dir
putProgressInfo =<< renderCreateFileLink linkTarget link
quietly . liftIO $ IO.createFileLink linkTarget link
-- | Link a file tracking the link target. Create the target directory if
-- missing.
createFileLink :: FilePath -> FilePath -> Action ()
createFileLink linkTarget link = do
let source = if isAbsolute linkTarget
then linkTarget
else takeDirectory link -/- linkTarget
need [source]
createFileLinkUntracked linkTarget link
-- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
......
......@@ -26,7 +26,6 @@ import qualified Rules.SimpleTargets
import Settings
import Target
import UserSettings
import Utilities
-- | @tool-args@ is used by tooling in order to get the arguments necessary
......@@ -120,7 +119,7 @@ packageTargets includeGhciLib stage pkg = do
let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
ways <- interpretInContext context pkgWays
libs <- mapM (pkgLibraryFile . Context stage pkg) ways
more <- libraryTargets includeGhciLib context
more <- Rules.Library.libraryTargets includeGhciLib context
setupConfig <- pkgSetupConfigFile context
return $ [setupConfig] ++ libs ++ more
else do -- The only target of a program package is the executable.
......
......@@ -10,6 +10,7 @@ import Rules.Generate
import Settings
import Target
import Utilities
import Rules.Library
import qualified Text.Parsec as Parsec
......
......@@ -54,7 +54,7 @@ compilerDependencies = do
rtsPath <- expr (rtsBuildPath stage)
mconcat [ return ((root -/-) <$> derivedConstantsDependencies)
, notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
, notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
, notStage0 ? return ((rtsPath -/-) <$> libffiHeaderFiles)
, return $ fmap (ghcPath -/-)
[ "primop-can-fail.hs-incl"
, "primop-code-size.hs-incl"
......@@ -80,7 +80,7 @@ generatedDependencies = do
includes <- expr includesDependencies
mconcat [ package compiler ? compilerDependencies
, package ghcPrim ? ghcPrimDependencies
, package rts ? return (fmap (rtsPath -/-) libffiDependencies
, package rts ? return (fmap (rtsPath -/-) libffiHeaderFiles
++ includes
++ fmap (root -/-) derivedConstantsDependencies)
, stage0 ? return includes ]
......
module Rules.Libffi (libffiRules, libffiDependencies, libffiName) where
{-# LANGUAGE TypeFamilies #-}
module Rules.Libffi (
LibffiDynLibs(..),
needLibffi, askLibffilDynLibs, libffiRules, libffiLibrary, libffiHeaderFiles,
libffiHeaders, libffiSystemHeaders, libffiName
) where
import Hadrian.Utilities
......@@ -7,26 +13,33 @@ import Settings.Builders.Common
import Target
import Utilities
{-
Note [Hadrian: install libffi hack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- | Oracle question type. The oracle returns the list of dynamic
-- libffi library file paths (all but one of which should be symlinks).
newtype LibffiDynLibs = LibffiDynLibs Stage
deriving (Eq, Show, Hashable, Binary, NFData)
type instance RuleResult LibffiDynLibs = [FilePath]
askLibffilDynLibs :: Stage -> Action [FilePath]
askLibffilDynLibs stage = askOracle (LibffiDynLibs stage)
There are 2 important steps in handling libffi's .a and .so files:
-- | The path to the dynamic library manifest file. The file contains all file
-- paths to libffi dynamic library file paths.
dynLibManifest' :: Monad m => m FilePath -> Stage -> m FilePath
dynLibManifest' getRoot stage = do
root <- getRoot
return $ root -/- stageString stage -/- pkgName libffi -/- ".dynamiclibs"
1. libffi's .a and .so|.dynlib|.dll files are copied from the libffi build dir
to the rts build dir. This is because libffi is ultimately bundled with the
rts package. Relevant code is in the libffiRules function.
2. The rts is "installed" via the hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
copyPackage action. This uses the "cabal copy" command which (among other
things) attempts to copy the bundled .a and .so|.dynlib|.dll files from the
rts build dir to the install dir.
dynLibManifestRules :: Stage -> Rules FilePath
dynLibManifestRules = dynLibManifest' buildRootRules
There is an issue in step 1. that the name of the shared library files is not
know untill after libffi is built. As a workaround, the rts package needs just
the libffiDependencies, and the corresponding rule (defined below in
libffiRules) does the extra work of installing the shared library files into the
rts build directory after building libffi.
-}
dynLibManifest :: Stage -> Action FilePath
dynLibManifest = dynLibManifest' buildRoot
-- | Need the (locally built) libffi library.
needLibffi :: Stage -> Action ()
needLibffi stage = do
manifest <- dynLibManifest stage
need [manifest]
-- | Context for @libffi@.
libffiContext :: Stage -> Action Context
......@@ -51,18 +64,21 @@ libffiName' windows dynamic
= (if dynamic then "" else "C")
++ (if windows then "ffi-6" else "ffi")
libffiDependencies :: [FilePath]
libffiDependencies = ["ffi.h", "ffitarget.h"]
libffiLibrary :: FilePath
libffiLibrary = "inst/lib/libffi.a"
rtsLibffiLibrary :: Stage -> Way -> Action FilePath
rtsLibffiLibrary stage way = do
name <- libffiLibraryName
suf <- libsuf stage way
rtsPath <- rtsBuildPath stage
return $ rtsPath -/- "lib" ++ name ++ suf
libffiHeaderFiles :: [FilePath]
libffiHeaderFiles = ["ffi.h", "ffitarget.h"]
libffiHeaders :: Stage -> Action [FilePath]
libffiHeaders stage = do
path <- libffiBuildPath stage
return $ fmap ((path -/- "inst/include") -/-) libffiHeaderFiles
libffiSystemHeaders :: Action [FilePath]
libffiSystemHeaders = do
ffiIncludeDir <- setting FfiIncludeDir
return $ fmap (ffiIncludeDir -/-) libffiHeaderFiles
fixLibffiMakefile :: FilePath -> String -> String
fixLibffiMakefile top =
......@@ -88,84 +104,46 @@ configureEnvironment stage = do
, return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
libffiRules :: Rules ()
libffiRules = forM_ [Stage1 ..] $ \stage -> do
libffiRules = do
_ <- addOracleCache $ \ (LibffiDynLibs stage)
-> readFileLines =<< dynLibManifest stage
forM_ [Stage1 ..] $ \stage -> do
root <- buildRootRules
let path = root -/- stageString stage
libffiPath = path -/- pkgName libffi -/- "build"
libffiOuts = [libffiPath -/- libffiLibrary] ++
fmap ((path -/- "rts/build") -/-) libffiDependencies
-- We set a higher priority because this rule overlaps with the build rule
-- for static libraries 'Rules.Library.libraryRules'.
-- See [Hadrian: install libffi hack], this rule installs libffi into the
-- rts build path.
priority 2.0 $ libffiOuts &%> \_ -> do
dynLibMan <- dynLibManifestRules stage
let topLevelTargets = [ libffiPath -/- libffiLibrary
, dynLibMan
]
priority 2 $ topLevelTargets &%> \_ -> do
context <- libffiContext stage
useSystemFfi <- flag UseSystemFfi
rtsPath <- rtsBuildPath stage
if useSystemFfi
then do
ffiIncludeDir <- setting FfiIncludeDir
putBuild "| System supplied FFI library will be used"
forM_ ["ffi.h", "ffitarget.h"] $ \file ->
copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
putSuccess "| Successfully copied system FFI library header files"
else do
build $ target context (Make libffiPath) [] []
-- Here we produce 'libffiDependencies'
headers <- liftIO $ getDirectoryFilesIO libffiPath ["inst/include/*"]
forM_ headers $ \header -> do
let target = rtsPath -/- takeFileName header
copyFileUntracked (libffiPath -/- header) target
produces [target]
-- Find ways.
ways <- interpretInContext context
(getLibraryWays <> getRtsWays)
let (dynamicWays, staticWays) = partition (wayUnit Dynamic) ways
-- Install static libraries.
forM_ staticWays $ \way -> do
rtsLib <- rtsLibffiLibrary stage way
copyFileUntracked (libffiPath -/- "inst/lib/libffi.a") rtsLib
produces [rtsLib]
-- Install dynamic libraries.
when (not $ null dynamicWays) $ do
-- Find dynamic libraries.
windows <- windowsHost
osx <- osxHost
let libffiName'' = libffiName' windows True
(dynLibsSrcDir, dynLibFiles) <- if windows
then do
let libffiDll = "lib" ++ libffiName'' ++ ".dll"
return (libffiPath -/- "inst/bin", [libffiDll])
else do
let libffiLibPath = libffiPath -/- "inst/lib"
dynLibsRelative <- liftIO $ getDirectoryFilesIO
libffiLibPath
(if osx
then ["lib" ++ libffiName'' ++ ".dylib*"]
else ["lib" ++ libffiName'' ++ ".so*"])
return (libffiLibPath, dynLibsRelative)
-- Install dynamic libraries.
rtsPath <- rtsBuildPath stage
forM_ dynLibFiles $ \dynLibFile -> do
let target = rtsPath -/- dynLibFile
copyFileUntracked (dynLibsSrcDir -/- dynLibFile) target
-- On OSX the dylib's id must be updated to a relative path.
when osx $ cmd
[ "install_name_tool"
, "-id", "@rpath/" ++ dynLibFile
, target
]
produces [target]
putSuccess "| Successfully bundled custom library 'libffi' with rts"
-- Note this build needs the Makefile, triggering the rules bellow.
build $ target context (Make libffiPath) [] []
-- Find dynamic libraries.
dynLibFiles <- do
windows <- windowsHost
osx <- osxHost
let libffiName'' = libffiName' windows True
if windows
then
let libffiDll = "lib" ++ libffiName'' ++ ".dll"
in return [libffiPath -/- "inst/bin" -/- libffiDll]
else do
let libffiLibPath = libffiPath -/- "inst/lib"
dynLibsRelative <- liftIO $ getDirectoryFilesIO
libffiLibPath
(if osx
then ["lib" ++ libffiName'' ++ ".dylib*"]
else ["lib" ++ libffiName'' ++ ".so*"])
return (fmap (libffiLibPath -/-) dynLibsRelative)
writeFileLines dynLibMan dynLibFiles
putSuccess "| Successfully build libffi."
fmap (libffiPath -/-) ["Makefile.in", "configure" ] &%> \[mkIn, _] -> do
-- Extract libffi tar file
......
module Rules.Library (libraryRules) where
module Rules.Library (libraryRules, needLibrary, libraryTargets) where
import Hadrian.BuildPath
import Hadrian.Haskell.Cabal
......@@ -11,7 +11,7 @@ import Expression hiding (way, package)
import Oracles.ModuleFiles
import Packages
import Rules.Gmp
import Rules.Libffi (libffiDependencies)
import Rules.Rts (needRtsLibffiTargets)
import Target
import Utilities
......@@ -86,14 +86,6 @@ buildDynamicLibUnix root suffix dynlibpath = do
let context = libDynContext dynlib
deps <- contextDependencies context
need =<< mapM pkgRegisteredLibraryFile deps
-- TODO should this be somewhere else?
-- Custom build step to generate libffi.so* in the rts build directory.
when (package context == rts) . interpretInContext context $ do
stage <- getStage
rtsPath <- expr (rtsBuildPath stage)
expr $ need ((rtsPath -/-) <$> libffiDependencies)
objs <- libraryObjects context
build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
......@@ -152,6 +144,32 @@ 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
-- * Library paths types and parsers
-- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
......
......@@ -14,6 +14,7 @@ import Settings
import Settings.Default
import Target
import Utilities
import Rules.Library
-- | TODO: Drop code duplication
buildProgramRules :: [(Resource, Int)] -> Rules ()
......
......@@ -12,6 +12,7 @@ import Rules.Rts
import Settings
import Target
import Utilities
import Rules.Library
import Distribution.Version (Version)
import qualified Distribution.Parsec as Cabal
......@@ -109,8 +110,7 @@ buildConf _ context@Context {..} conf = do
need [ path -/- "DerivedConstants.h"
, path -/- "ghcautoconf.h"
, path -/- "ghcplatform.h"
, path -/- "ghcversion.h"
, path -/- "ffi.h" ]
, path -/- "ghcversion.h" ]
when (package == integerGmp) $ need [path -/- gmpLibraryH]
......
module Rules.Rts (rtsRules, needRtsSymLinks) where
module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where
import Packages (rts)
import Packages (rts, rtsBuildPath, libffiBuildPath, libffiLibraryName, rtsContext)
import Rules.Libffi
import Hadrian.Utilities
import Settings.Builders.Common
-- | Dynamic RTS library files need symlinks without the dummy version number.
-- This is for backwards compatibility (the old make build system omitted the
-- dummy version number).
-- This rule has priority 3 to override the general rule for generating shared
-- | This rule has priority 3 to override the general rule for generating shared
-- library files (see Rules.Library.libraryRules).
rtsRules :: Rules ()
rtsRules = priority 3 $ do
-- Dynamic RTS library files need symlinks without the dummy version number.
-- This is for backwards compatibility (the old make build system omitted the
-- dummy version number).
root <- buildRootRules
[ root -/- "//libHSrts_*-ghc*.so",
root -/- "//libHSrts_*-ghc*.dylib",
......@@ -20,6 +21,129 @@ rtsRules = priority 3 $ do
(addRtsDummyVersion $ takeFileName rtsLibFilePath')
rtsLibFilePath'
-- Libffi
forM_ [Stage1 ..] $ \ stage -> do
let buildPath = root -/- buildDir (rtsContext stage)
-- Header files
(fmap (buildPath -/-) libffiHeaderFiles) &%> const (copyLibffiHeaders stage)
-- Static libraries.
buildPath -/- "libCffi*.a" %> copyLibffiStatic stage
-- Dynamic libraries
buildPath -/- "libffi*.dylib*" %> copyLibffiDynamicUnix stage ".dylib"
buildPath -/- "libffi*.so*" %> copyLibffiDynamicUnix stage ".so"
buildPath -/- "libffi*.dll*" %> copyLibffiDynamicWin stage
withLibffi :: Stage -> (FilePath -> FilePath -> Action a) -> Action a
withLibffi stage action = needLibffi stage
>> (join $ action <$> libffiBuildPath stage
<*> rtsBuildPath stage)
-- | Copy all header files wither from the system libffi or from the libffi
-- build dir to the rts build dir.
copyLibffiHeaders :: Stage -> Action ()
copyLibffiHeaders stage = do
rtsPath <- rtsBuildPath stage
useSystemFfi <- flag UseSystemFfi
(fromStr, headers) <- if useSystemFfi
then ("system",) <$> libffiSystemHeaders
else needLibffi stage
>> ("custom",) <$> libffiHeaders stage
forM_ headers $ \ header -> copyFile header
(rtsPath -/- takeFileName header)
putSuccess $ "| Successfully copied " ++ fromStr ++ " FFI library header "
++ "files to RTS build directory."
-- | Copy a static library file from the libffi build dir to the rts build dir.
copyLibffiStatic :: Stage -> FilePath -> Action ()
copyLibffiStatic stage target = withLibffi stage $ \ libffiPath _ -> do
-- Copy the vanilla library, and symlink the rest to it.
vanillaLibFile <- rtsLibffiLibrary stage vanilla
if target == vanillaLibFile
then copyFile' (libffiPath -/- libffiLibrary) target
else createFileLink (takeFileName vanillaLibFile) target
-- | Copy a dynamic library file from the libffi build dir to the rts build dir.
copyLibffiDynamicUnix :: Stage -> String -> FilePath -> Action ()
copyLibffiDynamicUnix stage libSuf target = do
needLibffi stage
dynLibs <- askLibffilDynLibs stage
-- If no version number suffix, then copy else just symlink.
let versionlessSourceFilePath = fromMaybe
(error $ "Needed " ++ show target ++ " which is not any of " ++
"libffi's built shared libraries: " ++ show dynLibs)
(find (libSuf `isSuffixOf`) dynLibs)
let versionlessSourceFileName = takeFileName versionlessSourceFilePath
if versionlessSourceFileName == takeFileName target
then do
copyFile' versionlessSourceFilePath target
-- On OSX the dylib's id must be updated to a relative path.
osx <- osxHost
when osx $ cmd
[ "install_name_tool"
, "-id", "@rpath/" ++ takeFileName target
, target
]
else createFileLink versionlessSourceFileName target
-- | Copy a dynamic library file from the libffi build dir to the rts build dir.
copyLibffiDynamicWin :: Stage -> FilePath -> Action ()
copyLibffiDynamicWin stage target = do
needLibffi stage
dynLibs <- askLibffilDynLibs stage
let source = fromMaybe
(error $ "Needed " ++ show target ++ " which is not any of " ++
"libffi's built shared libraries: " ++ show dynLibs)
(find (\ lib -> takeFileName target == takeFileName lib) dynLibs)
copyFile' source target
rtsLibffiLibrary :: Stage -> Way -> Action FilePath
rtsLibffiLibrary stage way = do
name <- libffiLibraryName
suf <- libsuf stage way
rtsPath <- rtsBuildPath stage
return $ rtsPath -/- "lib" ++ name ++ suf
-- | Get the libffi files bundled with the rts (header and library files).
-- Unless using the system libffi, this needs the libffi library. It must be
-- built before the targets can be calcuulated.
needRtsLibffiTargets :: Stage -> Action [FilePath]
needRtsLibffiTargets stage = do
rtsPath <- rtsBuildPath stage
useSystemFfi <- flag UseSystemFfi
-- Header files (in the rts build dir).
let headers = fmap (rtsPath -/-) libffiHeaderFiles
if useSystemFfi
then return headers
else do
-- Need Libffi
-- This returns the dynamic library files (in the Libffi build dir).
needLibffi stage
dynLibffSource <- askLibffilDynLibs stage
-- Header files (in the rts build dir).
let headers = fmap (rtsPath -/-) libffiHeaderFiles
-- Dynamic library files (in the rts build dir).
let dynLibffis = fmap (\ lib -> rtsPath -/- takeFileName lib)
dynLibffSource
-- Static Libffi files (in the rts build dir).
staticLibffis <- do
ways <- interpretInContext (stageContext stage)
(getLibraryWays <> getRtsWays)
let staticWays = filter (not . wayUnit Dynamic) ways
mapM (rtsLibffiLibrary stage) staticWays
return $ concat [ headers, dynLibffis, staticLibffis ]
-- Need symlinks generated by rtsRules.
needRtsSymLinks :: Stage -> [Way] -> Action ()
needRtsSymLinks stage rtsWays
......
......@@ -2,7 +2,7 @@ module Utilities (
build, buildWithResources, buildWithCmdOptions,
askWithResources,
runBuilder, runBuilderWith,
needLibrary, contextDependencies, stage1Dependencies, libraryTargets,
contextDependencies, stage1Dependencies,
topsortPackages, cabalDependencies
) where
......@@ -55,21 +55,6 @@ stage1Dependencies :: Package -> Action [Package]
stage1Dependencies =
fmap (map Context.package) . contextDependencies . vanillaContext Stage1
-- | Given a library 'Package' this action computes all of its targets. 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
return $ [ libFile ] ++ [ ghciLib | ghci ]
-- | Coarse-grain 'need': make sure all given libraries are fully built.
needLibrary :: [Context] -> Action ()
needLibrary cs = need =<< concatMapM (libraryTargets True) cs
-- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
-- | Topological sort of packages according to their dependencies.
topsortPackages :: [Package] -> Action [Package]
......
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