Hadrian: add rts shared library symlinks for backwards compatability

Fixes test T3807 when building with Hadrian.

Trac #16370

2 files changed, 58 insertions, 0 deletions

diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index f278cc76f9..39899738c1 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 0000000000..553bdbbf9e
--- /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