Add --semaphore flag to enable interaction with GHC Job Server…

Cabal/Cabal.cabal

@@ -148,6 +148,7 @@ library
     Distribution.Types.LocalBuildInfo
     Distribution.Types.TargetInfo
     Distribution.Types.GivenComponent
+    Distribution.Types.ParStrat
     Distribution.Utils.Json
     Distribution.Utils.NubList
     Distribution.Utils.Progress

Cabal/src/Distribution/Simple/Build.hs

@@ -41,6 +41,7 @@ import Distribution.Types.LocalBuildInfo
 import Distribution.Types.ModuleRenaming
 import Distribution.Types.MungedPackageId
 import Distribution.Types.MungedPackageName
+import Distribution.Types.ParStrat
 import Distribution.Types.TargetInfo
 import Distribution.Utils.Path
 
@@ -110,6 +111,7 @@ build
   -- ^ preprocessors to run before compiling
   -> IO ()
 build pkg_descr lbi flags suffixes = do
+  checkSemaphoreSupport verbosity (compiler lbi) flags
   targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
   let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
   info verbosity $
@@ -145,10 +147,21 @@ build pkg_descr lbi flags suffixes = do
             , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
             , installedPkgs = index
             }
+    par_strat <-
+      toFlag <$> case buildUseSemaphore flags of
+        Flag sem_name -> case buildNumJobs flags of
+          Flag{} -> do
+            warn verbosity $ "Ignoring -j due to --semaphore"
+            return $ UseSem sem_name
+          NoFlag -> return $ UseSem sem_name
+        NoFlag -> return $ case buildNumJobs flags of
+          Flag n -> NumJobs n
+          NoFlag -> Serial
+
     mb_ipi <-
       buildComponent
         verbosity
-        (buildNumJobs flags)
+        par_strat
         pkg_descr
         lbi'
         suffixes
@@ -162,6 +175,15 @@ build pkg_descr lbi flags suffixes = do
     distPref = fromFlag (buildDistPref flags)
     verbosity = fromFlag (buildVerbosity flags)
 
+-- | Check for conditions that would prevent the build from succeeding.
+checkSemaphoreSupport
+  :: Verbosity -> Compiler -> BuildFlags -> IO ()
+checkSemaphoreSupport verbosity comp flags = do
+  unless (jsemSupported comp || (isNothing (flagToMaybe (buildUseSemaphore flags)))) $
+    die' verbosity $
+      "Your compiler does not support the -jsem flag. "
+        ++ "To use this feature you must use GHC 9.8 or later."
+
 -- | Write available build information for 'LocalBuildInfo' to disk.
 --
 -- Dumps detailed build information 'build-info.json' to the given directory.
@@ -317,7 +339,7 @@ startInterpreter verbosity programDb comp platform packageDBs =
 
 buildComponent
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> [PPSuffixHandler]
@@ -926,7 +948,7 @@ addInternalBuildTools pkg lbi bi progs =
 -- multiple libs, e.g. for 'LibTest' library-style test suites
 buildLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -946,7 +968,7 @@ buildLib verbosity numJobs pkg_descr lbi lib clbi =
 -- foreign library in configure.
 buildFLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> ForeignLib
@@ -959,7 +981,7 @@ buildFLib verbosity numJobs pkg_descr lbi flib clbi =
 
 buildExe
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Executable

Cabal/src/Distribution/Simple/Compiler.hs

@@ -67,6 +67,7 @@ module Distribution.Simple.Compiler
   , arDashLSupported
   , libraryDynDirSupported
   , libraryVisibilitySupported
+  , jsemSupported
 
     -- * Support for profiling detail levels
   , ProfDetailLevel (..)
@@ -363,6 +364,14 @@ unitIdSupported = ghcSupported "Uses unit IDs"
 backpackSupported :: Compiler -> Bool
 backpackSupported = ghcSupported "Support Backpack"
 
+-- | Does this compiler support the -jsem option?
+jsemSupported :: Compiler -> Bool
+jsemSupported comp = case compilerFlavor comp of
+  GHC -> v >= mkVersion [9, 7]
+  _ -> False
+  where
+    v = compilerVersion comp
+
 -- | Does this compiler support a package database entry with:
 -- "dynamic-library-dirs"?
 libraryDynDirSupported :: Compiler -> Bool

Cabal/src/Distribution/Simple/GHC.hs

@@ -114,6 +114,7 @@ import Distribution.Simple.Utils
 import Distribution.System
 import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Types.PackageName.Magic
+import Distribution.Types.ParStrat
 import Distribution.Utils.NubList
 import Distribution.Utils.Path
 import Distribution.Verbosity
@@ -587,7 +588,7 @@ getInstalledPackagesMonitorFiles verbosity platform progdb =
 
 buildLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -598,7 +599,7 @@ buildLib = buildOrReplLib Nothing
 replLib
   :: ReplOptions
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -609,7 +610,7 @@ replLib = buildOrReplLib . Just
 buildOrReplLib
   :: Maybe ReplOptions
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -1173,7 +1174,7 @@ runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_
 -- | Build a foreign library
 buildFLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> ForeignLib
@@ -1184,7 +1185,7 @@ buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib
 replFLib
   :: ReplOptions
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> ForeignLib
@@ -1196,7 +1197,7 @@ replFLib replFlags v njobs pkg lbi =
 -- | Build an executable with GHC.
 buildExe
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Executable
@@ -1207,7 +1208,7 @@ buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe
 replExe
   :: ReplOptions
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Executable
@@ -1526,7 +1527,7 @@ replNoLoad replFlags l
 -- | Generic build function. See comment for 'GBuildMode'.
 gbuild
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> GBuildMode

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -76,9 +76,10 @@ import Distribution.Simple.Utils
 import Distribution.System
 import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Types.PackageName.Magic
