Hadrian: Track RTS library symlink targets

This requires creating RTS library symlinks when registering, outside
of the rule for the registered library file.

5 files changed, 53 insertions, 48 deletions

diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
index a1386e68fc..48ba34964e 100644
--- a/hadrian/src/Hadrian/Utilities.hs
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -16,7 +16,7 @@ module Hadrian.Utilities (
     BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
 
     -- * File system operations
-    copyFile, copyFileUntracked, createFileLink, createFileLinkUntracked, fixFile,
+    copyFile, copyFileUntracked, createFileLink, fixFile,
     makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
     moveDirectory, removeDirectory,
 
@@ -290,17 +290,6 @@ infixl 1 <&>
 isGeneratedSource :: FilePath -> Action Bool
 isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
 
--- | Link a file (without tracking the link target). Create the target directory
--- if missing.
-createFileLinkUntracked :: FilePath -> FilePath -> Action ()
-createFileLinkUntracked linkTarget link = do
-    let dir = takeDirectory link
-    liftIO $ IO.createDirectoryIfMissing True dir
-    putProgressInfo =<< renderCreateFileLink linkTarget link
-    quietly . liftIO $ do
-        IO.removeFile link <|> return ()
-        IO.createFileLink linkTarget link
-
 -- | Link a file tracking the link target. Create the target directory if
 -- missing.
 createFileLink :: FilePath -> FilePath -> Action ()
@@ -309,7 +298,12 @@ createFileLink linkTarget link = do
                     then linkTarget
                     else takeDirectory link -/- linkTarget
     need [source]
-    createFileLinkUntracked linkTarget link
+    let dir = takeDirectory link
+    liftIO $ IO.createDirectoryIfMissing True dir
+    putProgressInfo =<< renderCreateFileLink linkTarget link
+    quietly . liftIO $ do
+        IO.removeFile link <|> return ()
+        IO.createFileLink linkTarget link
 
 -- | Copy a file tracking the source. Create the target directory if missing.
 copyFile :: FilePath -> FilePath -> Action ()
diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs
index aea855df11..75a2cb2c3e 100644
--- a/hadrian/src/Rules/Library.hs
+++ b/hadrian/src/Rules/Library.hs
@@ -11,7 +11,7 @@ import Expression hiding (way, package)
 import Oracles.ModuleFiles
 import Packages
 import Rules.Gmp
-import Rules.Rts (needRtsLibffiTargets)
+import Rules.Register
 import Target
 import Utilities
 
@@ -85,7 +85,7 @@ buildDynamicLibUnix root suffix dynlibpath = do
     dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
     let context = libDynContext dynlib
     deps <- contextDependencies context
-    need =<< mapM pkgRegisteredLibraryFile deps
+    registerPackages deps
     objs <- libraryObjects context
     build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
 
@@ -144,28 +144,6 @@ libraryObjects context@Context{..} = do
     need $ noHsObjs ++ hsObjs
     return (noHsObjs ++ hsObjs)
 
--- | Return extra library targets.
-extraTargets :: Context -> Action [FilePath]
-extraTargets context
-    | package context == rts  = needRtsLibffiTargets (Context.stage context)
-    | otherwise               = return []
-
--- | Given a library 'Package' this action computes all of its targets. Needing
--- all the targets should build the library such that it is ready to be
--- registered into the package database.
--- See 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
-libraryTargets :: Bool -> Context -> Action [FilePath]
-libraryTargets includeGhciLib context@Context {..} = do
-    libFile  <- pkgLibraryFile     context
-    ghciLib  <- pkgGhciLibraryFile context
-    ghci     <- if includeGhciLib && not (wayUnit Dynamic way)
-                then interpretInContext context $ getContextData buildGhciLib
-                else return False
-    extra    <- extraTargets context
-    return $ [ libFile ]
-          ++ [ ghciLib | ghci ]
-          ++ extra
-
 -- | Coarse-grain 'need': make sure all given libraries are fully built.
 needLibrary :: [Context] -> Action ()
 needLibrary cs = need =<< concatMapM (libraryTargets True) cs
@@ -270,4 +248,4 @@ parseLibDynFilename ext = do
 
 -- | Get the package identifier given the package name and version.
 pkgId :: String -> [Integer] -> String
-pkgId name version = name ++ "-" ++ intercalate "." (map show version)
\ No newline at end of file
+pkgId name version = name ++ "-" ++ intercalate "." (map show version)
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index 7efe6c42ae..96855a3927 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -15,6 +15,7 @@ import Settings.Default
 import Target
 import Utilities
 import Rules.Library
+import Rules.Register
 
 -- | TODO: Drop code duplication
 buildProgramRules :: [(Resource, Int)] -> Rules ()
@@ -96,8 +97,7 @@ buildProgram bin ctx@(Context{..}) rs = do
   -- but when building the program, we link against the *ghc-pkg registered* library e.g.
   --    _build/stage1/lib/x86_64-linux-ghc-8.9.0.20190430/libHShaskeline-0.7.5.0-ghc8.9.0.20190430.so
   -- so we use pkgRegisteredLibraryFile instead.
-  need =<< mapM pkgRegisteredLibraryFile
-       =<< contextDependencies ctx
+  registerPackages =<< contextDependencies ctx
 
   cross <- flag CrossCompiling
   -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index 700756eaad..d815d40c98 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -1,7 +1,11 @@
-module Rules.Register (configurePackageRules, registerPackageRules) where
+module Rules.Register (
+    configurePackageRules, registerPackageRules, registerPackages,
+    libraryTargets
+    ) where
 
 import Base
 import Context
+import Expression ( getContextData )
 import Hadrian.BuildPath
 import Hadrian.Expression
 import Hadrian.Haskell.Cabal
@@ -12,7 +16,9 @@ import Rules.Rts
 import Settings
 import Target
 import Utilities
-import Rules.Library
+
+import Hadrian.Haskell.Cabal.Type
+import qualified Text.Parsec      as Parsec
 
 import Distribution.Version (Version)
 import qualified Distribution.Parsec as Cabal
@@ -21,7 +27,6 @@ import qualified Distribution.Types.PackageId as Cabal
 
 import qualified Hadrian.Haskell.Cabal.Parse as Cabal
 import qualified System.Directory            as IO
-import qualified Text.Parsec                 as Parsec
 
 -- * Configuring
 
@@ -63,6 +68,15 @@ parseToBuildSubdirectory root = do
 
 -- * Registering
 
+registerPackages :: [Context] -> Action ()
+registerPackages ctxs = do
+    need =<< mapM pkgRegisteredLibraryFile ctxs
+
+    -- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
+    forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do
+        ways <- interpretInContext ctx (getLibraryWays <> getRtsWays)
+        needRtsSymLinks (stage ctx) ways
+
 -- | Register a package and initialise the corresponding package database if
 -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
 registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
@@ -118,9 +132,6 @@ 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.
@@ -171,3 +182,25 @@ parseCabalName = fmap f . Cabal.eitherParsec
   where
     f :: Cabal.PackageId -> (String, Version)
     f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)
