feature: batched compilation of extra-sources

All C sources for a component are now compiled with a single one-shot
(the `-c` option) GHC invocation, rather than one-per-source, and ditto
for each other type of extra-source. In addition, `--semaphore` now
propagates `-jsem` to these GHC invocations if working with a GHC that
supports this (see
https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12388/ for the
status of that support).

Author: edmundnoble

Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs

@@ -10,7 +10,7 @@ import Distribution.Types.ParStrat
 import Distribution.Simple.Flag
 import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), AbiTag(NoAbiTag))
 import Distribution.PackageDescription (emptyPackageDescription)
-import Distribution.Simple.Program.GHC (normaliseGhcArgs, renderGhcOptions, ghcOptNumJobs)
+import Distribution.Simple.Program.GHC (normaliseGhcArgs, renderGhcOptions, GhcMode(..), ghcOptNumJobs, ghcOptMode)
 import Distribution.Version            (mkVersion)
 
 tests :: TestTree
@@ -44,7 +44,7 @@ tests = testGroup "Distribution.Simple.Program.GHC"
             assertListEquals flags options_9_0_affects
         ]
     , testGroup "renderGhcOptions"
-      [ testCase "options" $ do
+      [ testCase "parallel make" $ do
             let flags :: [String]
                 flags = renderGhcOptions
                   (Compiler
@@ -57,8 +57,27 @@ tests = testGroup "Distribution.Simple.Program.GHC"
                       , compilerWiredInUnitIds = Nothing
                       })
                   (Platform X86_64 Linux)
-                  (mempty { ghcOptNumJobs = Flag (NumJobs (Just 4)) })
-            assertListEquals flags ["-j4", "-clear-package-db"]
+                  (mempty
+                    { ghcOptMode = Flag GhcModeMake
+                    , ghcOptNumJobs = Flag (NumJobs (Just 4)) })
+            assertListEquals flags ["--make", "-j4", "-clear-package-db"]
+      , testCase "parallel batch" $ do
+            let flags :: [String]
+                flags = renderGhcOptions
+                  (Compiler
+                      { compilerId = CompilerId GHC (mkVersion [9,8,1])
+                      , compilerAbiTag = NoAbiTag
+                      , compilerCompat = []
+                      , compilerLanguages = []
+                      , compilerExtensions = []
+                      , compilerProperties = Map.singleton "Support parallel batch mode" "YES"
+                      , compilerWiredInUnitIds = Nothing
+                      })
+                  (Platform X86_64 Linux)
+                  (mempty
+                    { ghcOptMode = Flag GhcModeCompile
+                    , ghcOptNumJobs = Flag (NumJobs (Just 4)) })
+            assertListEquals flags ["-c", "-j4", "-clear-package-db"]
         ]
     ]
 

Cabal/src/Distribution/Simple/Compiler.hs

@@ -67,6 +67,7 @@ module Distribution.Simple.Compiler
   , extensionsToFlags
   , unsupportedExtensions
   , parmakeSupported
+  , parBatchSupported
   , reexportedModulesSupported
   , renamingPackageFlagsSupported
   , unifiedIPIDRequired
@@ -447,6 +448,10 @@ extensionToFlag' comp ext = lookup ext (compilerExtensions comp)
 parmakeSupported :: Compiler -> Bool
 parmakeSupported = ghcSupported "Support parallel --make"
 
+-- | Does this compiler support parallel batch mode?
+parBatchSupported :: Compiler -> Bool
+parBatchSupported = ghcSupported "Support parallel batch mode"
+
 -- | Does this compiler support reexported-modules?
 reexportedModulesSupported :: Compiler -> Bool
 reexportedModulesSupported = ghcSupported "Support reexported-modules"

Cabal/src/Distribution/Simple/GHC/Build.hs

@@ -145,7 +145,7 @@ build numJobs pkg_descr pbci = do
                 (Nothing, Just mainFile)
           Nothing -> (Nothing, Nothing)
   buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays pbci
-  extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays pbci
+  extraSources <- buildAllExtraSources numJobs nonHsMainFile ghcProg buildTargetDir wantedWays pbci
   linkOrLoadComponent
     ghcProg
     pkg_descr

Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs

@@ -6,7 +6,7 @@
 
 module Distribution.Simple.GHC.Build.ExtraSources where
 
-import Control.Monad
+import Control.Monad (forM, when)
 import Data.Foldable
 import Distribution.Simple.Flag
 import qualified Distribution.Simple.GHC.Internal as Internal
@@ -16,6 +16,7 @@ import Distribution.Utils.NubList
 
 import Distribution.Types.BuildInfo
 import Distribution.Types.Component
+import Distribution.Types.ParStrat
 import Distribution.Types.TargetInfo
 
 import Distribution.Simple.Build.Inputs
@@ -32,7 +33,8 @@ import Distribution.Verbosity (Verbosity)
 -- | An action that builds all the extra build sources of a component, i.e. C,
 -- C++, Js, Asm, C-- sources.
 buildAllExtraSources
