Refactor the linking invocation from gbuild/buildOrReplLib

This is the third part of the refactor of gbuild and buildOrReplLib (haskell#9389). It re-works the linker invocation, focusing on preserving existing behaviour before simplifying any further. Follows the spirit of the two previous commits, with the end goal of (haskell#9389)
alt-romes · Jan 11, 2024 · c756bb4 · c756bb4
1 parent 46726a4
commit c756bb4
Show file tree

Hide file tree

Showing 9 changed files with 837 additions and 1,185 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -336,8 +336,6 @@ library
     Distribution.Simple.GHC.Build.Link
     Distribution.Simple.GHC.Build.Modules
     Distribution.Simple.GHC.Build.Utils
-    Distribution.Simple.GHC.BuildGeneric
-    Distribution.Simple.GHC.BuildOrRepl
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo

diff --git a/Cabal/src/Distribution/Simple/Build/Monad.hs b/Cabal/src/Distribution/Simple/Build/Monad.hs
@@ -87,11 +87,13 @@ buildLBI :: BuildM LocalBuildInfo
 buildLBI = asks localBuildInfo
 {-# INLINE buildLBI #-}
 
+-- | Get the @'Compiler'@ being used to build the component.
 buildCompiler :: BuildM Compiler
 buildCompiler = compiler <$> buildLBI
 {-# INLINE buildCompiler #-}
 
 -- | Get the @'TargetInfo'@ of the current component being built.
 buildTarget :: BuildM TargetInfo
 buildTarget = asks targetInfo
+{-# INLINE buildTarget #-}
 
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
@@ -93,6 +93,8 @@ import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
 import Distribution.Simple.Errors
 import Distribution.Simple.Flag (Flag (..), toFlag)
+import qualified Distribution.Simple.GHC.Build as GHC
+import Distribution.Simple.Build.Monad (runBuildM)
 import Distribution.Simple.GHC.Build.Utils
 import Distribution.Simple.GHC.EnvironmentParser
 import Distribution.Simple.GHC.ImplInfo
@@ -131,13 +133,10 @@ import System.FilePath
   )
 import qualified System.Info
 #ifndef mingw32_HOST_OS
-import Distribution.Simple.GHC.Build.Utils (flibBuildName)
 import System.Directory (renameFile)
 import System.Posix (createSymbolicLink)
 #endif /* mingw32_HOST_OS */
 
-import Distribution.Simple.GHC.BuildGeneric (GBuildMode (..), gbuild)
-import Distribution.Simple.GHC.BuildOrRepl (buildOrReplLib)
 import Distribution.Simple.Setup (BuildingWhat (..))
 import Distribution.Simple.Setup.Build
 
@@ -567,7 +566,8 @@ buildLib
   -> Library
   -> ComponentLocalBuildInfo
   -> IO ()
-buildLib = buildOrReplLib . BuildNormal
+buildLib flags numJobs pkg lbi lib clbi
+  = runBuildM (BuildNormal flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg)
 
 replLib
   :: ReplFlags
@@ -577,7 +577,8 @@ replLib
   -> Library
   -> ComponentLocalBuildInfo
   -> IO ()
-replLib = buildOrReplLib . BuildRepl
+replLib flags numJobs pkg lbi lib clbi
+  = runBuildM (BuildRepl flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg)
 
 -- | Start a REPL without loading any source files.
 startInterpreter
@@ -609,7 +610,8 @@ buildFLib
   -> ForeignLib
   -> ComponentLocalBuildInfo
   -> IO ()
-buildFLib v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildFLib
+buildFLib v njobs pkg lbi flib clbi
+  = runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg)
 
 replFLib
   :: ReplFlags
@@ -619,8 +621,8 @@ replFLib
   -> ForeignLib
   -> ComponentLocalBuildInfo
   -> IO ()
-replFLib replFlags njobs pkg lbi =
-  gbuild (BuildRepl replFlags) njobs pkg lbi . GReplFLib replFlags
+replFLib replFlags njobs pkg lbi flib clbi
+  = runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg)
 
 -- | Build an executable with GHC.
 buildExe
@@ -631,7 +633,8 @@ buildExe
   -> Executable
   -> ComponentLocalBuildInfo
   -> IO ()
-buildExe v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildExe
+buildExe v njobs pkg lbi exe clbi
+  = runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg)
 
 replExe
   :: ReplFlags
@@ -641,8 +644,8 @@ replExe
   -> Executable
   -> ComponentLocalBuildInfo
   -> IO ()
-replExe replFlags njobs pkg lbi =
-  gbuild (BuildRepl replFlags) njobs pkg lbi . GReplExe replFlags
+replExe replFlags njobs pkg lbi exe clbi
+  = runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg)
 
 -- | Extracts a String representing a hash of the ABI of a built
 -- library.  It can fail if the library has not yet been built.
@@ -724,7 +727,7 @@ installExe
   exe = do
     createDirectoryIfMissingVerbose verbosity True binDir
     let exeName' = unUnqualComponentName $ exeName exe
