Hadrian: add rts shared library symlinks for backwards compatability

Fixes test T3807 when building with Hadrian.

Trac #16370

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.*

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 $

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 ()

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.

hadrian/src/Rules/Rts.hs

+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

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