Commit 5f183081 authored by David Eichmann's avatar David Eichmann 🏋 Committed by Marge Bot

Hadrian: add rts shared library symlinks for backwards compatability

Fixes test T3807 when building with Hadrian.

Trac #16370
parent 40848a43
......@@ -66,6 +66,7 @@ executable hadrian
, Rules.Nofib
, Rules.Program
, Rules.Register
, Rules.Rts
, Rules.Selftest
, Rules.SimpleTargets
, Rules.SourceDist
......@@ -121,7 +122,7 @@ executable hadrian
build-depends: base >= 4.8 && < 5
, Cabal >= 3.0 && < 3.1
, containers >= 0.5 && < 0.7
, directory >= 1.2 && < 1.4
, directory >= 1.3.1.0 && < 1.4
, extra >= 1.4.7
, filepath
, mtl == 2.2.*
......
......@@ -16,8 +16,9 @@ module Hadrian.Utilities (
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
-- * File system operations
copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
createDirectory, copyDirectory, moveDirectory, removeDirectory,
copyFile, copyFileUntracked, createFileLinkUntracked, fixFile,
makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
moveDirectory, removeDirectory,
-- * Diagnostic info
UseColour (..), Colour (..), ANSIColour (..), putColoured,
......@@ -288,6 +289,14 @@ infixl 1 <&>
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
-- | Link a file tracking the source. Create the target directory if missing.
createFileLinkUntracked :: FilePath -> FilePath -> Action ()
createFileLinkUntracked linkTarget link = do
let dir = takeDirectory linkTarget
liftIO $ IO.createDirectoryIfMissing True dir
putProgressInfo =<< renderCreateFileLink linkTarget link
quietly . liftIO $ IO.createFileLink linkTarget link
-- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
......@@ -460,8 +469,12 @@ renderAction what input output = do
return $ case progressInfo of
None -> ""
Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
Normal -> renderBox [ what
, " input: " ++ i
, " => output: " ++ o ]
Unicorn -> renderUnicorn [ what
, " input: " ++ i
, " => output: " ++ o ]
where
i = unifyPath input
o = unifyPath output
......@@ -478,6 +491,24 @@ renderActionNoOutput what input = do
where
i = unifyPath input
-- | Render creating a file link.
renderCreateFileLink :: String -> FilePath -> Action String
renderCreateFileLink linkTarget link' = do
progressInfo <- userSetting Brief
let what = "Creating file link"
linkString = link ++ " -> " ++ linkTarget
return $ case progressInfo of
None -> ""
Brief -> "| " ++ what ++ ": " ++ linkString
Normal -> renderBox [ what
, " link name: " ++ link
, " -> link target: " ++ linkTarget ]
Unicorn -> renderUnicorn [ what
, " link name: " ++ link
, " -> link target: " ++ linkTarget ]
where
link = unifyPath link'
-- | Render the successful build of a program.
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox $
......
......@@ -21,6 +21,7 @@ import qualified Rules.Libffi
import qualified Rules.Library
import qualified Rules.Program
import qualified Rules.Register
import qualified Rules.Rts
import qualified Rules.SimpleTargets
import Settings
import Target
......@@ -158,6 +159,7 @@ buildRules = do
Rules.Gmp.gmpRules
Rules.Libffi.libffiRules
Rules.Library.libraryRules
Rules.Rts.rtsRules
packageRules
oracleRules :: Rules ()
......
......@@ -8,6 +8,7 @@ import Hadrian.Haskell.Cabal
import Oracles.Setting
import Packages
import Rules.Gmp
import Rules.Rts
import Settings
import Target
import Utilities
......@@ -117,6 +118,9 @@ 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.
......
module Rules.Rts (rtsRules, needRtsSymLinks) where
import Packages (rts)
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 2 to override the general rule for generating share
-- library files (see Rules.Library.libraryRules).
rtsRules :: Rules ()
rtsRules = priority 2 $ do
root <- buildRootRules
[ root -/- "//libHSrts_*-ghc*.so",
root -/- "//libHSrts_*-ghc*.dylib",
root -/- "//libHSrts-ghc*.so",
root -/- "//libHSrts-ghc*.dylib"]
|%> \ rtsLibFilePath' -> createFileLinkUntracked
(addRtsDummyVersion $ takeFileName rtsLibFilePath')
rtsLibFilePath'
-- Need symlinks generated by rtsRules.
needRtsSymLinks :: Stage -> [Way] -> Action ()
needRtsSymLinks stage rtsWays
= forM_ (filter (wayUnit Dynamic) rtsWays) $ \ way -> do
let ctx = Context stage rts way
libPath <- libPath ctx
distDir <- distDir stage
rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
need [removeRtsDummyVersion (libPath </> distDir </> rtsLibFile)]
prefix, versionlessPrefix :: String
versionlessPrefix = "libHSrts"
prefix = versionlessPrefix ++ "-1.0"
-- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
-- == "a/libHSrts-ghc1.2.3.4.so"
removeRtsDummyVersion :: FilePath -> FilePath
removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix
-- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so"
-- == "a/libHSrts-1.0-ghc1.2.3.4.so"
addRtsDummyVersion :: FilePath -> FilePath
addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix
replaceLibFilePrefix :: String -> String -> FilePath -> FilePath
replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let
oldFileName = takeFileName oldFilePath
newFileName = maybe
(error $ "Expected RTS library file to start with " ++ oldPrefix)
(newPrefix ++)
(stripPrefix oldPrefix oldFileName)
in replaceFileName oldFilePath newFileName
\ No newline at end of file
......@@ -9,6 +9,11 @@ T3807:
$(RM) T3807-export.o T3807-load.o
$(RM) T3807test.so
$(RM) T3807-load
# GHC does not automatically link with the RTS when building shared
# libraries. This is done to allow the RTS flavour to be chosen later (i.e.
# when linking an executable).
# Hence we must explicitly linking with the RTS here.
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -v0 --make -dynamic -fPIC -shared T3807Export.hs T3807-export.c -o T3807test.so -lHSrts-ghc`'$(TEST_HC)' $(TEST_HC_OPTS) --numeric-version`
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -no-auto-link-packages -no-hs-main T3807-load.c -o T3807-load -ldl
./T3807-load
......
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