Hadrian: add rts shared library symlinks for backwards compatability

Fixes test T3807 when building with Hadrian.

Trac #16370

1 files changed, 54 insertions, 0 deletions

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