From 5f1830817b90960d5d11bee95a99df3e1425f8ab Mon Sep 17 00:00:00 2001
From: David Eichmann <EichmannD@gmail.com>
Date: Wed, 27 Feb 2019 18:31:13 +0000
Subject: [PATCH] Hadrian: add rts shared library symlinks for backwards
compatability
Fixes test T3807 when building with Hadrian.
Trac #16370
---
hadrian/hadrian.cabal | 3 +-
hadrian/src/Hadrian/Utilities.hs | 39 ++++++++++++++++++++---
hadrian/src/Rules.hs | 2 ++
hadrian/src/Rules/Register.hs | 4 +++
hadrian/src/Rules/Rts.hs | 54 ++++++++++++++++++++++++++++++++
testsuite/tests/dynlibs/Makefile | 5 +++
6 files changed, 102 insertions(+), 5 deletions(-)
create mode 100644 hadrian/src/Rules/Rts.hs
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index 02d524a957ec..fdcba15b8d32 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -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.*
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
index 42a6fffe1d85..42125c750bea 100644
--- a/hadrian/src/Hadrian/Utilities.hs
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -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 $
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index e4de23f34d51..d9fa167b50a7 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -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 ()
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index f278cc76f9d5..39899738c1b4 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -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.
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
new file mode 100644
index 000000000000..553bdbbf9e60
--- /dev/null
+++ b/hadrian/src/Rules/Rts.hs
@@ -0,0 +1,54 @@
+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
diff --git a/testsuite/tests/dynlibs/Makefile b/testsuite/tests/dynlibs/Makefile
index e3af7503e7e9..7201cfdbdb4e 100644
--- a/testsuite/tests/dynlibs/Makefile
+++ b/testsuite/tests/dynlibs/Makefile
@@ -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
--
GitLab