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

Build and copy libffi shared libraries correctly and enable dynamically linking ghc.

Test Plan:
Ensure build environment does NOT have a system libffi installed (you may want to use a nix environment).
Then `hadrian/build.sh -c --flavour=default`

Reviewers: bgamari

Subscribers: rwbarton, carter

GHC Trac Issues: #15837
parent 44ad7215
Pipeline #2647 failed with stages
in 269 minutes and 27 seconds
......@@ -12,7 +12,7 @@ module Packages (
-- * Package information
programName, nonHsMainPackage, autogenPath, programPath, timeoutPath,
rtsContext, rtsBuildPath, libffiContext, libffiBuildPath, libffiLibraryName,
rtsContext, rtsBuildPath, libffiBuildPath, libffiLibraryName,
generatedGhcDependencies, ensureConfigured
) where
......@@ -200,14 +200,12 @@ rtsContext stage = vanillaContext stage rts
rtsBuildPath :: Stage -> Action FilePath
rtsBuildPath stage = buildPath (rtsContext stage)
-- | Build directory for @libffi@. This probably doesn't need to be stage
-- dependent but it is for consistency for now.
libffiContext :: Stage -> Context
libffiContext stage = vanillaContext stage libffi
-- | Build directory for in-tree 'libffi' library.
libffiBuildPath :: Stage -> Action FilePath
libffiBuildPath stage = buildPath (libffiContext stage)
libffiBuildPath stage = buildPath $ Context
stage
libffi
(error "libffiBuildPath: way not set.")
-- | Name of the 'libffi' library.
libffiLibraryName :: Action FilePath
......
module Rules.Libffi (libffiRules, libffiDependencies) where
module Rules.Libffi (libffiRules, libffiDependencies, libffiName) where
import Hadrian.Utilities
......@@ -7,6 +7,50 @@ import Settings.Builders.Common
import Target
import Utilities
{-
Note [Hadrian: install libffi hack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are 2 important steps in handling libffi's .a and .so files:
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.
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.
-}
-- | Context for @libffi@.
libffiContext :: Stage -> Action Context
libffiContext stage = do
ways <- interpretInContext
(Context stage libffi (error "libffiContext: way not set"))
getLibraryWays
return . Context stage libffi $ if any (wayUnit Dynamic) ways
then dynamic
else vanilla
-- | The name of the (locally built) library
libffiName :: Expr String
libffiName = do
windows <- expr windowsHost
way <- getWay
return $ libffiName' windows (Dynamic `wayUnit` way)
-- | The name of the (locally built) library
libffiName' :: Bool -> Bool -> String
libffiName' windows dynamic
= (if dynamic then "" else "C")
++ (if windows then "ffi-6" else "ffi")
libffiDependencies :: [FilePath]
libffiDependencies = ["ffi.h", "ffitarget.h"]
......@@ -29,10 +73,11 @@ fixLibffiMakefile top =
-- TODO: check code duplication w.r.t. ConfCcArgs
configureEnvironment :: Stage -> Action [CmdOption]
configureEnvironment stage = do
cFlags <- interpretInContext (libffiContext stage) $ mconcat
context <- libffiContext stage
cFlags <- interpretInContext context $ mconcat
[ cArgs
, getStagedSettingList ConfCcArgs ]
ldFlags <- interpretInContext (libffiContext stage) ldArgs
ldFlags <- interpretInContext context ldArgs
sequence [ builderEnvironment "CC" $ Cc CompileC stage
, builderEnvironment "CXX" $ Cc CompileC stage
, builderEnvironment "LD" (Ld stage)
......@@ -52,7 +97,10 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
-- We set a higher priority because this rule overlaps with the build rule
-- for static libraries 'Rules.Library.libraryRules'.
priority 2.0 $ libffiOuts &%> \(out : _) -> do
-- See [Hadrian: install libffi hack], this rule installs libffi into the
-- rts build path.
priority 2.0 $ libffiOuts &%> \_ -> do
context <- libffiContext stage
useSystemFfi <- flag UseSystemFfi
rtsPath <- rtsBuildPath stage
if useSystemFfi
......@@ -63,25 +111,65 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
putSuccess "| Successfully copied system FFI library header files"
else do
build $ target (libffiContext stage) (Make libffiPath) [] []
build $ target context (Make libffiPath) [] []
-- Here we produce 'libffiDependencies'
hs <- liftIO $ getDirectoryFilesIO "" [libffiPath -/- "inst/include/*"]
forM_ hs $ \header -> do
headers <- liftIO $ getDirectoryFilesIO "" [libffiPath -/- "inst/include/*"]
forM_ headers $ \header -> do
let target = rtsPath -/- takeFileName header
copyFileUntracked header target
produces [target]
ways <- interpretInContext (libffiContext stage)
-- Find ways.
ways <- interpretInContext context
(getLibraryWays <> getRtsWays)
forM_ (nubOrd ways) $ \way -> do
let (dynamicWays, staticWays) = partition (wayUnit Dynamic) ways
-- Install static libraries.
forM_ staticWays $ \way -> do
rtsLib <- rtsLibffiLibrary stage way
copyFileUntracked out rtsLib
copyFileUntracked (libffiPath -/- "inst/lib/libffi.a") rtsLib
produces [rtsLib]
putSuccess "| Successfully built custom library 'libffi'"
-- 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"
fmap (libffiPath -/-) ["Makefile.in", "configure" ] &%> \[mkIn, _] -> do
-- Extract libffi tar file
context <- libffiContext stage
removeDirectory libffiPath
tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
<$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
......@@ -90,11 +178,11 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
-- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
let libname = takeWhile (/= '+') $ takeFileName tarball
-- Move extracted directory to libffiPath.
root <- buildRoot
removeDirectory (root -/- libname)
-- TODO: Simplify.
actionFinally (do
build $ target (libffiContext stage) (Tar Extract) [tarball] [path]
build $ target context (Tar Extract) [tarball] [path]
moveDirectory (path -/- libname) libffiPath) $
-- And finally:
removeFiles (path) [libname <//> "*"]
......@@ -106,12 +194,17 @@ libffiRules = forM_ [Stage1 ..] $ \stage -> do
produces files
fmap (libffiPath -/-) ["Makefile", "config.guess", "config.sub"] &%> \[mk, _, _] -> do
context <- libffiContext stage
-- This need rule extracts the libffi tar file to libffiPath.
need [mk <.> "in"]
-- Configure.
forM_ ["config.guess", "config.sub"] $ \file -> do
copyFile file (libffiPath -/- file)
env <- configureEnvironment stage
buildWithCmdOptions env $
target (libffiContext stage) (Configure libffiPath) [mk <.> "in"] [mk]
target context (Configure libffiPath) [mk <.> "in"] [mk]
dir <- setting BuildPlatform
files <- liftIO $ getDirectoryFilesIO "." [libffiPath -/- dir <//> "*"]
......
......@@ -13,6 +13,7 @@ import Flavour
import Oracles.ModuleFiles
import Packages
import Rules.Gmp
import Rules.Libffi (libffiDependencies)
import Settings
import Target
import Utilities
......@@ -57,6 +58,14 @@ buildDynamicLibUnix root suffix dynlibpath = do
let context = libDynContext dynlib
deps <- contextDependencies context
need =<< mapM pkgLibraryFile 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]
......
......@@ -13,7 +13,6 @@ import Settings
import Settings.Default
import Target
import Utilities
import Flavour
-- | TODO: Drop code duplication
buildProgramRules :: [(Resource, Int)] -> Rules ()
......@@ -45,18 +44,13 @@ getProgramContexts stage = do
-- make sure that we cover these
-- "prof-build-under-other-name" cases.
-- iserv gets its names from Packages.hs:programName
--
profiled <- ghcProfiled <$> flavour
let allCtxs =
if pkg == ghc && profiled && stage > Stage0
then [ Context stage pkg profiling ]
else [ vanillaContext stage pkg
, Context stage pkg profiling
-- TODO Dynamic way has been reverted as the dynamic build is
-- broken. See #15837.
-- , Context stage pkg dynamic
]
ctx <- programContext stage pkg -- TODO: see todo on programContext.
let allCtxs = if pkg == iserv
then [ vanillaContext stage pkg
, Context stage pkg profiling
, Context stage pkg dynamic
]
else [ ctx ]
forM allCtxs $ \ctx -> do
name <- programName ctx
return (name <.> exe, ctx)
......
......@@ -113,11 +113,7 @@ needIservBins = do
rtsways <- interpretInContext (vanillaContext Stage1 ghc) getRtsWays
need =<< traverse programPath
[ Context Stage1 iserv w
| w <- [vanilla, profiling
-- TODO dynamic way has been reverted as the dynamic build
-- is broken. See #15837.
-- , dynamic
]
| w <- [vanilla, profiling, dynamic]
, w `elem` rtsways
]
......
......@@ -50,12 +50,17 @@ flavour = do
getIntegerPackage :: Expr Package
getIntegerPackage = expr (integerLibrary =<< flavour)
-- TODO: there is duplication and inconsistency between this and
-- Rules.Program.getProgramContexts. There should only be one way to get a
-- context / contexts for a given stage and package.
programContext :: Stage -> Package -> Action Context
programContext stage pkg = do
profiled <- ghcProfiled <$> flavour
return $ if pkg == ghc && profiled && stage > Stage0
then Context stage pkg profiling
else vanillaContext stage pkg
dynGhcProgs <- dynamicGhcPrograms =<< flavour
return . Context stage pkg . wayFromUnits . concat $
[ [ Profiling | pkg == ghc && profiled && stage > Stage0 ]
, [ Dynamic | dynGhcProgs && stage > Stage0 ]
]
-- TODO: switch to Set Package as the order of packages should not matter?
-- Otherwise we have to keep remembering to sort packages from time to time.
......
......@@ -19,8 +19,12 @@ configureBuilderArgs = do
, builder (Configure libffiPath) ? do
top <- expr topDirectory
targetPlatform <- getSetting TargetPlatform
way <- getWay
pure [ "--prefix=" ++ top -/- libffiPath -/- "inst"
, "--libdir=" ++ top -/- libffiPath -/- "inst/lib"
, "--enable-static=yes"
, "--enable-shared=no" -- TODO: add support for yes
, "--enable-shared="
++ (if wayUnit Dynamic way
then "yes"
else "no")
, "--host=" ++ targetPlatform ] ]
......@@ -8,6 +8,7 @@ import Packages
import Settings.Builders.Common
import Settings.Warnings
import qualified Context as Context
import Rules.Libffi (libffiName)
ghcBuilderArgs :: Args
ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies]
......@@ -46,20 +47,37 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
libs <- getContextData extraLibs
libDirs <- getContextData extraLibDirs
fmwks <- getContextData frameworks
dynamic <- requiresDynamic
darwin <- expr osxHost
way <- getWay
-- Relative path from the output (rpath $ORIGIN).
originPath <- dropFileName <$> getOutput
context <- getContext
libPath' <- expr (libPath context)
distDir <- expr Context.distDir
useSystemFfi <- expr (flag UseSystemFfi)
buildPath <- getBuildPath
libffiName' <- libffiName
let
dynamic = Dynamic `wayUnit` way
distPath = libPath' -/- distDir
originToLibsDir = makeRelativeNoSysLink originPath distPath
rpath | darwin = "@loader_path" -/- originToLibsDir
| otherwise = "$ORIGIN" -/- originToLibsDir
-- TODO: an alternative would be to generalize by linking with extra
-- bundled libraries, but currently the rts is the only use case. It is
-- a special case when `useSystemFfi == True`: the ffi library files
-- are not actually bundled with the rts. Perhaps ffi should be part of
-- rts's extra libraries instead of extra bundled libraries in that
-- case. Care should be take as to not break the make build.
rtsFfiArg = package rts ? not useSystemFfi ? mconcat
[ arg ("-L" ++ buildPath)
, arg ("-l" ++ libffiName')
]
mconcat [ dynamic ? mconcat
[ arg "-dynamic"
-- TODO what about windows?
......@@ -70,8 +88,9 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
, arg "-no-auto-link-packages"
, nonHsMainPackage pkg ? arg "-no-hs-main"
, not (nonHsMainPackage pkg) ? arg "-rtsopts"
, pure [ "-l" ++ lib | lib <- libs ]
, pure [ "-l" ++ lib | lib <- libs ]
, pure [ "-L" ++ libDir | libDir <- libDirs ]
, rtsFfiArg
, darwin ? pure (concat [ ["-framework", fmwk] | fmwk <- fmwks ])
]
......@@ -117,8 +136,7 @@ commonGhcArgs = do
wayGhcArgs :: Args
wayGhcArgs = do
way <- getWay
dynamic <- requiresDynamic
mconcat [ if dynamic
mconcat [ if Dynamic `wayUnit` way
then pure ["-fPIC", "-dynamic"]
else arg "-static"
, (Threaded `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
......@@ -156,20 +174,3 @@ includeGhcArgs = do
, arg $ "-I" ++ root -/- generatedDir
, arg $ "-optc-I" ++ root -/- generatedDir
, pure ["-optP-include", "-optP" ++ cabalMacros] ]
-- Check if building dynamically is required. GHC is a special case that needs
-- to be built dynamically if any of the RTS ways is dynamic.
requiresDynamic :: Expr Bool
requiresDynamic = wayUnit Dynamic <$> getWay
-- TODO This logic has been reverted as the dynamic build is broken.
-- See #15837.
--
-- pkg <- getPackage
-- way <- getWay
-- rtsWays <- getRtsWays
-- let
-- dynRts = any (Dynamic `wayUnit`) rtsWays
-- dynWay = Dynamic `wayUnit` way
-- return $ if pkg == ghc
-- then dynRts || dynWay
-- else dynWay
Subproject commit 97484d8e46f3c542523ef5daf5470540a4d66cb6
Subproject commit fd51946bbb3850165de5f7b394fa987d1f4bd28e
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