-        exeFileName = exeTargetName (hostPlatform lbi) exe
+        exeFileName = exeTargetName (hostPlatform lbi) (exeName exe)
         fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
         installBinary dest = do
           installExecutableFile

diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs
@@ -6,38 +6,49 @@ import Prelude ()
 
 import Data.Function
 import Control.Monad.IO.Class
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Distribution.Compat.Binary (encode)
-import Distribution.Compat.ResponseFile (escapeArgs)
-import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.Package
 import Distribution.PackageDescription as PD hiding (buildInfo)
-import qualified Distribution.PackageDescription as PD
-import Distribution.PackageDescription.Utils (cabalBug)
-import Distribution.Pretty
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Compiler
-import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault)
-import Distribution.Simple.GHC.ImplInfo
-import qualified Distribution.Simple.GHC.Internal as Internal
+import Distribution.Simple.Flag (Flag)
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program
-import Distribution.Simple.Program.GHC
-import Distribution.Simple.Setup.Repl
 import Distribution.Simple.Utils
-import Distribution.System
-import Distribution.Utils.NubList
-import Distribution.Utils.Path (getSymbolicPath)
-import Distribution.Verbosity
-import Distribution.Version
 import System.Directory hiding (exeExtension)
 import System.FilePath
 import Distribution.Simple.Build.Monad
 import Distribution.Simple.GHC.Build.ExtraSources
 import Distribution.Simple.GHC.Build.Modules
+import Distribution.Simple.GHC.Build.Link
 import Distribution.Types.ParStrat