-  :: Maybe (SymbolicPath Pkg File)
+  :: Flag ParStrat
+  -> Maybe (SymbolicPath Pkg File)
   -- ^ An optional non-Haskell Main file
   -> ConfiguredProgram
   -- ^ The GHC configured program
@@ -58,7 +60,8 @@ buildCSources
   , buildJsSources
   , buildAsmSources
   , buildCmmSources
-    :: Maybe (SymbolicPath Pkg File)
+    :: Flag ParStrat
+    -> Maybe (SymbolicPath Pkg File)
     -- ^ An optional non-Haskell Main file
     -> ConfiguredProgram
     -- ^ The GHC configured program
@@ -70,7 +73,7 @@ buildCSources
     -- ^ The context and component being built in it.
     -> IO (NubListR (SymbolicPath Pkg File))
     -- ^ Returns the list of extra sources that were built
-buildCSources mbMainFile =
+buildCSources parStrat mbMainFile =
   buildExtraSources
     "C Sources"
     Internal.componentCcGhcOptions
@@ -83,7 +86,8 @@ buildCSources mbMainFile =
                 cFiles ++ [main]
           _otherwise -> cFiles
     )
-buildCxxSources mbMainFile =
+    parStrat
+buildCxxSources parStrat mbMainFile =
   buildExtraSources
     "C++ Sources"
     Internal.componentCxxGhcOptions
@@ -96,7 +100,8 @@ buildCxxSources mbMainFile =
                 cxxFiles ++ [main]
           _otherwise -> cxxFiles
     )
-buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do
+    parStrat
+buildJsSources parStrat _mbMainFile ghcProg buildTargetDir neededWays = do
   Platform hostArch _ <- hostPlatform <$> localBuildInfo
   let hasJsSupport = hostArch == JavaScript
   buildExtraSources
@@ -111,19 +116,22 @@ buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do
             jsSources (componentBuildInfo c)
           else mempty
     )
+    parStrat
     ghcProg
     buildTargetDir
     neededWays
-buildAsmSources _mbMainFile =
+buildAsmSources parStrat _mbMainFile =
   buildExtraSources
     "Assembler Sources"
     Internal.componentAsmGhcOptions
     (asmSources . componentBuildInfo)
-buildCmmSources _mbMainFile =
+    parStrat
+buildCmmSources parStrat _mbMainFile =
   buildExtraSources
     "C-- Sources"
     Internal.componentCmmGhcOptions
     (cmmSources . componentBuildInfo)
+    parStrat
 
 -- | Create 'PreBuildComponentRules' for a given type of extra build sources
 -- which are compiled via a GHC invocation with the given options. Used to
@@ -136,7 +144,6 @@ buildExtraSources
        -> BuildInfo
        -> ComponentLocalBuildInfo
        -> SymbolicPath Pkg (Dir Artifacts)
-       -> SymbolicPath Pkg File
        -> GhcOptions
      )
   -- ^ Function to determine the @'GhcOptions'@ for the
@@ -149,6 +156,7 @@ buildExtraSources
   -- @'Executable'@ components might additionally add the
   -- program entry point (@main-is@ file) to the extra sources,
   -- if it should be compiled as the rest of them.
+  -> Flag ParStrat
   -> ConfiguredProgram
   -- ^ The GHC configured program
   -> SymbolicPath Pkg (Dir Artifacts)
@@ -163,6 +171,7 @@ buildExtraSources
   description
   componentSourceGhcOptions
   viewSources
+  parStrat
   ghcProg
   buildTargetDir
   (neededLibWays, neededFLibWay, neededExeWay) =
@@ -189,84 +198,82 @@ buildExtraSources
             platform
             mbWorkDir
 
-        buildAction :: SymbolicPath Pkg File -> IO ()
-        buildAction sourceFile = do
+        buildAction :: [SymbolicPath Pkg File] -> IO ()
+        buildAction sourceFiles = do
           let baseSrcOpts =
                 componentSourceGhcOptions
                   verbosity
                   lbi
                   bi
                   clbi
                   buildTargetDir
-                  sourceFile
               vanillaSrcOpts =
-                -- -fPIC is used in case you are using the repl
-                -- of a dynamically linked GHC
-                baseSrcOpts{ghcOptFPic = toFlag True}
+                baseSrcOpts
+                  { ghcOptFPic = toFlag True
+                  , -- -fPIC is always used in case you are using the repl of a
+                    -- dynamically linked GHC
+                    ghcOptNumJobs = parStrat
+                  }
               profSrcOpts =
                 vanillaSrcOpts
-                  `mappend` mempty
-                    { ghcOptProfilingMode = toFlag True
-                    }
+                  { ghcOptProfilingMode = toFlag True
+                  , ghcOptObjSuffix = toFlag "p_o"
+                  }
               sharedSrcOpts =
                 vanillaSrcOpts
-                  `mappend` mempty
-                    { ghcOptFPic = toFlag True
-                    , ghcOptDynLinkMode = toFlag GhcDynamicOnly
-                    }
+                  { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+                  , ghcOptObjSuffix = toFlag "dyn_o"
+                  }
               profSharedSrcOpts =
                 vanillaSrcOpts
