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

9 files changed, 164 insertions, 64 deletions

diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 8d2aef1c7b..75a74b2ae6 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -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
diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs
index 1fe6174b1e..64f63039eb 100644
--- a/hadrian/src/Rules/Libffi.hs
+++ b/hadrian/src/Rules/Libffi.hs
@@ -1,4 +1,4 @@
-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 <//> "*"]
diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs
index 8bd7067202..d19907bfa9 100644
--- a/hadrian/src/Rules/Library.hs
+++ b/hadrian/src/Rules/Library.hs
@@ -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]
 
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index d7bcb48712..51bc2e9959 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -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)
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 461a95f93a..b72c1b964b 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -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
                ]
 
diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs
index fdbef1c359..bc0f8cecaa 100755
--- a/hadrian/src/Settings.hs
+++ b/hadrian/src/Settings.hs
@@ -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.
diff --git a/hadrian/src/Settings/Builders/Configure.hs b/hadrian/src/Settings/Builders/Configure.hs
index 214aed6c27..427d5da6f6 100644
--- a/hadrian/src/Settings/Builders/Configure.hs
+++ b/hadrian/src/Settings/Builders/Configure.hs
@@ -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 ] ]
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index f18832c1ef..4bc10e5edd 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -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
diff --git a/libraries/Cabal b/libraries/Cabal
-Subproject 97484d8e46f3c542523ef5daf5470540a4d66cb
+Subproject fd51946bbb3850165de5f7b394fa987d1f4bd28