+import Distribution.Types.ParStrat
 import Distribution.Utils.NubList
 import Distribution.Utils.Path
-import Distribution.Verbosity
+import Distribution.Verbosity (Verbosity)
 import Distribution.Version
 
 import Control.Monad (msum)
@@ -466,7 +467,7 @@ toJSLibName lib
 
 buildLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -477,7 +478,7 @@ buildLib = buildOrReplLib Nothing
 replLib
   :: [String]
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -488,7 +489,7 @@ replLib = buildOrReplLib . Just
 buildOrReplLib
   :: Maybe [String]
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Library
@@ -889,7 +890,7 @@ startInterpreter verbosity progdb comp platform packageDBs = do
 -- | Build a foreign library
 buildFLib
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> ForeignLib
@@ -900,7 +901,7 @@ buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib
 replFLib
   :: [String]
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> ForeignLib
@@ -912,7 +913,7 @@ replFLib replFlags v njobs pkg lbi =
 -- | Build an executable with GHC.
 buildExe
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Executable
@@ -923,7 +924,7 @@ buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe
 replExe
   :: [String]
   -> Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> Executable
@@ -1218,7 +1219,7 @@ isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]
 -- | Generic build function. See comment for 'GBuildMode'.
 gbuild
   :: Verbosity
-  -> Flag (Maybe Int)
+  -> Flag ParStrat
   -> PackageDescription
   -> LocalBuildInfo
   -> GBuildMode

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

@@ -41,6 +41,7 @@ import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Monoid (All (..), Any (..), Endo (..))
 import qualified Data.Set as Set
+import Distribution.Types.ParStrat
 
 normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
 normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
@@ -513,7 +514,7 @@ data GhcOptions = GhcOptions
   -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag.
   , ghcOptSplitObjs :: Flag Bool
   -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag.
-  , ghcOptNumJobs :: Flag (Maybe Int)
+  , ghcOptNumJobs :: Flag ParStrat
   -- ^ Run N jobs simultaneously (if possible).
   , ghcOptHPCDir :: Flag FilePath
   -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.
@@ -553,6 +554,8 @@ data GhcOptions = GhcOptions
   , ghcOptExtraPath :: NubListR FilePath
   -- ^ Put the extra folders in the PATH environment variable we invoke
   -- GHC with
+  -- | Put the extra folders in the PATH environment variable we invoke
+  -- GHC with
   , ghcOptCabal :: Flag Bool
   -- ^ Let GHC know that it is Cabal that's calling it.
   -- Modifies some of the GHC error messages.
@@ -693,7 +696,12 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
         , if parmakeSupported comp
             then case ghcOptNumJobs opts of
               NoFlag -> []
-              Flag n -> ["-j" ++ maybe "" show n]
+              Flag Serial -> []
+              Flag (UseSem name) ->
+                if jsemSupported comp
+                  then ["-jsem " ++ name]
+                  else []
+              Flag (NumJobs n) -> ["-j" ++ show n]
             else []
         , --------------------
           -- Creating libraries

Cabal/src/Distribution/Simple/Setup.hs

@@ -131,7 +131,6 @@ module Distribution.Simple.Setup
   , trueArg
   , falseArg
   , optionVerbosity
-  , optionNumJobs
   ) where
 
 import Prelude ()

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

@@ -50,6 +50,7 @@ data BuildFlags = BuildFlags
   , buildDistPref :: Flag FilePath
   , buildVerbosity :: Flag Verbosity
   , buildNumJobs :: Flag (Maybe Int)
+  , buildUseSemaphore :: Flag String
   , -- TODO: this one should not be here, it's just that the silly
     -- UserHooks stop us from passing extra info in other ways
     buildArgs :: [String]
@@ -65,6 +66,7 @@ defaultBuildFlags =
     , buildDistPref = mempty
     , buildVerbosity = Flag normal
     , buildNumJobs = mempty
+    , buildUseSemaphore = NoFlag
     , buildArgs = []
     , buildCabalFilePath = mempty
     }
@@ -125,6 +127,13 @@ buildOptions progDb showOrParseArgs =
   [ optionNumJobs
       buildNumJobs
       (\v flags -> flags{buildNumJobs = v})
+  , option
+      []
+      ["semaphore"]
+      "semaphore"
+      buildUseSemaphore
+      (\v flags -> flags{buildUseSemaphore = v})
+      (reqArg' "SEMAPHORE" Flag flagToList)
   ]
     ++ programDbPaths
       progDb

Cabal/src/Distribution/Types/ParStrat.hs

@@ -0,0 +1,24 @@
+module Distribution.Types.ParStrat where
+
+-- | How to control parallelism, e.g. a fixed number of jobs or by using a system semaphore.
+data ParStratX sem
+  = -- | Compile in parallel with the given number of jobs (`-jN` or `-j`).
+    NumJobs (Maybe Int)
+  | -- | `--semaphore`: use a system semaphore to control parallelism.
+    UseSem sem
+  | -- | No parallelism (neither `-jN` nor `--semaphore`, but could be `-j1`).
+    Serial
+  deriving (Show)
+
+-- | Used by Cabal to indicate that we want to use this specific semaphore (created by cabal-install)
+type ParStrat = ParStratX String
+
+-- | Used by cabal-install to say we want to create a semaphore with N slots.
+type ParStratInstall = ParStratX Int
+
+-- | Determine if the parallelism strategy enables parallel builds.
+isParallelBuild :: ParStratX n -> Bool
+isParallelBuild Serial = False
+isParallelBuild (NumJobs (Just 1)) = False
+isParallelBuild (NumJobs _) = True
+isParallelBuild UseSem{} = True