Implement -jsem: parallelism controlled by semaphoreswip/jsem

See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a
complete description for the motivation for this feature.

The `-jsem` option allows a build tool to pass a semaphore to GHC which
GHC can use in order to control how much parallelism it requests.

GHC itself acts as a client in the GHC jobserver protocol.

```
GHC Jobserver Protocol
~~~~~~~~~~~~~~~~~~~~~~

This proposal introduces the GHC Jobserver Protocol. This protocol allows
a server to dynamically invoke many instances of a client process,
while restricting all of those instances to use no more than <n> capabilities.
This is achieved by coordination over a system semaphore (either a POSIX
semaphore [6]_  in the case of Linux and Darwin, or a Win32 semaphore [7]_
in the case of Windows platforms).

There are two kinds of participants in the GHC Jobserver protocol:

- The *jobserver* creates a system semaphore with a certain number of
  available tokens.

  Each time the jobserver wants to spawn a new jobclient subprocess, it **must**
  first acquire a single token from the semaphore, before spawning
  the subprocess. This token **must** be released once the subprocess terminates.

  Once work is finished, the jobserver **must** destroy the semaphore it created.

- A *jobclient* is a subprocess spawned by the jobserver or another jobclient.

  Each jobclient starts with one available token (its *implicit token*,
  which was acquired by the parent which spawned it), and can request more
  tokens through the Jobserver Protocol by waiting on the semaphore.

  Each time a jobclient wants to spawn a new jobclient subprocess, it **must**
  pass on a single token to the child jobclient. This token can either be the
  jobclient's implicit token, or another token which the jobclient acquired
  from the semaphore.

  Each jobclient **must** release exactly as many tokens as it has acquired from
  the semaphore (this does not include the implicit tokens).
```

Build tools such as cabal act as jobservers in the protocol and are
responsibile for correctly creating, cleaning up and managing the
semaphore.

Adds a new submodule (semaphore-compat) for managing and interacting
with semaphores in a cross-platform way.

Fixes #19349

1 files changed, 19 insertions, 6 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 46290d4ade..d6dd214c75 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -48,6 +48,7 @@ module GHC.Driver.Session (
         needSourceNotes,
         OnOff(..),
         DynFlags(..),
+        ParMakeCount(..),
         outputFile, objectSuf, ways,
         FlagSpec(..),
         HasDynFlags(..), ContainsDynFlags(..),
@@ -467,9 +468,9 @@ data DynFlags = DynFlags {
   ruleCheck             :: Maybe String,
   strictnessBefore      :: [Int],       -- ^ Additional demand analysis
 
-  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel
-                                        --   in --make mode, where Nothing ==> compile as
-                                        --   many in parallel as there are CPUs.
+  parMakeCount          :: Maybe ParMakeCount,
+    -- ^ The number of modules to compile in parallel
+    --   If unspecified, compile with a single job.
 
   enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?
   ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.
@@ -791,6 +792,16 @@ instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where
 class ContainsDynFlags t where
     extractDynFlags :: t -> DynFlags
 
+-- | The type for the -jN argument, specifying that -j on its own represents
+-- using the number of machine processors.
+data ParMakeCount
+  -- | Use this many processors (@-j<n>@ flag).
+  = ParMakeThisMany Int
+  -- | Use parallelism with as many processors as possible (@-j@ flag without an argument).
+  | ParMakeNumProcessors
+  -- | Use the specific semaphore @<sem>@ to control parallelism (@-jsem <sem>@ flag).
+  | ParMakeSemaphore FilePath
+
 -----------------------------------------------------------------------------
 -- Accessors from 'DynFlags'
 
@@ -1154,7 +1165,7 @@ defaultDynFlags mySettings =
         historySize             = 20,
         strictnessBefore        = [],
 
-        parMakeCount            = Just 1,
+        parMakeCount            = Nothing,
 
         enableTimeStats         = False,
         ghcHeapSize             = Nothing,
@@ -2120,14 +2131,16 @@ dynamic_flags_deps = [
   , make_ord_flag defGhcFlag "j"     (OptIntSuffix
         (\n -> case n of
                  Just n
-                     | n > 0     -> upd (\d -> d { parMakeCount = Just n })
+                     | n > 0     -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) })
                      | otherwise -> addErr "Syntax: -j[n] where n > 0"
-                 Nothing -> upd (\d -> d { parMakeCount = Nothing })))
+                 Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors })))
                  -- When the number of parallel builds
                  -- is omitted, it is the same
                  -- as specifying that the number of
                  -- parallel builds is equal to the
                  -- result of getNumProcessors
+  , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) }
+
   , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)
   , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)