From 0a1c167a742b8e17fcda2a7154138919f2989dc3 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Wed, 19 Oct 2022 13:30:45 +0100
Subject: [PATCH] Add support for using GHC's -jsem option
* The top-level user interface to enable the use of the semaphore is the
`--semaphore` flag. If you pass `-j4 --semaphore` then cabal will
create a semaphore with 4 slots which is passed to ghc using the
`-jsem` option so that all GHC processes coordinate to use 4
capabilities.
- The semaphore logic is provided by a new package `semaphore-compat`
which provides a cross-platform abstraction for semaphores.
* The low level `./Setup.hs build` interface accepts the `--semaphore
<SEMAPHORE>` option, which can be used to directly pass the semaphore
you require to the Setup script.
---
Cabal/Cabal.cabal | 1 +
Cabal/src/Distribution/Simple/Build.hs | 32 ++++-
Cabal/src/Distribution/Simple/Compiler.hs | 9 ++
Cabal/src/Distribution/Simple/GHC.hs | 17 +--
Cabal/src/Distribution/Simple/GHCJS.hs | 19 +--
Cabal/src/Distribution/Simple/Program/GHC.hs | 12 +-
Cabal/src/Distribution/Simple/Setup.hs | 1 -
Cabal/src/Distribution/Simple/Setup/Build.hs | 9 ++
Cabal/src/Distribution/Types/ParStrat.hs | 24 ++++
bootstrap/linux-8.10.7.json | 118 +++++++++++------
bootstrap/linux-9.0.2.json | 118 +++++++++++------
bootstrap/linux-9.2.7.json | 63 ++++++---
bootstrap/linux-9.4.4.json | 79 +++++++----
cabal-install/cabal-install.cabal | 3 +-
.../src/Distribution/Client/Config.hs | 1 +
.../src/Distribution/Client/JobControl.hs | 98 +++++++++++++-
.../Distribution/Client/ProjectBuilding.hs | 124 +++++++++++-------
.../src/Distribution/Client/ProjectConfig.hs | 13 +-
.../Client/ProjectConfig/Legacy.hs | 3 +
.../Client/ProjectConfig/Types.hs | 7 +-
.../Distribution/Client/ProjectPlanning.hs | 9 +-
.../src/Distribution/Client/Setup.hs | 38 +++++-
cabal-install/tests/IntegrationTests2.hs | 3 +-
.../Distribution/Client/ProjectConfig.hs | 7 +-
.../PackageTests/NewBuild/Semaphore/C.hs | 3 +
.../NewBuild/Semaphore/Semaphore.cabal | 22 ++++
.../PackageTests/NewBuild/Semaphore/Setup.hs | 2 +
.../PackageTests/NewBuild/Semaphore/cabal.out | 0
.../NewBuild/Semaphore/cabal.project | 3 +
.../NewBuild/Semaphore/cabal.test.hs | 6 +
.../NewBuild/Semaphore/sub-package-A/A.hs | 1 +
.../NewBuild/Semaphore/sub-package-A/Setup.hs | 2 +
.../sub-package-A/sub-package-A.cabal | 22 ++++
.../NewBuild/Semaphore/sub-package-B/B.hs | 1 +
.../NewBuild/Semaphore/sub-package-B/Setup.hs | 2 +
.../sub-package-B/sub-package-B.cabal | 22 ++++
changelog.d/pr-8557 | 20 +++
changelog.d/pr-8557-2 | 16 +++
doc/cabal-project.rst | 16 +++
39 files changed, 736 insertions(+), 210 deletions(-)
create mode 100644 Cabal/src/Distribution/Types/ParStrat.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/C.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/Semaphore.cabal
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/Setup.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.out
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.project
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.test.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/A.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/Setup.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/sub-package-A.cabal
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/B.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/Setup.hs
create mode 100644 cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/sub-package-B.cabal
create mode 100644 changelog.d/pr-8557
create mode 100644 changelog.d/pr-8557-2
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index 10dafe0050..147d921f0f 100644
--- a/Cabal/Cabal.cabal
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
index 25a0af6db3..636c2c298e 100644
--- a/Cabal/src/Distribution/Simple/Build.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs
index 074f2f38b5..6aaa0931ee 100644
--- a/Cabal/src/Distribution/Simple/Compiler.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
index 656a258ca0..501ae75939 100644
--- a/Cabal/src/Distribution/Simple/GHC.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs
index 6c9bf34f0e..2e99e209c6 100644
--- a/Cabal/src/Distribution/Simple/GHCJS.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs
index 4b821f5680..1f525fd9f3 100644
--- a/Cabal/src/Distribution/Simple/Program/GHC.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs
index b1758d1ee9..b4d55d604b 100644
--- a/Cabal/src/Distribution/Simple/Setup.hs
+++ b/Cabal/src/Distribution/Simple/Setup.hs
@@ -131,7 +131,6 @@ module Distribution.Simple.Setup
, trueArg
, falseArg
, optionVerbosity
- , optionNumJobs
) where
import Prelude ()
diff --git a/Cabal/src/Distribution/Simple/Setup/Build.hs b/Cabal/src/Distribution/Simple/Setup/Build.hs
index 6888853285..434558ca54 100644
--- a/Cabal/src/Distribution/Simple/Setup/Build.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Types/ParStrat.hs b/Cabal/src/Distribution/Types/ParStrat.hs
new file mode 100644
index 0000000000..59d8beb388
--- /dev/null
+++ b/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
diff --git a/bootstrap/linux-8.10.7.json b/bootstrap/linux-8.10.7.json
index 7c753100da..24dc7fcf5e 100644
--- a/bootstrap/linux-8.10.7.json
+++ b/bootstrap/linux-8.10.7.json
@@ -25,28 +25,20 @@
"version": "1.4.4.0"
},
{
- "package": "bytestring",
- "version": "0.10.12.0"
- },
- {
- "package": "containers",
- "version": "0.6.5.1"
- },
- {
- "package": "binary",
- "version": "0.8.8.0"
+ "package": "ghc-boot-th",
+ "version": "8.10.7"
},
{
- "package": "filepath",
- "version": "1.4.2.1"
+ "package": "pretty",
+ "version": "1.1.3.6"
},
{
- "package": "time",
- "version": "1.9.3"
+ "package": "template-haskell",
+ "version": "2.16.0.0"
},
{
- "package": "unix",
- "version": "2.7.2.2"
+ "package": "containers",
+ "version": "0.6.5.1"
},
{
"package": "transformers",
@@ -57,43 +49,86 @@
"version": "2.2.2"
},
{
- "package": "ghc-boot-th",
- "version": "8.10.7"
+ "package": "stm",
+ "version": "2.5.0.1"
},
{
- "package": "pretty",
- "version": "1.1.3.6"
+ "package": "exceptions",
+ "version": "0.10.4"
},
{
- "package": "template-haskell",
- "version": "2.16.0.0"
- },
+ "package": "time",
+ "version": "1.9.3"
+ }
+ ],
+ "dependencies": [
{
- "package": "text",
- "version": "1.2.4.1"
+ "cabal_sha256": "55390b63bbd7846aab6b16b7b255cf5108a3a422798a1e9a3b674eb0c68ac20c",
+ "flags": [],
+ "package": "bytestring",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "491aaef7625c693a06c26ae7f097caf23d9e3f9cae14af5ab17e71abb39576d3",
+ "version": "0.11.4.0"
},
{
- "package": "parsec",
- "version": "3.1.14.0"
+ "cabal_sha256": "81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801",
+ "flags": [],
+ "package": "binary",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ac21ca63452dfc9b0bcab87c57699c531d87f7a9bcb6230ca46fba1b7faeebc0",
+ "version": "0.8.9.1"
},
{
- "package": "stm",
- "version": "2.5.0.1"
+ "cabal_sha256": "ab6e3330c42817b0effb14cae9c60d5cdc41d61f7354d04bc529ed031113f27c",
+ "flags": [
+ "-cpphs"
+ ],
+ "package": "filepath",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ed1d11173f5052461cd1df58b5ef4abbfa1803ad2b237da7ddb7c7d64e017de2",
+ "version": "1.4.100.3"
},
{
- "package": "exceptions",
- "version": "0.10.4"
- }
- ],
- "dependencies": [
+ "cabal_sha256": "26eeda14432a2fcc6049045068ecf59525ffff9196616a642b5ab2326a003692",
+ "flags": [],
+ "package": "unix",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "5e59d9ca0f8e505d2203af7dba17c67275621fbcd4ed8fcbdd59e80df4d79a7d",
+ "version": "2.8.1.0"
+ },
{
- "cabal_sha256": "1125a0a4be3aafc8da208940f219d4e4df8a0db87d892cc42bb369071855c590",
+ "cabal_sha256": "e384a4831b0ac0f8908a1d99d14ce44bf9c5fe2092eec5b2c47ea072d477a493",
"flags": [],
"package": "directory",
"revision": 0,
"source": "hackage",
- "src_sha256": "dc2785d6548cec2e80700fab007d3e9467f65d3c58ab3efa21b34d9017cf0efd",
- "version": "1.3.7.1"
+ "src_sha256": "bd8253197587d32d4553070d2de89d3817176860932b0e9ab7bb7ba3759d8e9c",
+ "version": "1.3.8.1"
+ },
+ {
+ "cabal_sha256": "d495b2a2a53da7e66163477a5837d2109074f8818fc938739b9ecf27d506050a",
+ "flags": [
+ "-developer",
+ "+simdutf"
+ ],
+ "package": "text",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "c735be650a898606ce9f2c8642bc6ac6123eea82871d5e90f92797801f59efad",
+ "version": "2.0.2"
+ },
+ {
+ "cabal_sha256": "5769242043b01bf759b07b7efedcb19607837ee79015fcddde34645664136aed",
+ "flags": [],
+ "package": "parsec",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "a41962e5d76ea68658876735b8d5b755e0eff336b079d0a2f439c364755d1246",
+ "version": "3.1.16.1"
},
{
"cabal_sha256": null,
@@ -393,6 +428,15 @@
"src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf",
"version": "0.1.7.3"
},
+ {
+ "cabal_sha256": "868694b09361e7c6756542bcdcfba68a9b8b93410c6798709e475abd3751afe7",
+ "flags": [],
+ "package": "semaphore-compat",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "1c6e6fab021c2ccee5d86112fb1c0bd016d15e0cf70c489dae5fb5ec156ed9e2",
+ "version": "1.0.0"
+ },
{
"cabal_sha256": null,
"flags": [
diff --git a/bootstrap/linux-9.0.2.json b/bootstrap/linux-9.0.2.json
index 1c28ff534e..5700325f05 100644
--- a/bootstrap/linux-9.0.2.json
+++ b/bootstrap/linux-9.0.2.json
@@ -25,28 +25,20 @@
"version": "1.4.5.0"
},
{
- "package": "bytestring",
- "version": "0.10.12.1"
- },
- {
- "package": "containers",
- "version": "0.6.4.1"
- },
- {
- "package": "binary",
- "version": "0.8.8.0"
+ "package": "ghc-boot-th",
+ "version": "9.0.2"
},
{
- "package": "filepath",
- "version": "1.4.2.1"
+ "package": "pretty",
+ "version": "1.1.3.6"
},
{
- "package": "time",
- "version": "1.9.3"
+ "package": "template-haskell",
+ "version": "2.17.0.0"
},
{
- "package": "unix",
- "version": "2.7.2.2"
+ "package": "containers",
+ "version": "0.6.4.1"
},
{
"package": "transformers",
@@ -57,43 +49,86 @@
"version": "2.2.2"
},
{
- "package": "ghc-boot-th",
- "version": "9.0.2"
+ "package": "stm",
+ "version": "2.5.0.0"
},
{
- "package": "pretty",
- "version": "1.1.3.6"
+ "package": "exceptions",
+ "version": "0.10.4"
},
{
- "package": "template-haskell",
- "version": "2.17.0.0"
- },
+ "package": "time",
+ "version": "1.9.3"
+ }
+ ],
+ "dependencies": [
{
- "package": "text",
- "version": "1.2.5.0"
+ "cabal_sha256": "55390b63bbd7846aab6b16b7b255cf5108a3a422798a1e9a3b674eb0c68ac20c",
+ "flags": [],
+ "package": "bytestring",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "491aaef7625c693a06c26ae7f097caf23d9e3f9cae14af5ab17e71abb39576d3",
+ "version": "0.11.4.0"
},
{
- "package": "parsec",
- "version": "3.1.14.0"
+ "cabal_sha256": "81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801",
+ "flags": [],
+ "package": "binary",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ac21ca63452dfc9b0bcab87c57699c531d87f7a9bcb6230ca46fba1b7faeebc0",
+ "version": "0.8.9.1"
},
{
- "package": "stm",
- "version": "2.5.0.0"
+ "cabal_sha256": "ab6e3330c42817b0effb14cae9c60d5cdc41d61f7354d04bc529ed031113f27c",
+ "flags": [
+ "-cpphs"
+ ],
+ "package": "filepath",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ed1d11173f5052461cd1df58b5ef4abbfa1803ad2b237da7ddb7c7d64e017de2",
+ "version": "1.4.100.3"
},
{
- "package": "exceptions",
- "version": "0.10.4"
- }
- ],
- "dependencies": [
+ "cabal_sha256": "26eeda14432a2fcc6049045068ecf59525ffff9196616a642b5ab2326a003692",
+ "flags": [],
+ "package": "unix",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "5e59d9ca0f8e505d2203af7dba17c67275621fbcd4ed8fcbdd59e80df4d79a7d",
+ "version": "2.8.1.0"
+ },
{
- "cabal_sha256": "1125a0a4be3aafc8da208940f219d4e4df8a0db87d892cc42bb369071855c590",
+ "cabal_sha256": "e384a4831b0ac0f8908a1d99d14ce44bf9c5fe2092eec5b2c47ea072d477a493",
"flags": [],
"package": "directory",
"revision": 0,
"source": "hackage",
- "src_sha256": "dc2785d6548cec2e80700fab007d3e9467f65d3c58ab3efa21b34d9017cf0efd",
- "version": "1.3.7.1"
+ "src_sha256": "bd8253197587d32d4553070d2de89d3817176860932b0e9ab7bb7ba3759d8e9c",
+ "version": "1.3.8.1"
+ },
+ {
+ "cabal_sha256": "d495b2a2a53da7e66163477a5837d2109074f8818fc938739b9ecf27d506050a",
+ "flags": [
+ "-developer",
+ "+simdutf"
+ ],
+ "package": "text",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "c735be650a898606ce9f2c8642bc6ac6123eea82871d5e90f92797801f59efad",
+ "version": "2.0.2"
+ },
+ {
+ "cabal_sha256": "5769242043b01bf759b07b7efedcb19607837ee79015fcddde34645664136aed",
+ "flags": [],
+ "package": "parsec",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "a41962e5d76ea68658876735b8d5b755e0eff336b079d0a2f439c364755d1246",
+ "version": "3.1.16.1"
},
{
"cabal_sha256": null,
@@ -393,6 +428,15 @@
"src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf",
"version": "0.1.7.3"
},
+ {
+ "cabal_sha256": "868694b09361e7c6756542bcdcfba68a9b8b93410c6798709e475abd3751afe7",
+ "flags": [],
+ "package": "semaphore-compat",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "1c6e6fab021c2ccee5d86112fb1c0bd016d15e0cf70c489dae5fb5ec156ed9e2",
+ "version": "1.0.0"
+ },
{
"cabal_sha256": null,
"flags": [
diff --git a/bootstrap/linux-9.2.7.json b/bootstrap/linux-9.2.7.json
index ad75816daf..3b8fda58d6 100644
--- a/bootstrap/linux-9.2.7.json
+++ b/bootstrap/linux-9.2.7.json
@@ -49,24 +49,24 @@
"version": "0.8.9.0"
},
{
- "package": "filepath",
- "version": "1.4.2.2"
+ "package": "transformers",
+ "version": "0.5.6.2"
},
{
- "package": "time",
- "version": "1.11.1.1"
+ "package": "mtl",
+ "version": "2.2.2"
},
{
- "package": "unix",
- "version": "2.7.2.2"
+ "package": "stm",
+ "version": "2.5.0.2"
},
{
- "package": "transformers",
- "version": "0.5.6.2"
+ "package": "exceptions",
+ "version": "0.10.4"
},
{
- "package": "mtl",
- "version": "2.2.2"
+ "package": "time",
+ "version": "1.11.1.1"
},
{
"package": "text",
@@ -75,25 +75,37 @@
{
"package": "parsec",
"version": "3.1.15.0"
- },
- {
- "package": "stm",
- "version": "2.5.0.2"
- },
- {
- "package": "exceptions",
- "version": "0.10.4"
}
],
"dependencies": [
{
- "cabal_sha256": "1125a0a4be3aafc8da208940f219d4e4df8a0db87d892cc42bb369071855c590",
+ "cabal_sha256": "ab6e3330c42817b0effb14cae9c60d5cdc41d61f7354d04bc529ed031113f27c",
+ "flags": [
+ "-cpphs"
+ ],
+ "package": "filepath",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ed1d11173f5052461cd1df58b5ef4abbfa1803ad2b237da7ddb7c7d64e017de2",
+ "version": "1.4.100.3"
+ },
+ {
+ "cabal_sha256": "26eeda14432a2fcc6049045068ecf59525ffff9196616a642b5ab2326a003692",
+ "flags": [],
+ "package": "unix",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "5e59d9ca0f8e505d2203af7dba17c67275621fbcd4ed8fcbdd59e80df4d79a7d",
+ "version": "2.8.1.0"
+ },
+ {
+ "cabal_sha256": "e384a4831b0ac0f8908a1d99d14ce44bf9c5fe2092eec5b2c47ea072d477a493",
"flags": [],
"package": "directory",
"revision": 0,
"source": "hackage",
- "src_sha256": "dc2785d6548cec2e80700fab007d3e9467f65d3c58ab3efa21b34d9017cf0efd",
- "version": "1.3.7.1"
+ "src_sha256": "bd8253197587d32d4553070d2de89d3817176860932b0e9ab7bb7ba3759d8e9c",
+ "version": "1.3.8.1"
},
{
"cabal_sha256": null,
@@ -384,6 +396,15 @@
"src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf",
"version": "0.1.7.3"
},
+ {
+ "cabal_sha256": "868694b09361e7c6756542bcdcfba68a9b8b93410c6798709e475abd3751afe7",
+ "flags": [],
+ "package": "semaphore-compat",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "1c6e6fab021c2ccee5d86112fb1c0bd016d15e0cf70c489dae5fb5ec156ed9e2",
+ "version": "1.0.0"
+ },
{
"cabal_sha256": null,
"flags": [
diff --git a/bootstrap/linux-9.4.4.json b/bootstrap/linux-9.4.4.json
index 98382c20a5..bcb80b9104 100644
--- a/bootstrap/linux-9.4.4.json
+++ b/bootstrap/linux-9.4.4.json
@@ -49,28 +49,24 @@
"version": "0.8.9.1"
},
{
- "package": "filepath",
- "version": "1.4.2.2"
- },
- {
- "package": "time",
- "version": "1.12.2"
+ "package": "transformers",
+ "version": "0.5.6.2"
},
{
- "package": "unix",
- "version": "2.7.3"
+ "package": "mtl",
+ "version": "2.2.2"
},
{
- "package": "directory",
- "version": "1.3.7.1"
+ "package": "stm",
+ "version": "2.5.1.0"
},
{
- "package": "transformers",
- "version": "0.5.6.2"
+ "package": "exceptions",
+ "version": "0.10.5"
},
{
- "package": "mtl",
- "version": "2.2.2"
+ "package": "time",
+ "version": "1.12.2"
},
{
"package": "text",
@@ -79,21 +75,38 @@
{
"package": "parsec",
"version": "3.1.15.0"
- },
+ }
+ ],
+ "dependencies": [
{
- "package": "process",
- "version": "1.6.16.0"
+ "cabal_sha256": "ab6e3330c42817b0effb14cae9c60d5cdc41d61f7354d04bc529ed031113f27c",
+ "flags": [
+ "-cpphs"
+ ],
+ "package": "filepath",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "ed1d11173f5052461cd1df58b5ef4abbfa1803ad2b237da7ddb7c7d64e017de2",
+ "version": "1.4.100.3"
},
{
- "package": "stm",
- "version": "2.5.1.0"
+ "cabal_sha256": "26eeda14432a2fcc6049045068ecf59525ffff9196616a642b5ab2326a003692",
+ "flags": [],
+ "package": "unix",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "5e59d9ca0f8e505d2203af7dba17c67275621fbcd4ed8fcbdd59e80df4d79a7d",
+ "version": "2.8.1.0"
},
{
- "package": "exceptions",
- "version": "0.10.5"
- }
- ],
- "dependencies": [
+ "cabal_sha256": "e384a4831b0ac0f8908a1d99d14ce44bf9c5fe2092eec5b2c47ea072d477a493",
+ "flags": [],
+ "package": "directory",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "bd8253197587d32d4553070d2de89d3817176860932b0e9ab7bb7ba3759d8e9c",
+ "version": "1.3.8.1"
+ },
{
"cabal_sha256": null,
"flags": [],
@@ -103,6 +116,15 @@
"src_sha256": null,
"version": "3.11.0.0"
},
+ {
+ "cabal_sha256": "49d8a7f372d35363011591b253cae4c8db8b9ec594590448e20b7bed7acaee98",
+ "flags": [],
+ "package": "process",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "4c5c454e0f5c864c79b9fabd850307b26d8ac4037e45a6a39ab87e20b583bf06",
+ "version": "1.6.17.0"
+ },
{
"cabal_sha256": null,
"flags": [],
@@ -365,6 +387,15 @@
"src_sha256": "91ce28d8f8a6efd31788d4827ed5cdcb9a546ad4053a86c56f7947c66a30b5bf",
"version": "0.1.7.3"
},
+ {
+ "cabal_sha256": "868694b09361e7c6756542bcdcfba68a9b8b93410c6798709e475abd3751afe7",
+ "flags": [],
+ "package": "semaphore-compat",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "1c6e6fab021c2ccee5d86112fb1c0bd016d15e0cf70c489dae5fb5ec156ed9e2",
+ "version": "1.0.0"
+ },
{
"cabal_sha256": null,
"flags": [
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 1374c495e8..d20db6ced5 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -232,7 +232,8 @@ library
parsec >= 3.1.13.0 && < 3.2,
regex-base >= 0.94.0.0 && <0.95,
regex-posix >= 0.96.0.0 && <0.97,
- safe-exceptions >= 0.1.7.0 && < 0.2
+ safe-exceptions >= 0.1.7.0 && < 0.2,
+ semaphore-compat >= 1.0.0 && < 1.1
if flag(native-dns)
if os(windows)
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
index 4b3853aa89..24c6c6a29f 100644
--- a/cabal-install/src/Distribution/Client/Config.hs
+++ b/cabal-install/src/Distribution/Client/Config.hs
@@ -434,6 +434,7 @@ instance Semigroup SavedConfig where
, installSymlinkBinDir = combine installSymlinkBinDir
, installPerComponent = combine installPerComponent
, installNumJobs = combine installNumJobs
+ , installUseSemaphore = combine installUseSemaphore
, installKeepGoing = combine installKeepGoing
, installRunTests = combine installRunTests
, installOfflineMode = combine installOfflineMode
diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs
index d45efe3c8b..ec14847851 100644
--- a/cabal-install/src/Distribution/Client/JobControl.hs
+++ b/cabal-install/src/Distribution/Client/JobControl.hs
@@ -18,10 +18,13 @@ module Distribution.Client.JobControl
( JobControl
, newSerialJobControl
, newParallelJobControl
+ , newSemaphoreJobControl
, spawnJob
, collectJob
, remainingJobs
, cancelJobs
+ , cleanupJobControl
+ , jobControlSemaphore
, JobLimit
, newJobLimit
, withJobLimit
@@ -33,15 +36,17 @@ module Distribution.Client.JobControl
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, forkIOWithUnmask, threadDelay)
import Control.Concurrent.MVar
-import Control.Concurrent.STM (STM, atomically)
+import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar)
import Control.Concurrent.STM.TChan
-import Control.Concurrent.STM.TVar
-import Control.Exception (bracket_, try)
+import Control.Exception (bracket_, mask_, try)
import Control.Monad (forever, replicateM_)
import Distribution.Client.Compat.Semaphore
import Distribution.Compat.Stack
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+import System.Semaphore
-- | A simple concurrency abstraction. Jobs can be spawned and can complete
-- in any order. This allows both serial and parallel implementations.
@@ -57,6 +62,12 @@ data JobControl m a = JobControl
-- ^ Try to cancel any outstanding but not-yet-started jobs.
-- Call 'remainingJobs' after this to find out if any jobs are left
-- (ie could not be cancelled).
+ , cleanupJobControl :: m ()
+ -- ^ cleanup any resources created by the JobControl, intended to be used
+ -- as the finaliser for `bracket`.
+ , jobControlSemaphore :: Maybe SemaphoreName
+ -- ^ Name of the semaphore which can be used to control parallelism, if one
+ -- is available for that job control type.
}
-- | Make a 'JobControl' that executes all jobs serially and in order.
@@ -72,6 +83,8 @@ newSerialJobControl = do
, collectJob = collect qVar
, remainingJobs = remaining qVar
, cancelJobs = cancel qVar
+ , cleanupJobControl = return ()
+ , jobControlSemaphore = Nothing
}
where
spawn :: TChan (IO a) -> IO a -> IO ()
@@ -112,6 +125,8 @@ newParallelJobControl maxJobLimit = do
, collectJob = collect outqVar countVar
, remainingJobs = remaining countVar
, cancelJobs = cancel inqVar countVar
+ , cleanupJobControl = return ()
+ , jobControlSemaphore = Nothing
}
where
worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO ()
@@ -152,6 +167,81 @@ readAllTChan qvar = go []
Nothing -> return (reverse xs)
Just x -> go (x : xs)
+-- | Make a 'JobControl' where the parallism is controlled by a semaphore.
+--
+-- This uses the GHC -jsem option to allow GHC to take additional semaphore slots
+-- if we are not using them all.
+newSemaphoreJobControl :: WithCallStack (Int -> IO (JobControl IO a))
+newSemaphoreJobControl n
+ | n < 1 || n > 1000 =
+ error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n
+newSemaphoreJobControl maxJobLimit = do
+ sem <- freshSemaphore "cabal_semaphore" maxJobLimit
+ notice normal $
+ "Created semaphore called "
+ ++ getSemaphoreName (semaphoreName sem)
+ ++ " with "
+ ++ show maxJobLimit
+ ++ " slots."
+ outqVar <- newTChanIO
+ inqVar <- newTChanIO
+ countVar <- newTVarIO 0
+ void (forkIO (worker sem inqVar outqVar))
+ return
+ JobControl
+ { spawnJob = spawn inqVar countVar
+ , collectJob = collect outqVar countVar
+ , remainingJobs = remaining countVar
+ , cancelJobs = cancel inqVar countVar
+ , cleanupJobControl = destroySemaphore sem
+ , jobControlSemaphore = Just (semaphoreName sem)
+ }
+ where
+ worker :: Semaphore -> TChan (IO a) -> TChan (Either SomeException a) -> IO ()
+ worker sem inqVar outqVar =
+ forever $ do
+ job <- atomically $ readTChan inqVar
+ -- mask here, as we need to ensure that the thread which contains the
+ -- release action is spawned. Otherwise, there is the chance that an
+ -- async exception is thrown between the semaphore being taken and the
+ -- thread being spawned.
+ mask_ $ do
+ waitOnSemaphore sem
+ void $ forkIOWithUnmask $ \unmask -> do
+ res <- try (unmask job)
+ releaseSemaphore sem 1
+ atomically $ writeTChan outqVar res
+ -- Try to give GHC enough time to compute the module graph and then
+ -- request some additional capabilities if it can make use of them. The
+ -- ideal situation is that we have 1 GHC process running which has taken
+ -- all the capabilities in the semaphore, as this will reduce memory usage.
+ --
+ -- 0.25s is chosen by discussion between MP and SD on Mar 17th 2023 as a number
+ -- which isn't too big and not too small but also, not scientifically.
+ threadDelay 250000
+
+ spawn :: TChan (IO a) -> TVar Int -> IO a -> IO ()
+ spawn inqVar countVar job =
+ atomically $ do
+ modifyTVar' countVar (+ 1)
+ writeTChan inqVar job
+
+ collect :: TChan (Either SomeException a) -> TVar Int -> IO a
+ collect outqVar countVar = do
+ res <- atomically $ do
+ modifyTVar' countVar (subtract 1)
+ readTChan outqVar
+ either throwIO return res
+
+ remaining :: TVar Int -> IO Bool
+ remaining countVar = fmap (/= 0) $ atomically $ readTVar countVar
+
+ cancel :: TChan (IO a) -> TVar Int -> IO ()
+ cancel inqVar countVar =
+ atomically $ do
+ xs <- readAllTChan inqVar
+ modifyTVar' countVar (subtract (length xs))
+
-------------------------
-- Job limits and locks
--
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index f915af1271..a47cad5203 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -47,6 +47,7 @@ import Prelude ()
import Distribution.Client.PackageHash (renderPackageHashInputs)
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.RebuildMonad
@@ -82,6 +83,7 @@ import Distribution.Client.Types hiding
import Distribution.Client.Utils
( ProgressPhase (..)
, findOpenProgramLocation
+ , numberOfProcessors
, progressMessage
, removeExistingFile
)
@@ -97,6 +99,7 @@ import Distribution.Simple.Compiler
( Compiler
, PackageDB (..)
, compilerId
+ , jsemSupported
)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
@@ -122,10 +125,11 @@ import qualified Data.Set as Set
import qualified Text.PrettyPrint as Disp
-import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
+import Control.Exception (Handler (..), SomeAsyncException, assert, bracket, catches, handle)
import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
import System.IO (Handle, IOMode (AppendMode), withFile)
+import System.Semaphore (SemaphoreName (..))
import Distribution.Compat.Directory (listDirectory)
import Distribution.Simple.Flag (fromFlagOrDefault)
@@ -652,57 +656,64 @@ rebuildTargets
| otherwise = do
-- Concurrency control: create the job controller and concurrency limits
-- for downloading, building and installing.
- jobControl <-
- if isParallelBuild
- then newParallelJobControl buildSettingNumJobs
- else newSerialJobControl
+ mkJobControl <- case buildSettingNumJobs of
+ Serial -> newSerialJobControl
+ NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n)
+ UseSem n ->
+ if jsemSupported compiler
+ then newSemaphoreJobControl n
+ else do
+ warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
+ newParallelJobControl n
registerLock <- newLock -- serialise registration
cacheLock <- newLock -- serialise access to setup exe cache
-- TODO: [code cleanup] eliminate setup exe cache
- debug verbosity $
+ info verbosity $
"Executing install plan "
- ++ if isParallelBuild
- then " in parallel using " ++ show buildSettingNumJobs ++ " threads."
- else " serially."
+ ++ case buildSettingNumJobs of
+ NumJobs n -> " in parallel using " ++ show n ++ " threads."
+ UseSem n -> " in parallel using a semaphore with " ++ show n ++ " slots."
+ Serial -> " serially."
createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
createDirectoryIfMissingVerbose verbosity True distTempDirectory
traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
- -- Before traversing the install plan, preemptively find all packages that
- -- will need to be downloaded and start downloading them.
- asyncDownloadPackages
- verbosity
- withRepoCtx
- installPlan
- pkgsBuildStatus
- $ \downloadMap ->
- -- For each package in the plan, in dependency order, but in parallel...
- InstallPlan.execute
- jobControl
- keepGoing
- (BuildFailure Nothing . DependentFailed . packageId)
- installPlan
- $ \pkg ->
- -- TODO: review exception handling
- handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do
- let uid = installedUnitId pkg
- pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
-
- rebuildTarget
- verbosity
- distDirLayout
- storeDirLayout
- buildSettings
- downloadMap
- registerLock
- cacheLock
- sharedPackageConfig
- installPlan
- pkg
- pkgBuildStatus
+ bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do
+ -- Before traversing the install plan, preemptively find all packages that
+ -- will need to be downloaded and start downloading them.
+ asyncDownloadPackages
+ verbosity
+ withRepoCtx
+ installPlan
+ pkgsBuildStatus
+ $ \downloadMap ->
+ -- For each package in the plan, in dependency order, but in parallel...
+ InstallPlan.execute
+ mkJobControl
+ keepGoing
+ (BuildFailure Nothing . DependentFailed . packageId)
+ installPlan
+ $ \pkg ->
+ -- TODO: review exception handling
+ handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do
+ let uid = installedUnitId pkg
+ pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
+
+ rebuildTarget
+ verbosity
+ distDirLayout
+ storeDirLayout
+ (jobControlSemaphore jobControl)
+ buildSettings
+ downloadMap
+ registerLock
+ cacheLock
+ sharedPackageConfig
+ installPlan
+ pkg
+ pkgBuildStatus
where
- isParallelBuild = buildSettingNumJobs >= 2
keepGoing = buildSettingKeepGoing
withRepoCtx =
projectConfigWithBuilderRepoContext
@@ -780,6 +791,7 @@ rebuildTarget
:: Verbosity
-> DistDirLayout
-> StoreDirLayout
+ -> Maybe SemaphoreName
-> BuildTimeSettings
-> AsyncFetchMap
-> Lock
@@ -793,6 +805,7 @@ rebuildTarget
verbosity
distDirLayout@DistDirLayout{distBuildDirectory}
storeDirLayout
+ semaphoreName
buildSettings
downloadMap
registerLock
@@ -876,6 +889,7 @@ rebuildTarget
verbosity
distDirLayout
storeDirLayout
+ semaphoreName
buildSettings
registerLock
cacheLock
@@ -894,6 +908,7 @@ rebuildTarget
buildInplaceUnpackedPackage
verbosity
distDirLayout
+ semaphoreName
buildSettings
registerLock
cacheLock
@@ -1124,6 +1139,10 @@ buildAndInstallUnpackedPackage
:: Verbosity
-> DistDirLayout
-> StoreDirLayout
+ -> Maybe SemaphoreName
+ -- ^ Whether to pass a semaphore to build process
+ -- this is different to BuildTimeSettings because the
+ -- name of the semaphore is created freshly each time.
-> BuildTimeSettings
-> Lock
-> Lock
@@ -1139,6 +1158,7 @@ buildAndInstallUnpackedPackage
storeDirLayout@StoreDirLayout
{ storePackageDBStack
}
+ maybe_semaphore
BuildTimeSettings
{ buildSettingNumJobs
, buildSettingLogFile
@@ -1324,11 +1344,9 @@ buildAndInstallUnpackedPackage
noticeProgress :: ProgressPhase -> IO ()
noticeProgress phase =
- when isParallelBuild $
+ when (isParallelBuild buildSettingNumJobs) $
progressMessage verbosity phase dispname
- isParallelBuild = buildSettingNumJobs >= 2
-
whenHaddock action
| hasValidHaddockTargets pkg = action
| otherwise = return ()
@@ -1344,7 +1362,10 @@ buildAndInstallUnpackedPackage
configureArgs _ = setupHsConfigureArgs pkg
buildCommand = Cabal.buildCommand defaultProgramDb
- buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir
+ comp_par_strat = case maybe_semaphore of
+ Just sem_name -> Cabal.Flag (getSemaphoreName sem_name)
+ _ -> Cabal.NoFlag
+ buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir
haddockCommand = Cabal.haddockCommand
haddockFlags _ =
@@ -1385,7 +1406,7 @@ buildAndInstallUnpackedPackage
distDirLayout
srcdir
builddir
- isParallelBuild
+ (isParallelBuild buildSettingNumJobs)
cacheLock
setup :: CommandUI flags -> (Version -> flags) -> IO ()
@@ -1461,6 +1482,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..}
buildInplaceUnpackedPackage
:: Verbosity
-> DistDirLayout
+ -> Maybe SemaphoreName
-> BuildTimeSettings
-> Lock
-> Lock
@@ -1479,6 +1501,7 @@ buildInplaceUnpackedPackage
, distDirectory
, distHaddockOutputDir
}
+ maybe_semaphore
BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}
registerLock
cacheLock
@@ -1641,7 +1664,9 @@ buildInplaceUnpackedPackage
ipkgid = installedUnitId pkg
dparams = elabDistDirParams pkgshared pkg
- isParallelBuild = buildSettingNumJobs >= 2
+ comp_par_strat = case maybe_semaphore of
+ Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name)
+ _ -> Cabal.NoFlag
packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
@@ -1697,6 +1722,7 @@ buildInplaceUnpackedPackage
buildCommand = Cabal.buildCommand defaultProgramDb
buildFlags _ =
setupHsBuildFlags
+ comp_par_strat
pkg
pkgshared
verbosity
@@ -1751,7 +1777,7 @@ buildInplaceUnpackedPackage
distDirLayout
srcdir
builddir
- isParallelBuild
+ (isParallelBuild buildSettingNumJobs)
cacheLock
setupInteractive
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index 2a0f82215c..4470d4fbfc 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -394,7 +394,12 @@ resolveBuildTimeSettings
-- buildSettingLogVerbosity -- defined below, more complicated
buildSettingBuildReports = fromFlag projectConfigBuildReports
buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
- buildSettingNumJobs = determineNumJobs projectConfigNumJobs
+ buildSettingNumJobs =
+ if fromFlag projectConfigUseSemaphore
+ then UseSem (determineNumJobs projectConfigNumJobs)
+ else case (determineNumJobs projectConfigNumJobs) of
+ 1 -> Serial
+ n -> NumJobs (Just n)
buildSettingKeepGoing = fromFlag projectConfigKeepGoing
buildSettingOfflineMode = fromFlag projectConfigOfflineMode
buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
@@ -455,11 +460,9 @@ resolveBuildTimeSettings
useDefaultTemplate
| buildSettingBuildReports == DetailedReports = True
| isJust givenTemplate = False
- | isParallelBuild = True
+ | isParallelBuild buildSettingNumJobs = True
| otherwise = False
- isParallelBuild = buildSettingNumJobs >= 2
-
substLogFileName
:: PathTemplate
-> Compiler
@@ -489,7 +492,7 @@ resolveBuildTimeSettings
overrideVerbosity
| buildSettingBuildReports == DetailedReports = True
| isJust givenTemplate = True
- | isParallelBuild = False
+ | isParallelBuild buildSettingNumJobs = False
| otherwise = False
---------------------------------------------
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
index cf39d2940e..7814d6ef0c 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -819,6 +819,7 @@ convertLegacyBuildOnlyFlags
, installReportPlanningFailure = projectConfigReportPlanningFailure
, installSymlinkBinDir = projectConfigSymlinkBinDir
, installNumJobs = projectConfigNumJobs
+ , installUseSemaphore = projectConfigUseSemaphore
, installKeepGoing = projectConfigKeepGoing
, installOfflineMode = projectConfigOfflineMode
} = installFlags
@@ -950,6 +951,7 @@ convertToLegacySharedConfig
, installSymlinkBinDir = projectConfigSymlinkBinDir
, installPerComponent = projectConfigPerComponent
, installNumJobs = projectConfigNumJobs
+ , installUseSemaphore = projectConfigUseSemaphore
, installKeepGoing = projectConfigKeepGoing
, installRunTests = mempty
, installOfflineMode = projectConfigOfflineMode
@@ -1385,6 +1387,7 @@ legacySharedConfigFieldDescrs constraintSrc =
, "remote-build-reporting"
, "report-planning-failure"
, "jobs"
+ , "semaphore"
, "keep-going"
, "offline"
, "per-component"
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
index 3ae80d86d3..744a50ddc3 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -14,6 +14,9 @@ module Distribution.Client.ProjectConfig.Types
-- * Resolving configuration
, SolverSettings (..)
, BuildTimeSettings (..)
+ , ParStratX (..)
+ , isParallelBuild
+ , ParStrat
-- * Extra useful Monoids
, MapLast (..)
@@ -91,6 +94,7 @@ import Distribution.Version
)
import qualified Data.Map as Map
+import Distribution.Types.ParStrat
-------------------------------
-- Project config types
@@ -157,6 +161,7 @@ data ProjectConfigBuildOnly = ProjectConfigBuildOnly
, projectConfigReportPlanningFailure :: Flag Bool
, projectConfigSymlinkBinDir :: Flag FilePath
, projectConfigNumJobs :: Flag (Maybe Int)
+ , projectConfigUseSemaphore :: Flag Bool
, projectConfigKeepGoing :: Flag Bool
, projectConfigOfflineMode :: Flag Bool
, projectConfigKeepTempFiles :: Flag Bool
@@ -454,7 +459,7 @@ data BuildTimeSettings = BuildTimeSettings
, buildSettingBuildReports :: ReportLevel
, buildSettingReportPlanningFailure :: Bool
, buildSettingSymlinkBinDir :: [FilePath]
- , buildSettingNumJobs :: Int
+ , buildSettingNumJobs :: ParStratInstall
, buildSettingKeepGoing :: Bool
, buildSettingOfflineMode :: Bool
, buildSettingKeepTempFiles :: Bool
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
index 28066513de..10bf7c18cc 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -4280,18 +4280,23 @@ setupHsConfigureArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabCompo
(compComponentName comp)
setupHsBuildFlags
- :: ElaboratedConfiguredPackage
+ :: Flag String
+ -> ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> Cabal.BuildFlags
-setupHsBuildFlags _ _ verbosity builddir =
+setupHsBuildFlags par_strat elab _ verbosity builddir =
Cabal.BuildFlags
{ buildProgramPaths = mempty -- unused, set at configure time
, buildProgramArgs = mempty -- unused, set at configure time
, buildVerbosity = toFlag verbosity
, buildDistPref = toFlag builddir
, buildNumJobs = mempty -- TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),
+ , buildUseSemaphore =
+ if elabSetupScriptCliVersion elab >= mkVersion [3, 9, 0, 0]
+ then par_strat
+ else mempty
, buildArgs = mempty -- unused, passed via args not flags
, buildCabalFilePath = mempty
}
diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
index 4cd7b207f7..680d4175c0 100644
--- a/cabal-install/src/Distribution/Client/Setup.hs
+++ b/cabal-install/src/Distribution/Client/Setup.hs
@@ -191,7 +191,6 @@ import Distribution.Simple.Setup
, boolOpt
, boolOpt'
, falseArg
- , optionNumJobs
, optionVerbosity
, readPackageDbList
, showPackageDbList
@@ -2074,6 +2073,7 @@ data InstallFlags = InstallFlags
installSymlinkBinDir :: Flag FilePath
, installPerComponent :: Flag Bool
, installNumJobs :: Flag (Maybe Int)
+ , installUseSemaphore :: Flag Bool
, installKeepGoing :: Flag Bool
, installRunTests :: Flag Bool
, installOfflineMode :: Flag Bool
@@ -2116,6 +2116,7 @@ defaultInstallFlags =
, installSymlinkBinDir = mempty
, installPerComponent = Flag True
, installNumJobs = mempty
+ , installUseSemaphore = Flag False
, installKeepGoing = Flag False
, installRunTests = mempty
, installOfflineMode = Flag False
@@ -2577,6 +2578,13 @@ installOptions showOrParseArgs =
installRunTests
(\v flags -> flags{installRunTests = v})
trueArg
+ , option
+ []
+ ["semaphore"]
+ "Use a semaphore so GHC can compile components in parallel"
+ installUseSemaphore
+ (\v flags -> flags{installUseSemaphore = v})
+ (yesNoOpt showOrParseArgs)
, optionNumJobs
installNumJobs
(\v flags -> flags{installNumJobs = v})
@@ -2608,6 +2616,34 @@ installOptions showOrParseArgs =
]
_ -> []
+optionNumJobs
+ :: (flags -> Flag (Maybe Int))
+ -> (Flag (Maybe Int) -> flags -> flags)
+ -> OptionField flags
+optionNumJobs get set =
+ option
+ "j"
+ ["jobs"]
+ "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
+ get
+ set
+ ( optArg
+ "NUM"
+ (fmap Flag numJobsParser)
+ ("", Flag Nothing)
+ (map (Just . maybe "$ncpus" show) . flagToList)
+ )
+ where
+ numJobsParser :: ReadE (Maybe Int)
+ numJobsParser = ReadE $ \s ->
+ case s of
+ "$ncpus" -> Right Nothing
+ _ -> case reads s of
+ [(n, "")]
+ | n < 1 -> Left "The number of jobs should be 1 or more."
+ | otherwise -> Right (Just n)
+ _ -> Left "The jobs value should be a number or '$ncpus'"
+
instance Monoid InstallFlags where
mempty = gmempty
mappend = (<>)
diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs
index 4425a9a03a..fd9ed4ca19 100644
--- a/cabal-install/tests/IntegrationTests2.hs
+++ b/cabal-install/tests/IntegrationTests2.hs
@@ -85,6 +85,7 @@ import qualified Data.List as L
import qualified Data.ByteString as BS
import Distribution.Client.GlobalFlags (GlobalFlags, globalNix)
import Distribution.Simple.Flag (Flag (Flag, NoFlag))
+import Distribution.Types.ParStrat
import Data.Maybe (fromJust)
#if !MIN_VERSION_directory(1,2,7)
@@ -1760,7 +1761,7 @@ executePlan ((distDirLayout, cabalDirLayout, config, _, buildSettings),
elaboratedShared
pkgsBuildStatus
-- Avoid trying to use act-as-setup mode:
- buildSettings { buildSettingNumJobs = 1 }
+ buildSettings { buildSettingNumJobs = Serial }
return (elaboratedPlan'', buildOutcomes)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index b1108d7770..cdb34a3534 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -488,6 +488,7 @@ instance Arbitrary ProjectConfigBuildOnly where
<*> arbitrary
<*> arbitrary
<*> arbitrary
+ <*> arbitrary
<*> (fmap getShortToken <$> arbitrary)
<*> arbitrary
<*> (fmap getShortToken <$> arbitrary)
@@ -508,6 +509,7 @@ instance Arbitrary ProjectConfigBuildOnly where
, projectConfigReportPlanningFailure = x06
, projectConfigSymlinkBinDir = x07
, projectConfigNumJobs = x09
+ , projectConfigUseSemaphore = x19
, projectConfigKeepGoing = x10
, projectConfigOfflineMode = x11
, projectConfigKeepTempFiles = x12
@@ -528,6 +530,7 @@ instance Arbitrary ProjectConfigBuildOnly where
, projectConfigReportPlanningFailure = x06'
, projectConfigSymlinkBinDir = x07'
, projectConfigNumJobs = postShrink_NumJobs x09'
+ , projectConfigUseSemaphore = x19'
, projectConfigKeepGoing = x10'
, projectConfigOfflineMode = x11'
, projectConfigKeepTempFiles = x12'
@@ -540,13 +543,13 @@ instance Arbitrary ProjectConfigBuildOnly where
| ( (x00', x01', x02', x03', x04')
, (x05', x06', x07', x09')
, (x10', x11', x12', x14')
- , (x17', x18')
+ , (x17', x18', x19')
) <-
shrink
( (x00, x01, x02, x03, x04)
, (x05, x06, x07, preShrink_NumJobs x09)
, (x10, x11, x12, x14)
- , (x17, x18)
+ , (x17, x18, x19)
)
]
where
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/C.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/C.hs
new file mode 100644
index 0000000000..ac14f3ce5c
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/C.hs
@@ -0,0 +1,3 @@
+module C where
+import A
+import B
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/Semaphore.cabal b/cabal-testsuite/PackageTests/NewBuild/Semaphore/Semaphore.cabal
new file mode 100644
index 0000000000..4f2d0fb67a
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/Semaphore.cabal
@@ -0,0 +1,22 @@
+-- Initial T3460.cabal generated by cabal init. For further documentation,
+-- see http://haskell.org/cabal/users-guide/
+
+name: Semaphore
+version: 0.1.0.0
+-- synopsis:
+-- description:
+license: BSD3
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+-- copyright:
+-- category:
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: C
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base, sub-package-A, sub-package-B
+ -- hs-source-dirs:
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.out b/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.out
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.project b/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.project
new file mode 100644
index 0000000000..273ddad8cd
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.project
@@ -0,0 +1,3 @@
+packages: ./Semaphore.cabal
+ , ./sub-package-A
+ , ./sub-package-B
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.test.hs
new file mode 100644
index 0000000000..fe425b5c36
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/cabal.test.hs
@@ -0,0 +1,6 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+ skipUnlessGhcVersion ">= 9.7"
+ -- Parallel flag means output of this test is nondeterministic
+ recordMode DoNotRecord $
+ cabal "v2-build" ["-j", "--semaphore", "Semaphore"]
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/A.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/A.hs
new file mode 100644
index 0000000000..d843c00b78
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/A.hs
@@ -0,0 +1 @@
+module A where
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/sub-package-A.cabal b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/sub-package-A.cabal
new file mode 100644
index 0000000000..2f1f44ce52
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-A/sub-package-A.cabal
@@ -0,0 +1,22 @@
+-- Initial sub-package-A.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: sub-package-A
+version: 0.1.0.0
+-- synopsis:
+-- description:
+license: BSD3
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+-- copyright:
+-- category:
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: A
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base
+ -- hs-source-dirs:
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/B.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/B.hs
new file mode 100644
index 0000000000..c759bc2d13
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/B.hs
@@ -0,0 +1 @@
+module B where
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/Setup.hs b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/sub-package-B.cabal b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/sub-package-B.cabal
new file mode 100644
index 0000000000..2498184766
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/Semaphore/sub-package-B/sub-package-B.cabal
@@ -0,0 +1,22 @@
+-- Initial sub-package-B.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: sub-package-B
+version: 0.1.0.0
+-- synopsis:
+-- description:
+license: BSD3
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+-- copyright:
+-- category:
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: B
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base
+ -- hs-source-dirs:
+ default-language: Haskell2010
diff --git a/changelog.d/pr-8557 b/changelog.d/pr-8557
new file mode 100644
index 0000000000..f2f11d2eea
--- /dev/null
+++ b/changelog.d/pr-8557
@@ -0,0 +1,20 @@
+synopsis: Add `--semaphore` flag to enable interaction with GHC Job Server protocol
+packages: cabal-install
+prs: #8557
+
+description: {
+
+When cabal-install is passed the `--semaphore` flag it will now act as a job server
+according to the GHC Jobserver Protocol.
+
+In particular this means that cabal-install will create a semaphore which it then
+passes to `./Setup build` (and hence `ghc`) which can be used by `ghc` in order to
+control how much paralellism it uses, coordinating with other simultaneously running
+processes.
+
+This feature requires ghc-9.8 in order to use, as this is the first version of GHC
+which implements the protocol.
+
+The protocol is specified by [GHC Proposal #540](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0540-jsem.rst).
+
+}
diff --git a/changelog.d/pr-8557-2 b/changelog.d/pr-8557-2
new file mode 100644
index 0000000000..c472f992c3
--- /dev/null
+++ b/changelog.d/pr-8557-2
@@ -0,0 +1,16 @@
+synopsis: Add --semaphore option to ./Setup build interface
+packages: Cabal
+prs: #8557
+
+description: {
+
+When `./Setup build --semaphore <SEM>` is called, `ghc` will be called with the
+`-jsem` option. It is the responsibility of the caller of `./Setup build` to
+manage the semaphore according to the GHC Jobserver Protocol.
+
+This low level interface is intended to be called by a high-level tool such as
+`cabal-install` which can create and manage the semaphore appropriately.
+
+The protocol is specified by [GHC Proposal #540](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0540-jsem.rst).
+
+}
diff --git a/doc/cabal-project.rst b/doc/cabal-project.rst
index 3c6f9f63e6..90f819a529 100644
--- a/doc/cabal-project.rst
+++ b/doc/cabal-project.rst
@@ -269,6 +269,22 @@ package, and thus apply globally:
``-j2`` is also supported; a bare ``--jobs`` or ``-j`` is equivalent
to ``--jobs=$ncpus``.
+.. cfg-field:: semaphore: boolean
+ --semaphore
+ --no-semaphore
+ :synopsis: Use GHC's support for semaphore based parallelism.
+
+ :default: False
+
+ This option instructs cabal to control parallelism by creating a new system semaphore,
+ whose number of tokens is specified by ``--jobs`` (or ``-j``).
+ This semaphore is passed to GHC, which allows it to use any leftover parallelism
+ that ``cabal-install`` is not using.
+
+ Requires ``ghc >= 9.8``.
+
+ The command line variant of this field is ``--semaphore``.
+
.. cfg-field:: keep-going: boolean
--keep-going
:synopsis: Try to continue building on failure.
--
GitLab