-import qualified Distribution.Simple.Hpc as Hpc
-import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
+import qualified Data.Set as Set
+
+{-
+Note [Build Target Dir vs Target Dir]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Where to place the build result (targetDir) and the build artifacts (buildTargetDir).
+
+* For libraries, targetDir == buildTargetDir, where both the library and
+artifacts are put together.
+
+* For executables or foreign libs, buildTargetDir == targetDir/<name-of-target-dir>-tmp, where
+    the targetDir is the location where the target (e.g. the executable) is written to
+    and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live
+  Arguably, this difference should not exist (#9498) (TODO)
+
+For instance, for a component `cabal-benchmarks`:
+  targetDir == <buildDir>/cabal-benchmarks
+  buildTargetDir == <buildDir>/cabal-benchmarks/cabal-benchmarks-tmp
+
+Or, for a library `Cabal`:
+  targetDir == <buildDir>/.
+  buildTargetDir == targetDir
+
+Furthermore, we need to account for the limit of characters in ghc
+invocations that different OSes constrain us to. Cabal invocations can
+rapidly reach this limit, in part, due to the long length of cabal v2
+prefixes. To minimize the likelihood, we use
+`makeRelativeToCurrentDirectory` to shorten the paths used in invocations
+(see da6321bb).
+-}
 
 -- | The main build phase of building a component.
 -- Includes building Haskell modules, extra build sources, and linking.
@@ -46,42 +57,14 @@ build :: Flag ParStrat
       -> BuildM ()
 build numJobs pkg_descr = do
   verbosity <- buildVerbosity
-  what      <- buildWhat
   component <- buildComponent
   lbi       <- buildLBI
   clbi      <- buildCLBI
-  buildInfo <- buildBI
-  target    <- buildTarget
 
   let isLib | CLib{} <- component = True
             | otherwise = False
 
-  {-
-    Where to place the build result (targetDir) and the build artifacts (buildTargetDir).
-
-    * For libraries, targetDir == buildTargetDir, where both the library and
-    artifacts are put together.
-   
-    * For executables or foreign libs, buildTargetDir == targetDir/<name-of-target-dir>-tmp, where
-        the targetDir is the location where the target (e.g. the executable) is written to
-        and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live
-      Arguably, this difference should not exist (#9498) (TODO)
-   
-    For instance, for a component `cabal-benchmarks`:
-      targetDir == <buildDir>/cabal-benchmarks
-      buildTargetDir == <buildDir>/cabal-benchmarks/cabal-benchmarks-tmp
-    
-    Or, for a library `Cabal`:
-      targetDir == <buildDir>/.
-      buildTargetDir == targetDir
-    
-    Furthermore, we need to account for the limit of characters in ghc
-    invocations that different OSes constrain us to. Cabal invocations can
-    rapidly reach this limit, in part, due to the long length of cabal v2
-    prefixes. To minimize the likelihood, we use
-    `makeRelativeToCurrentDirectory` to shorten the paths used in invocations
-    (see da6321bb).
-  -}
+  -- See Note [Build Target Dir vs Target Dir]
   let targetDir_absolute = componentBuildDir lbi clbi
       buildTargetDir_absolute
         -- Libraries use the target dir for building (see above)
@@ -101,71 +84,49 @@ build numJobs pkg_descr = do
 
   (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) & liftIO
 
-  -- ensure extra lib dirs exist before passing to ghc
-  cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs buildInfo) & liftIO
-  cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic buildInfo) & liftIO
-
-  buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir
-  buildAllExtraSources ghcProg
-
-  -- Now pattern match and call repl or link action for each kind of component
-  -- ROMES:TODO: Still a work in progress!
-  pure ()
-  -- case what of
-  --   BuildRepl rflags -> do
-  --     -- TODO when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
-  --     runReplOrWriteFlags ghcProg lbi rflags replOpts target (pkgName (PD.package pkg_descr)) & liftIO
-
-  --   _build -> linkComponent
-
---------------------------------------------------------------------------------
--- * Utils, basically.
---------------------------------------------------------------------------------
-
-replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a
-replNoLoad replFlags l
-  | replOptionsNoLoad replFlags == Flag True = mempty
-  | otherwise = l
-
-runReplOrWriteFlags
-  :: ConfiguredProgram
-  -> LocalBuildInfo
-  -> ReplFlags
-  -> GhcOptions
-  -> TargetInfo
-  -> PackageName
-  -> IO ()
-runReplOrWriteFlags ghcProg lbi rflags ghcOpts target pkg_name =
-  let bi = componentBuildInfo $ targetComponent target
-      clbi = targetCLBI target
-      comp = compiler lbi
-      platform = hostPlatform lbi
-  in
-  case replOptionsFlagOutput (replReplOptions rflags) of
-    NoFlag -> runGHC (fromFlag $ replVerbosity rflags) ghcProg comp platform ghcOpts
-    Flag out_dir -> do
-      src_dir <- getCurrentDirectory
-      let uid = componentUnitId clbi
-          this_unit = prettyShow uid
-          reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi]
-          hidden_modules = otherModules bi
-          extra_opts =
-            concat $
-              [ ["-this-package-name", prettyShow pkg_name]
-              , ["-working-dir", src_dir]
-              ]
-                ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules
-                   ]
-                ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules
-                   ]
-      -- Create "paths" subdirectory if it doesn't exist. This is where we write
-      -- information about how the PATH was augmented.
-      createDirectoryIfMissing False (out_dir </> "paths")
-      -- Write out the PATH information into `paths` subdirectory.
-      writeFileAtomic (out_dir </> "paths" </> this_unit) (encode ghcProg)
-      -- Write out options for this component into a file ready for loading into
-      -- the multi-repl
-      writeFileAtomic (out_dir </> this_unit) $
-        BS.pack $
-          escapeArgs $
-            extra_opts ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag})
+  let
+    -- wantVanilla is underspecified, maybe we could deprecated it? (TODO)
+    wantVanilla = if isLib then withVanillaLib lbi else False
+    wantStatic  = if isLib then withStaticLib lbi else withFullyStaticExe lbi
+    wantDynamic = if isLib then withSharedLib lbi else withDynExe lbi
+    wantProf    = if isLib then withProfLib lbi else withProfExe lbi
+
+    -- See also Note [Building Haskell Modules accounting for TH] in Distribution.Simple.GHC.Build.Modules
+    wantedWays
+      = Set.fromList
+      $ [StaticWay | wantStatic]
+      <> [DynWay | wantDynamic ]
+      <> [ProfWay | wantProf ]
+      -- If no way is explicitly wanted, we take vanilla
+      <> [VanillaWay | wantVanilla || not (wantStatic || wantDynamic || wantProf) ]
+      -- ROMES:TODO: Is vanilla necessarily the same as defaultGhcWay? If so,
+      -- we can deal away with VanillaWay and be explicit in -dynamic vs
+      -- -static, or always default to -static. Would simplify further.
+      -- ROMES:TODO: Perhaps, if the component is indefinite, we only pick Vanilla?
+      -- To mimick the old behaviour we need at least profiled too (Vanilla +
+      -- Prof), and there's even a test for profiled signature, whatever that
+      -- means. So only doing vanilla way for indefinite components before seems wrong.
+      -- Consider...
+      -- ROMES:TODO: Perhaps for executables we want to limit the "wanted"
+      -- ways to just one?
+
+  -- ROMES:TODO: From #3294, this may now be possible, after the refactor?
+  -- In the case that there are no C source files that depend on FFI exports, I
+  -- think there is one more way that this can be fixed: we should revert to
+  -- pre-#842 and do compilation and linking in one go. This will obviously make
+  -- the GHC code more complicated, but I suspect it will pay its way: we'll
+  -- also get faster compilation for new versions of GHC since we don't have to
+  -- call GHC twice. Duncan previously claimed that the performance hit from
+  -- calling GHC a second time should not be large, but actually there is a
+  -- substantial performance hit when module graphs are large, as GHC recomputes
+  -- the module graph on every computation (one of the reasons why Shake is so
+  -- much faster.)
+
+  -- We need a separate build and link phase, and C sources must be compiled
+  -- after Haskell modules, because C sources may depend on stub headers
+  -- generated from compiling Haskell modules (#842).
+  (vanillaOpts, wantedWaysMap)
+    <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays
+  extraSources <- buildAllExtraSources ghcProg
+  linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) vanillaOpts wantedWaysMap
+