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

1 files changed, 130 insertions, 6 deletions

diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index b7e3d49b53..b7f39609b9 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -1,16 +1,17 @@
-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