+
+-- | Return extra library targets.
+extraTargets :: Context -> Action [FilePath]
+extraTargets context
+    | package context == rts  = needRtsLibffiTargets (Context.stage context)
+    | otherwise               = return []
+
+-- | Given a library 'Package' this action computes all of its targets. Needing
+-- all the targets should build the library such that it is ready to be
+-- registered into the package database.
+-- See 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
+libraryTargets :: Bool -> Context -> Action [FilePath]
+libraryTargets includeGhciLib context@Context {..} = do
+    libFile  <- pkgLibraryFile     context
+    ghciLib  <- pkgGhciLibraryFile context
+    ghci     <- if includeGhciLib && not (wayUnit Dynamic way)
+                then interpretInContext context $ getContextData buildGhciLib
+                else return False
+    extra    <- extraTargets context
+    return $ [ libFile ]
+          ++ [ ghciLib | ghci ]
+          ++ extra
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index b7f39609b9..c9669f520d 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -17,7 +17,7 @@ rtsRules = priority 3 $ do
       root -/- "//libHSrts_*-ghc*.dylib",
       root -/- "//libHSrts-ghc*.so",
       root -/- "//libHSrts-ghc*.dylib"]
-      |%> \ rtsLibFilePath' -> createFileLinkUntracked
+      |%> \ rtsLibFilePath' -> createFileLink
             (addRtsDummyVersion $ takeFileName rtsLibFilePath')
             rtsLibFilePath'
 
@@ -175,4 +175,4 @@ replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let
         (error $ "Expected RTS library file to start with " ++ oldPrefix)
         (newPrefix ++)
         (stripPrefix oldPrefix oldFileName)
-    in replaceFileName oldFilePath newFileName
\ No newline at end of file
+    in replaceFileName oldFilePath newFileName