-                  `mappend` mempty
-                    { ghcOptProfilingMode = toFlag True
-                    , ghcOptFPic = toFlag True
-                    , ghcOptDynLinkMode = toFlag GhcDynamicOnly
-                    }
+                  { ghcOptProfilingMode = toFlag True
+                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+                  , ghcOptObjSuffix = toFlag "p_dyn_o"
+                  }
               -- TODO: Placing all Haskell, C, & C++ objects in a single directory
               --       Has the potential for file collisions. In general we would
               --       consider this a user error. However, we should strive to
               --       add a warning if this occurs.
               odir = fromFlag (ghcOptObjDir vanillaSrcOpts)
 
-              compileIfNeeded :: GhcOptions -> IO ()
-              compileIfNeeded opts = do
-                needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts
-                when needsRecomp $ runGhcProg opts
-
           createDirectoryIfMissingVerbose verbosity True (i odir)
-          case targetComponent targetInfo of
-            -- For libraries, we compile extra objects in the four ways: vanilla, shared, profiled and profiled shared.
-            -- We suffix shared objects with `.dyn_o`, profiled ones with `.p_o` and profiled shared ones with `.p_dyn_o`.
-            CLib _lib
-              -- Unless for repl, in which case we only need the vanilla way
-              | BuildRepl _ <- buildingWhat ->
-                  compileIfNeeded vanillaSrcOpts
-              | otherwise ->
-                  do
-                    forM_ (neededLibWays isIndef) $ \case
-                      StaticWay -> compileIfNeeded vanillaSrcOpts
-                      DynWay -> compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"}
-                      ProfWay -> compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"}
-                      ProfDynWay -> compileIfNeeded profSharedSrcOpts{ghcOptObjSuffix = toFlag "p_dyn_o"}
-            CFLib flib ->
-              case neededFLibWay (withDynFLib flib) of
-                StaticWay -> compileIfNeeded vanillaSrcOpts
-                DynWay -> compileIfNeeded sharedSrcOpts
-                ProfWay -> compileIfNeeded profSrcOpts
-                ProfDynWay -> compileIfNeeded profSharedSrcOpts
-            -- For the remaining component types (Exec, Test, Bench), we also
-            -- determine with which options to build the objects (vanilla vs shared vs
-            -- profiled), but predicate is the same for the three kinds.
-            _exeLike ->
-              case neededExeWay of
-                StaticWay -> compileIfNeeded vanillaSrcOpts
-                DynWay -> compileIfNeeded sharedSrcOpts
-                ProfWay -> compileIfNeeded profSrcOpts
-                ProfDynWay -> compileIfNeeded profSharedSrcOpts
+          let optsForWay = \case
+                StaticWay -> vanillaSrcOpts
+                DynWay -> sharedSrcOpts
+                ProfWay -> profSrcOpts
+                ProfDynWay -> profSharedSrcOpts
+          -- we don't tell GHC to suffix the filenames of objects produced from
+          -- extra-sources for executables or foreign libraries
+          let stripObjectSuffix opts =
+                opts{ghcOptObjSuffix = ghcOptObjSuffix baseSrcOpts}
 
+          let optsForNeededWays =
+                case targetComponent targetInfo of
+                  -- For libraries (foreign or not), we compile extra objects in the four ways: vanilla, shared,
+                  -- profiled and profiled shared. We suffix shared objects with `.dyn_o`, profiled ones with `.p_o`
+                  -- and profiled shared ones with `.p_dyn_o`.
+                  CLib _lib
+                    -- Unless for repl, in which case we only need the vanilla way
+                    | BuildRepl _ <- buildingWhat ->
+                        [vanillaSrcOpts]
+                    | otherwise ->
+                        optsForWay <$> neededLibWays isIndef
+                  CFLib flib ->
+                    [stripObjectSuffix (optsForWay (neededFLibWay (withDynFLib flib)))]
+                  -- For the remaining component types (Exec, Test, Bench) we
+                  -- only need to build them with one set of options.
+                  _exeLike ->
+                    [stripObjectSuffix (optsForWay neededExeWay)]
+          forM_ optsForNeededWays $ \opts -> do
+            files <- fmap concat $ forM sourceFiles $ \sourceFile -> do
+              needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts
+              return [sourceFile | needsRecomp]
+            when (not (null files)) $
+              runGhcProg opts{ghcOptInputFiles = toNubListR files}
       -- build any sources
       if (null sources || componentIsIndefinite clbi)
         then return mempty
         else do
           info verbosity ("Building " ++ description ++ "...")
-          traverse_ buildAction sources
+          buildAction sources
           return (toNubListR sources)

Cabal/src/Distribution/Simple/GHC/Build/Link.hs

@@ -112,6 +112,8 @@ linkOrLoadComponent
     let
       extraSourcesObjs :: [RelativePath Artifacts File]
       extraSourcesObjs =
+        -- note that extra-sources objects are not suffixed with the way suffix
+        -- right now
         [ makeRelativePathEx $ getSymbolicPath src `replaceExtension` objExtension
         | src <- extraSources
         ]