Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC

Commits:

16 changed files:

Changes:

  • changelog.d/jobserver-leak-fix
    1 
    +section: compiler
    2 
    +issues: #27253
    3 
    +mrs: !15729
    4 
    +synopsis:
    5 
    +  Fix a token leak in the ``-jsem`` jobserver shutdown path
    6 
    +description:
    7 
    +  A build interrupted by Ctrl-C while a ``-jsem`` token transfer was in
    8 
    +  flight could leak that token.

  • changelog.d/semaphore-v2
    1 
    +section: compiler
    2 
    +issues: #25087
    3 
    +mrs: !15729
    4 
    +synopsis:
    5 
    +  Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2)
    6 
    +description:
    7 
    +  On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client
    8 
    +  now speaks v2 of the semaphore-compat protocol, which uses Unix
    9 
    +  domain sockets in place of POSIX named semaphores. This avoids the
    10 
    +  libc-ABI issues that affected the old implementation. Windows is
    11 
    +  unaffected and continues to use the v1 protocol (Win32 named
    12 
    +  semaphores); its reported protocol version remains v1.
    13 
    +
    14 
    +  When GHC receives a ``-jsem`` name whose protocol version it does not
    15 
    +  support, it now emits a ``-Wsemaphore-version-mismatch`` warning and
    16 
    +  falls back to ``-j1`` rather than crashing. ``ghc --info`` exposes the
    17 
    +  supported version in a new ``"Semaphore version"`` entry so
    18 
    +  cabal-install can detect a mismatch before invoking GHC.
    19 
    +
    20 
    +  Users on a ``cabal-install`` that predates the v2 update will continue
    21 
    +  to build successfully, but on Linux/POSIX will lose the cross-process
    22 
    +  ``-jsem`` coordination and fall back to ``-j1`` per GHC invocation.
    23 
    +  To recover full parallelism, upgrade to a ``cabal-install`` that
    24 
    +  supports protocol v2.
    25 
    +
    26 
    +  See also:
    27 
    +
    28 
    +  - the `GHC proposal amendment <https://github.com/ghc-proposals/ghc-proposals/pull/673>`_
    29 
    +  - the `cabal-install patch <https://github.com/haskell/cabal/pull/11628>`_
    30 
    +  - the `semaphore-compat library MR <https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8>`_

  • compiler/GHC/Driver/Errors/Ppr.hs
    ... ... @@ -24,6 +24,8 @@ import GHC.Types.Hint
    24 24 
     import GHC.Types.SrcLoc
    25 25 
     import Data.Version
    26 26
    27 
    +import System.Semaphore
    28 
    +  ( SemaphoreError(..), getSemaphoreProtocolVersion )
    27 29 
     import Language.Haskell.Syntax.Decls (RuleDecl(..))
    28 30 
     import GHC.Tc.Errors.Types (TcRnMessage)
    29 31 
     import GHC.HsToCore.Errors.Types (DsMessage)
    ... ... @@ -90,6 +92,20 @@ instance Diagnostic GhcMessage where
    90 92 
     instance HasDefaultDiagnosticOpts DriverMessageOpts where
    91 93 
       defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)
    92 94
    95 
    +pprSemaphoreError :: SemaphoreError -> SDoc
    96 
    +pprSemaphoreError = \case
    97 
    +  SemaphoreAlreadyExists nm ->
    98 
    +    text "a semaphore named" <+> quotes (text nm) <+> text "already exists"
    99 
    +  SemaphoreDoesNotExist nm ->
    100 
    +    text "no semaphore named" <+> quotes (text nm)
    101 
    +  SemaphoreIncompatibleVersion got want ->
    102 
    +    text "protocol version mismatch (got v"
    103 
    +    <> int (getSemaphoreProtocolVersion got)
    104 
    +    <> text ", supported v"
    105 
    +    <> int (getSemaphoreProtocolVersion want) <> text ")"
    106 
    +  SemaphoreOtherError ioe ->
    107 
    +    text (show ioe)
    108 
    +
    93 109 
     instance Diagnostic DriverMessage where
    94 110 
       type DiagnosticOpts DriverMessage = DriverMessageOpts
    95 111 
       diagnosticMessage opts = \case
    ... ... @@ -282,6 +298,10 @@ instance Diagnostic DriverMessage where
    282 298 
           -> mkSimpleDecorated $
    283 299 
             vcat [ text "The following modules are missing a linkable which is needed for creating a library:"
    284 300 
                  , nest 2 $ hcat (map ppr mods) ]
    301 
    +    DriverSemaphoreOpenFailure _ err
    302 
    +      -> mkSimpleDecorated $
    303 
    +        text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <>
    304 
    +        text "; ignoring -jsem and compiling sequentially."
    285 305
    286 306 
       diagnosticReason = \case
    287 307 
         DriverUnknownMessage m
    ... ... @@ -355,6 +375,8 @@ instance Diagnostic DriverMessage where
    355 375 
           -> WarningWithoutFlag
    356 376 
         DriverMissingLinkableForModule {}
    357 377 
           -> ErrorWithoutFlag
    378 
    +    DriverSemaphoreOpenFailure {}
    379 
    +      -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
    358 380
    359 381 
       diagnosticHints = \case
    360 382 
         DriverUnknownMessage m
    ... ... @@ -430,5 +452,19 @@ instance Diagnostic DriverMessage where
    430 452 
           -> noHints
    431 453 
         DriverMissingLinkableForModule {}
    432 454 
           -> noHints
    455 
    +    DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported)
    456 
    +      | received < supported
    457 
    +      -> let required = getSemaphoreProtocolVersion supported
    458 
    +             target = case buildingCabal of
    459 
    +               YesBuildingCabalPackage -> UpgradeCabalInstall
    460 
    +               NoBuildingCabalPackage  -> UpgradeJobserver
    461 
    +         in [SuggestUpgradeForSemaphoreVersionMismatch target required]
    462 
    +      | received > supported
    463 
    +      -> [SuggestUpgradeForSemaphoreVersionMismatch
    464 
    +            UpgradeGHC (getSemaphoreProtocolVersion received)]
    465 
    +      | otherwise
    466 
    +      -> noHints
    467 
    +    DriverSemaphoreOpenFailure {}
    468 
    +      -> noHints
    433 469
    434 470 
       diagnosticCode = constructorCode @GHC

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -37,6 +37,7 @@ import qualified GHC.LanguageExtensions as LangExt
    37 37
    38 38 
     import GHC.Generics ( Generic )
    39 39
    40 
    +import System.Semaphore ( SemaphoreError )
    40 41 
     import GHC.Tc.Errors.Types
    41 42 
     import GHC.Iface.Errors.Types
    42 43
    ... ... @@ -419,6 +420,17 @@ data DriverMessage where
    419 420
    420 421 
       DriverMissingLinkableForModule :: ![Module] -> DriverMessage
    421 422
    423 
    +  {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
    424 
    +      open the semaphore specified by @-jsem@, e.g. the socket does not
    425 
    +      exist, the protocol version is incompatible, or a system error
    426 
    +      occurred.  GHC ignores @-jsem@ and compiles sequentially.
    427 
    +
    428 
    +      The 'BuildingCabalPackage' flag controls whether the diagnostic
    429 
    +      hint suggests upgrading @cabal-install@ (it only does so when GHC
    430 
    +      is invoked by Cabal).
    431 
    +  -}
    432 
    +  DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage
    433 
    +
    422 434 
     deriving instance Generic DriverMessage
    423 435
    424 436 
     data DriverMessageOpts =

  • compiler/GHC/Driver/Flags.hs
    ... ... @@ -1115,6 +1115,7 @@ data WarningFlag =
    1115 1115 
        | Opt_WarnUnusableUnpackPragmas                   -- ^ @since 9.14
    1116 1116 
        | Opt_WarnPatternNamespaceSpecifier               -- ^ @since 9.14
    1117 1117 
        | Opt_WarnUnrecognisedModifiers                   -- ^ @since 10.0
    1118 
    +   | Opt_WarnSemaphoreOpenFailure                   -- Since 10.0.1
    1118 1119 
        deriving (Eq, Ord, Show, Enum, Bounded)
    1119 1120
    1120 1121 
     -- | Return the names of a WarningFlag
    ... ... @@ -1237,6 +1238,7 @@ warnFlagNames wflag = case wflag of
    1237 1238 
       Opt_WarnUnusableUnpackPragmas                   -> "unusable-unpack-pragmas" :| []
    1238 1239 
       Opt_WarnPatternNamespaceSpecifier               -> "pattern-namespace-specifier" :| []
    1239 1240 
       Opt_WarnUnrecognisedModifiers                   -> "unrecognised-modifiers" :| []
    1241 
    +  Opt_WarnSemaphoreOpenFailure                   -> "semaphore-open-failure" :| []
    1240 1242
    1241 1243 
     -- -----------------------------------------------------------------------------
    1242 1244 
     -- Standard sets of warning options
    ... ... @@ -1383,7 +1385,8 @@ standardWarnings -- see Note [Documenting warning flags]
    1383 1385 
             Opt_WarnDeprecatedPragmas,
    1384 1386 
             Opt_WarnRuleLhsEqualities,
    1385 1387 
             Opt_WarnUnusableUnpackPragmas,
    1386 
    -        Opt_WarnUnrecognisedModifiers
    1388 
    +        Opt_WarnUnrecognisedModifiers,
    1389 
    +        Opt_WarnSemaphoreOpenFailure
    1387 1390 
           ]
    1388 1391
    1389 1392 
     -- | Things you get with @-W@.

  • compiler/GHC/Driver/MakeAction.hs
    ... ... @@ -28,16 +28,39 @@ import GHC.Driver.Errors.Types
    28 28 
     import GHC.Driver.Messager
    29 29 
     import GHC.Driver.MakeSem
    30 30
    31 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    32 
    +import System.Semaphore
    33 
    +  ( SemaphoreIdentifier )
    34 
    +#else
    35 
    +import System.Semaphore
    36 
    +  ( SemaphoreError, SemaphoreIdentifier )
    37 
    +#endif
    38 
    +
    39 
    +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
    40 
    +import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
    41 
    +import GHC.Driver.Errors ( printOrThrowDiagnostics )
    42 
    +import GHC.Types.Error ( singleMessage )
    43 
    +import GHC.Types.SrcLoc ( noSrcSpan )
    44 
    +import GHC.Utils.Error ( mkPlainMsgEnvelope )
    45 
    +#endif
    31 46 
     import GHC.Utils.Logger
    32 47 
     import GHC.Utils.TmpFs
    33 48
    49 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    50 
    +import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask )
    51 
    +#else
    34 52 
     import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
    53 
    +#endif
    35 54 
     import qualified GHC.Conc as CC
    36 55 
     import Control.Concurrent.MVar
    37 56 
     import Control.Monad
    38 57 
     import qualified Control.Monad.Catch as MC
    39 58
    59 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    60 
    +import GHC.Conc ( getNumProcessors )
    61 
    +#else
    40 62 
     import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
    63 
    +#endif
    41 64 
     import Control.Monad.Trans.Reader
    42 65 
     import GHC.Driver.Pipeline.LogQueue
    43 66 
     import Control.Concurrent.STM
    ... ... @@ -49,7 +72,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit
    49 72 
     mkWorkerLimit dflags =
    50 73 
       case parMakeCount dflags of
    51 74 
         Nothing -> pure $ num_procs 1
    52 
    -    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))
    75 
    +    Just (ParMakeSemaphore h) -> pure (JSemLimit h)
    53 76 
         Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
    54 77 
         Just (ParMakeThisMany n) -> pure $ num_procs n
    55 78 
       where
    ... ... @@ -65,8 +88,8 @@ isWorkerLimitSequential (JSemLimit {}) = False
    65 88 
     data WorkerLimit
    66 89 
       = NumProcessorsLimit Int
    67 90 
       | JSemLimit
    68 
    -    SemaphoreName
    69 
    -      -- ^ Semaphore name to use
    91 
    +    SemaphoreIdentifier
    92 
    +      -- ^ Semaphore identifier from @-jsem@
    70 93 
       deriving Eq
    71 94
    72 95 
     -- | Environment used when compiling a module
    ... ... @@ -106,6 +129,7 @@ runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =
    106 129 
                         }
    107 130 
       in runAllPipelines (NumProcessorsLimit 1) env all_pipelines
    108 131
    132 
    +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
    109 133 
     runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
    110 134 
     runNjobsAbstractSem n_jobs action = do
    111 135 
       compile_sem <- newQSem n_jobs
    ... ... @@ -122,17 +146,26 @@ runNjobsAbstractSem n_jobs action = do
    122 146 
         resetNumCapabilities = set_num_caps n_capabilities
    123 147 
       MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
    124 148
    125 
    -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
    126 
    -#if defined(wasm32_HOST_ARCH)
    127 
    -runWorkerLimit _ action = do
    149 
    +#endif
    150 
    +
    151 
    +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
    152 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    153 
    +runWorkerLimit _logger _dflags _ action = do
    128 154 
       lock <- newMVar ()
    129 155 
       action $ AbstractSem (takeMVar lock) (putMVar lock ())
    130 156 
     #else
    131 
    -runWorkerLimit worker_limit action = case worker_limit of
    157 
    +runWorkerLimit logger dflags worker_limit action = case worker_limit of
    132 158 
         NumProcessorsLimit n_jobs ->
    133 159 
           runNjobsAbstractSem n_jobs action
    134 
    -    JSemLimit sem ->
    135 
    -      runJSemAbstractSem sem action
    160 
    +    JSemLimit sem_ident -> do
    161 
    +      result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
    162 
    +      case result of
    163 
    +        Right a -> return a
    164 
    +        Left err -> do
    165 
    +          let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
    166 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    167 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    168 
    +          runNjobsAbstractSem 1 action
    136 169 
     #endif
    137 170
    138 171 
     -- | Build and run a pipeline
    ... ... @@ -159,7 +192,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    159 192 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    160 193 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    161 194
    162 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    195 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    163 196 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    164 197 
                           , withLogger = withParLog log_queue_queue_var
    165 198 
                           , compile_sem = abstract_sem
    ... ... @@ -245,4 +278,4 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
    245 278 
     data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
    246 279
    247 280 
     waitMakeAction :: MakeAction -> IO ()
    248 
    -waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
    \ No newline at end of file
    281 
    +waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar

  • compiler/GHC/Driver/MakeSem.hs
    1 1 
     {-# LANGUAGE BlockArguments #-}
    2 
    +{-# LANGUAGE CPP #-}
    2 3 
     {-# LANGUAGE RecordWildCards #-}
    3 4
    4 5 
     -- | Implementation of a jobserver using system semaphores.
    5 6 
     --
    6 7 
     --
    7 8 
     module GHC.Driver.MakeSem
    8 
    -  ( -- * JSem: parallelism semaphore backed
    9 
    +  (
    10 
    +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
    11 
    +    -- * JSem: parallelism semaphore backed
    9 12 
         -- by a system semaphore (Posix/Windows)
    10 
    -    runJSemAbstractSem
    11 
    -
    12 
    -  -- * System semaphores
    13 
    -  , Semaphore, SemaphoreName(..)
    13 
    +    runJSemAbstractSem,
    14 
    +#endif
    14 15
    15 16 
       -- * Abstract semaphores
    16 
    -  , AbstractSem(..)
    17 
    +    AbstractSem(..)
    17 18 
       , withAbstractSem
    18 19 
       )
    19 20 
       where
    20 21
    22 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    23 
    +
    24 
    +import System.Semaphore
    25 
    +  ( AbstractSem(..)
    26 
    +  , withAbstractSem
    27 
    +  )
    28 
    +
    29 
    +#else
    30 
    +
    21 31 
     import GHC.Prelude
    22 32 
     import GHC.Conc
    23 33 
     import GHC.Data.OrdList
    ... ... @@ -27,6 +37,15 @@ import GHC.Utils.Panic
    27 37 
     import GHC.Utils.Json
    28 38
    29 39 
     import System.Semaphore
    40 
    +  ( AbstractSem(..)
    41 
    +  , ClientSemaphore
    42 
    +  , SemaphoreIdentifier
    43 
    +  , SemaphoreToken
    44 
    +  , openSemaphore
    45 
    +  , releaseSemaphoreToken
    46 
    +  , waitOnSemaphore
    47 
    +  , withAbstractSem
    48 
    +  )
    30 49
    31 50 
     import Control.Monad
    32 51 
     import qualified Control.Monad.Catch as MC
    ... ... @@ -46,11 +65,14 @@ import Debug.Trace
    46 65 
     -- available from the semaphore.
    47 66 
     data Jobserver
    48 67 
       = Jobserver
    49 
    -  { jSemaphore :: !Semaphore
    68 
    +  { jSemaphore :: !ClientSemaphore
    50 69 
         -- ^ The semaphore which controls available resources
    51 70 
       , jobs :: !(TVar JobResources)
    52 71 
         -- ^ The currently pending jobs, and the resources
    53 72 
         -- obtained from the semaphore
    73 
    +  , activeChild :: !(TVar (Maybe (ThreadId, TMVar (Maybe MC.SomeException))))
    74 
    +    -- ^ Handle on the current acquire thread (if any). The loop's exit
    75 
    +    -- handler reads this to drain a still-running child on shutdown.
    54 76 
       }
    55 77
    56 78 
     data JobserverOptions
    ... ... @@ -81,6 +103,9 @@ data JobResources
    81 103 
       , jobsWaiting :: !(OrdList (TMVar ()))
    82 104 
         -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into
    83 105 
         -- the TMVar will allow the job to continue.
    106 
    +  , heldTokens  :: [SemaphoreToken]
    107 
    +    -- ^ Actual semaphore tokens (for release/cleanup).
    108 
    +    -- Length should equal tokensOwned - 1 (the implicit token has no SemaphoreToken).
    84 109 
       }
    85 110
    86 111 
     instance Outputable JobResources where
    ... ... @@ -93,9 +118,9 @@ instance Outputable JobResources where
    93 118 
               ] )
    94 119
    95 120 
     -- | Add one new token.
    96 
    -addToken :: JobResources -> JobResources
    97 
    -addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })
    98 
    -  = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }
    121 
    +addToken :: SemaphoreToken -> JobResources -> JobResources
    122 
    +addToken tok jobs@( Jobs { tokensOwned = owned, tokensFree = free, heldTokens = toks })
    123 
    +  = jobs { tokensOwned = owned + 1, tokensFree = free + 1, heldTokens = tok : toks }
    99 124
    100 125 
     -- | Free one token.
    101 126 
     addFreeToken :: JobResources -> JobResources
    ... ... @@ -111,12 +136,14 @@ removeFreeToken jobs@( Jobs { tokensFree = free })
    111 136 
           (text "removeFreeToken:" <+> ppr free)
    112 137 
       $ jobs { tokensFree = free - 1 }
    113 138
    114 
    --- | Return one owned token.
    115 
    -removeOwnedToken :: JobResources -> JobResources
    116 
    -removeOwnedToken jobs@( Jobs { tokensOwned = owned })
    139 
    +-- | Return one owned token, extracting the 'SemaphoreToken' for release.
    140 
    +removeOwnedToken :: JobResources -> (SemaphoreToken, JobResources)
    141 
    +removeOwnedToken jobs@( Jobs { tokensOwned = owned, heldTokens = toks })
    117 142 
       = assertPpr (owned > 1)
    118 143 
           (text "removeOwnedToken:" <+> ppr owned)
    119 
    -  $ jobs { tokensOwned = owned - 1 }
    144 
    +  $ case toks of
    145 
    +      (t:rest) -> (t, jobs { tokensOwned = owned - 1, heldTokens = rest })
    146 
    +      []       -> panic "removeOwnedToken: no held tokens"
    120 147
    121 148 
     -- | Add one new job to the end of the list of pending jobs.
    122 149 
     addJob :: TMVar () -> JobResources -> JobResources
    ... ... @@ -143,7 +170,7 @@ data JobserverAction
    143 170 
       = Idle
    144 171 
       -- | A thread is waiting for a token on the semaphore.
    145 172 
       | Acquiring
    146 
    -    { activeWaitId   :: WaitId
    173 
    +    { activeThreadId :: ThreadId
    147 174 
         , threadFinished :: TMVar (Maybe MC.SomeException) }
    148 175
    149 176 
     -- | Retrieve the 'TMVar' that signals if the current thread has finished,
    ... ... @@ -189,17 +216,30 @@ releaseJob jobs_tvar = do
    189 216 
           return ((), addFreeToken jobs)
    190 217
    191 218
    192 
    --- | Release all tokens owned from the semaphore (to clean up
    193 
    --- the jobserver at the end).
    194 
    -cleanupJobserver :: Jobserver -> IO ()
    195 
    -cleanupJobserver (Jobserver { jSemaphore = sem
    196 
    -                            , jobs       = jobs_tvar })
    197 
    -  = do
    198 
    -    Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar
    199 
    -    let toks_to_release = owned - 1
    200 
    -      -- Subtract off the implicit token: whoever spawned the ghc process
    201 
    -      -- in the first place is responsible for that token.
    202 
    -    releaseSemaphore sem toks_to_release
    219 
    +-- | Kill the current acquire thread, if any, and wait for it to exit.
    220 
    +--
    221 
    +-- Called from the jobserver loop's exit handler, which runs masked.
    222 
    +-- Relies on the invariant from 'acquireThread' that a forked child
    223 
    +-- always fills its 'threadFinished' TMVar before it dies; this is what
    224 
    +-- lets the 'takeTMVar' below terminate after the 'killThread'.
    225 
    +drainActiveChild :: Jobserver -> IO ()
    226 
    +drainActiveChild (Jobserver { activeChild = active_tvar }) = do
    227 
    +  mb <- readTVarIO active_tvar
    228 
    +  for_ mb $ \(tid, tmv) -> do
    229 
    +    killThread tid
    230 
    +    void $ atomically (takeTMVar tmv)
    231 
    +    atomically $ writeTVar active_tvar Nothing
    232 
    +
    233 
    +-- | Release every token currently in 'heldTokens'.
    234 
    +--
    235 
    +-- Called from the jobserver loop's exit handler, which runs masked,
    236 
    +-- after 'drainActiveChild': no other thread is mutating 'JobResources'
    237 
    +-- at this point.
    238 
    +releaseAllHeld :: Jobserver -> IO ()
    239 
    +releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do
    240 
    +  Jobs { heldTokens = toks } <- readTVarIO jobs_tvar
    241 
    +  forM_ toks $ \t ->
    242 
    +    void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t)
    203 243
    204 244 
     -- | Dispatch the available tokens acquired from the semaphore
    205 245 
     -- to the pending jobs in the job server.
    ... ... @@ -252,7 +292,7 @@ tracedAtomically origin act = do
    252 292 
       return a
    253 293
    254 294 
     renderJobResources :: String -> JobResources -> String
    255 
    -renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $
    295 
    +renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $
    256 296 
       JSObject [ ("name", JSString origin)
    257 297 
                , ("owned", JSInt own)
    258 298 
                , ("free", JSInt free)
    ... ... @@ -262,61 +302,68 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON
    262 302
    263 303 
     -- | Spawn a new thread that waits on the semaphore in order to acquire
    264 304 
     -- an additional token.
    305 
    +--
    306 
    +-- The child is forked masked so the only async-exception delivery point
    307 
    +-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then
    308 
    +-- always runs to completion, so 'threadFinished' is always filled.
    309 
    +--
    310 
    +-- The (tid, threadFinished) pair is also published to 'activeChild' so
    311 
    +-- shutdown can drain the child even after the in-loop 'JobserverState'
    312 
    +-- is gone.
    265 313 
     acquireThread :: Jobserver -> IO JobserverAction
    266 
    -acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    314 
    +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do
    267 315 
         threadFinished_tmvar <- newEmptyTMVarIO
    268 
    -    let
    269 
    -      wait_result_action :: Either MC.SomeException Bool -> IO ()
    270 
    -      wait_result_action wait_res =
    316 
    +    tid <- MC.mask_ $ do
    317 
    +      tid <- forkIO $ do
    318 
    +        wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem
    271 319 
             tracedAtomically_ "acquire_thread" do
    272 320 
               (r, jb) <- case wait_res of
    273 321 
                 Left (e :: MC.SomeException) -> do
    274 322 
                   return $ (Just e, Nothing)
    275 
    -            Right success -> do
    276 
    -              if success
    277 
    -                then do
    278 
    -                  modifyJobResources jobs_tvar \ jobs ->
    279 
    -                    return (Nothing, addToken jobs)
    280 
    -                else
    281 
    -                  return (Nothing, Nothing)
    323 
    +            Right tok -> do
    324 
    +              modifyJobResources jobs_tvar \ jobs ->
    325 
    +                return (Nothing, addToken tok jobs)
    282 326 
               putTMVar threadFinished_tmvar r
    283 327 
               return jb
    284 
    -    wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action
    285 
    -    labelThread (waitingThreadId wait_id) "acquire_thread"
    286 
    -    return $ Acquiring { activeWaitId   = wait_id
    328 
    +      atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar))
    329 
    +      return tid
    330 
    +    labelThread tid "acquire_thread"
    331 
    +    return $ Acquiring { activeThreadId = tid
    287 332 
                            , threadFinished = threadFinished_tmvar }
    288 333
    289 334 
     -- | Spawn a thread to release ownership of one resource from the semaphore,
    290 335 
     -- provided we have spare resources and no pending jobs.
    291 336 
     releaseThread :: Jobserver -> IO JobserverAction
    292 
    -releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    337 
    +releaseThread (Jobserver { jobs = jobs_tvar }) = do
    293 338 
       threadFinished_tmvar <- newEmptyTMVarIO
    294 339 
       MC.mask_ do
    295 340 
         -- Pre-release the resource so that another thread doesn't take control of it
    296 341 
         -- just as we release the lock on the semaphore.
    297 
    -    still_ok_to_release
    342 
    +    mb_tok
    298 343 
           <- tracedAtomically "pre_release" $
    299 344 
              modifyJobResources jobs_tvar \ jobs ->
    300 345 
                if guardRelease jobs
    301 
    -               -- TODO: should this also debounce?
    302 
    -           then return (True , removeOwnedToken $ removeFreeToken jobs)
    303 
    -           else return (False, jobs)
    304 
    -    if not still_ok_to_release
    305 
    -    then return Idle
    306 
    -    else do
    307 
    -      tid <- forkIO $ do
    308 
    -        x <- MC.try $ releaseSemaphore sem 1
    309 
    -        tracedAtomically_ "post-release" $ do
    310 
    -          (r, jobs) <- case x of
    311 
    -            Left (e :: MC.SomeException) -> do
    312 
    -              modifyJobResources jobs_tvar \ jobs ->
    313 
    -                return (Just e, addToken jobs)
    314 
    -            Right _ -> do
    315 
    -              return (Nothing, Nothing)
    316 
    -          putTMVar threadFinished_tmvar r
    317 
    -          return jobs
    318 
    -      labelThread tid "release_thread"
    319 
    -      return Idle
    346 
    +           then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs
    347 
    +                in return (Just tok, jobs')
    348 
    +           else return (Nothing, jobs)
    349 
    +    case mb_tok of
    350 
    +      Nothing ->
    351 
    +        -- Not OK to release: there are other pending jobs that could make use of the token.
    352 
    +        return Idle
    353 
    +      Just tok -> do
    354 
    +        tid <- forkIO $ do
    355 
    +          x <- MC.try @_ @MC.SomeException $ releaseSemaphoreToken tok
    356 
    +          tracedAtomically_ "post-release" $ do
    357 
    +            (r, jobs) <- case x of
    358 
    +              Left (e :: MC.SomeException) -> do
    359 
    +                modifyJobResources jobs_tvar \ jobs ->
    360 
    +                  return (Just e, addToken tok jobs)
    361 
    +              Right _ -> do
    362 
    +                return (Nothing, Nothing)
    363 
    +            putTMVar threadFinished_tmvar r
    364 
    +            return jobs
    365 
    +        labelThread tid "release_thread"
    366 
    +        return Idle
    320 367
    321 368 
     -- | When there are pending jobs but no free tokens,
    322 369 
     -- spawn a thread to acquire a new token from the semaphore.
    ... ... @@ -363,13 +410,14 @@ tryRelease _ _ = retry
    363 410 
     -- | Wait for an active thread to finish. Once it finishes:
    364 411 
     --
    365 412 
     --  - set the 'JobserverAction' to 'Idle',
    413 
    +--  - clear the 'activeChild' handle,
    366 414 
     --  - update the number of capabilities to reflect the number
    367 415 
     --    of owned tokens from the semaphore.
    368 416 
     tryNoticeIdle :: JobserverOptions
    369 
    -              -> TVar JobResources
    417 
    +              -> Jobserver
    370 418 
                   -> JobserverState
    371 419 
                   -> STM (IO JobserverState)
    372 
    -tryNoticeIdle opts jobs_tvar jobserver_state
    420 
    +tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state
    373 421 
       | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state
    374 422 
       = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar
    375 423 
       | otherwise
    ... ... @@ -381,6 +429,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state
    381 429 
         sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do
    382 430 
           mb_ex <- takeTMVar threadFinished_tmvar
    383 431 
           for_ mb_ex MC.throwM
    432 
    +      writeTVar active_tvar Nothing
    384 433 
           Jobs { tokensOwned } <- readTVar jobs_tvar
    385 434 
           can_change_numcaps <- readTVar can_change_numcaps_tvar
    386 435 
           guard can_change_numcaps
    ... ... @@ -404,11 +453,11 @@ tryStopThread :: TVar JobResources
    404 453 
                   -> STM (IO JobserverState)
    405 454 
     tryStopThread jobs_tvar jsj = do
    406 455 
       case jobserverAction jsj of
    407 
    -    Acquiring { activeWaitId = wait_id } -> do
    456 
    +    Acquiring { activeThreadId = tid } -> do
    408 457 
          jobs <- readTVar jobs_tvar
    409 458 
          guard $ null (jobsWaiting jobs)
    410 459 
          return do
    411 
    -       interruptWaitOnSemaphore wait_id
    460 
    +       killThread tid
    412 461 
            return $ jsj { jobserverAction = Idle }
    413 462 
         _ -> retry
    414 463
    ... ... @@ -430,30 +479,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
    430 479 
           action <- atomically $ asum $ (\x -> x s) <$>
    431 480 
             [ tryRelease    sjs
    432 481 
             , tryAcquire    opts sjs
    433 
    -        , tryNoticeIdle opts jobs_tvar
    482 
    +        , tryNoticeIdle opts sjs
    434 483 
             , tryStopThread jobs_tvar
    435 484 
             ]
    436 485 
           s <- action
    437 486 
           loop s
    438 487
    439 
    --- | Create a new jobserver using the given semaphore handle.
    440 
    -makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
    441 
    -makeJobserver sem_name = do
    442 
    -  semaphore <- openSemaphore sem_name
    488 
    +-- | Create a new jobserver using the given semaphore identifier.
    489 
    +makeJobserver :: SemaphoreIdentifier -> IO (AbstractSem, IO ())
    490 
    +makeJobserver sem_ident = do
    491 
    +  semaphore <- openSemaphore sem_ident >>= either MC.throwM pure
    443 492 
       let
    444 493 
         init_jobs =
    445 494 
           Jobs { tokensOwned = 1
    446 495 
                , tokensFree  = 1
    447 496 
                , jobsWaiting = NilOL
    497 
    +           , heldTokens  = []
    448 498 
                }
    449 499 
       jobs_tvar <- newTVarIO init_jobs
    500 
    +  active_tvar <- newTVarIO Nothing
    450 501 
       let
    451 502 
         opts = defaultJobserverOptions -- TODO: allow this to be configured
    452 
    -    sjs = Jobserver { jSemaphore = semaphore
    453 
    -                    , jobs       = jobs_tvar }
    503 
    +    sjs = Jobserver { jSemaphore  = semaphore
    504 
    +                    , jobs        = jobs_tvar
    505 
    +                    , activeChild = active_tvar }
    454 506 
       loop_finished_mvar <- newEmptyMVar
    455 507 
       loop_tid <- forkIOWithUnmask \ unmask -> do
    456 508 
         r <- try $ unmask $ jobserverLoop opts sjs
    509 
    +    -- Always-run exit handler: any child the loop spawned is still alive
    510 
    +    -- in its own thread, so drain it before touching jobs_tvar. No one
    511 
    +    -- else can mutate the resources once both are dead.
    512 
    +    drainActiveChild sjs
    513 
    +    releaseAllHeld sjs
    457 514 
         putMVar loop_finished_mvar $
    458 515 
           case r of
    459 516 
             Left e
    ... ... @@ -467,8 +524,8 @@ makeJobserver sem_name = do
    467 524 
         acquireSem = acquireJob jobs_tvar
    468 525 
         releaseSem = releaseJob jobs_tvar
    469 526 
         cleanupSem = do
    470 
    -      -- this is interruptible
    471 
    -      cleanupJobserver sjs
    527 
    +      -- Trigger the loop's exit handler; it drains the active child and
    528 
    +      -- releases all held tokens, then signals loop_finished_mvar.
    472 529 
           killThread loop_tid
    473 530 
           mb_ex <- takeMVar loop_finished_mvar
    474 531 
           for_ mb_ex MC.throwM
    ... ... @@ -477,12 +534,12 @@ makeJobserver sem_name = do
    477 534
    478 535 
     -- | Implement an abstract semaphore using a semaphore 'Jobserver'
    479 536 
     -- which queries the system semaphore of the given name for resources.
    480 
    -runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use
    537 
    +runJSemAbstractSem :: SemaphoreIdentifier   -- ^ the semaphore identifier (from @-jsem@)
    481 538 
                        -> (AbstractSem -> IO a) -- ^ the operation to run
    482 539 
                                                 -- which requires a semaphore
    483 540 
                        -> IO a
    484 
    -runJSemAbstractSem sem action = MC.mask \ unmask -> do
    485 
    -  (abs, cleanup) <- makeJobserver sem
    541 
    +runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do
    542 
    +  (abs, cleanup) <- makeJobserver sem_ident
    486 543 
       r <- try $ unmask $ action abs
    487 544 
       case r of
    488 545 
         Left (e1 :: MC.SomeException) -> do
    ... ... @@ -517,8 +574,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre
    517 574 
     is increased, the token is immediately reused (see `modifyJobResources`).
    518 575
    519 576 
     The `jobServerLoop` interacts with the system semaphore: when there are pending
    520 
    -jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a
    521 
    -token is obtained, it increases the owned count.
    577 
    +jobs, `acquireThread` forks a child that calls the interruptible
    578 
    +`waitOnSemaphore`. The child is forked in the masked state, so the only place
    579 
    +an async exception can be delivered is the wait itself; once the wait returns,
    580 
    +the child's STM commit always completes, recording either the new token in
    581 
    +`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar)
    582 
    +pair is also published in `activeChild` so the loop's exit handler can drain
    583 
    +the child on shutdown even after the in-loop `JobserverState` is gone.
    522 584
    523 585 
     When GHC has free tokens (tokens from the semaphore that it is not using),
    524 586 
     no pending jobs, and the debounce has expired, then `releaseThread` will
    ... ... @@ -531,6 +593,12 @@ This second token is no longer needed, so we should cancel the wait
    531 593 
     (as it would not be used to do any work, and not be returned until the debounce).
    532 594 
     We only need to kill `acquireJob`, because `releaseJob` never blocks.
    533 595
    596 
    +Shutdown starts with `killThread loop_tid`. The loop's exit handler then
    597 
    +runs `drainActiveChild` followed by `releaseAllHeld`; only then does the
    598 
    +loop signal `loop_finished_mvar`. This sequence makes the heldTokens
    599 
    +snapshot consistent because no other thread can mutate it once the loop and
    600 
    +its child are both dead.
    601 
    +
    534 602 
     Note [Eventlog Messages for jsem]
    535 603 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    536 604 
     It can be tricky to verify that the work is shared adequately across different
    ... ... @@ -540,3 +608,5 @@ to analyse this output and report statistics about core saturation in the
    540 608 
     GitHub repo (https://github.com/mpickering/ghc-jsem-analyse).
    541 609
    542 610 
     -}
    611 
    +
    612 
    +#endif

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -289,6 +289,8 @@ import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
    289 289 
     import GHC.Toolchain
    290 290 
     import GHC.Toolchain.Program
    291 291
    292 
    +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion )
    293 
    +
    292 294 
     import Data.IORef
    293 295 
     import Control.Arrow ((&&&))
    294 296 
     import Control.Monad
    ... ... @@ -2445,6 +2447,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
    2445 2447 
       Opt_WarnUnusableUnpackPragmas -> warnSpec x
    2446 2448 
       Opt_WarnPatternNamespaceSpecifier -> warnSpec x
    2447 2449 
       Opt_WarnUnrecognisedModifiers -> warnSpec x
    2450 
    +  Opt_WarnSemaphoreOpenFailure -> warnSpec x
    2448 2451
    2449 2452 
     warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
    2450 2453 
     warningGroupsDeps = map mk warningGroups
    ... ... @@ -3628,6 +3631,8 @@ compilerInfo dflags
    3628 3631 
            ("Support dynamic-too",         showBool $ not isWindows),
    3629 3632 
            -- Whether or not we support the @-j@ flag with @--make@.
    3630 3633 
            ("Support parallel --make",     "YES"),
    3634 
    +       -- The semaphore protocol version supported by @-jsem@.
    3635 
    +       ("Semaphore version",           show (getSemaphoreProtocolVersion semaphoreVersion)),
    3631 3636 
            -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in
    3632 3637 
            -- installed package info.
    3633 3638 
            ("Support reexported-modules",  "YES"),

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -403,6 +403,7 @@ type family GhcDiagnosticCode c = n | n -> c where
    403 403 
       GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284
    404 404 
       GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain"               = 66599
    405 405 
       GhcDiagnosticCode "DriverMissingLinkableForModule"                = 47338
    406 
    +  GhcDiagnosticCode "DriverSemaphoreOpenFailure"                    = 19877
    406 407
    407 408 
       -- Constraint solver diagnostic codes
    408 409 
       GhcDiagnosticCode "BadTelescope"                                  = 97739

  • compiler/GHC/Types/Hint.hs
    ... ... @@ -11,6 +11,7 @@ module GHC.Types.Hint (
    11 11 
       , StarIsType(..)
    12 12 
       , UntickedPromotedThing(..)
    13 13 
       , AssumedDerivingStrategy(..)
    14 
    +  , SemaphoreUpgradeTarget(..)
    14 15 
       , SigLike(..)
    15 16 
       , pprUntickedConstructor, isBareSymbol
    16 17 
       , suggestExtension
    ... ... @@ -538,6 +539,28 @@ data GhcHint
    538 539 
       {-| Suggest adding signature to modifier -}
    539 540 
       | SuggestModifierSignature (HsModifier GhcRn) Name
    540 541
    542 
    +  {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to
    543 
    +      support the given semaphore protocol version.
    544 
    +
    545 
    +      Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure'
    546 
    +      carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'.
    547 
    +  -}
    548 
    +  | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int
    549 
    +    -- ^ The 'Int' is the required protocol version.
    550 
    +
    551 
    +-- | What the user should upgrade to resolve an @-jsem@ semaphore
    552 
    +--   protocol version mismatch.
    553 
    +data SemaphoreUpgradeTarget
    554 
    +  = UpgradeCabalInstall
    555 
    +    -- ^ Jobserver is @cabal-install@ (we are building a Cabal package)
    556 
    +    --   and speaks an older protocol than GHC.
    557 
    +  | UpgradeJobserver
    558 
    +    -- ^ Jobserver (not @cabal-install@) speaks an older protocol than
    559 
    +    --   GHC.
    560 
    +  | UpgradeGHC
    561 
    +    -- ^ Jobserver speaks a newer protocol than GHC.
    562 
    +  deriving (Eq, Show)
    563 
    +
    541 564 
     -- | The deriving strategy that was assumed when not explicitly listed in the
    542 565 
     --   source. This is used solely by the missing-deriving-strategies warning.
    543 566 
     --   There's no `Via` case because we never assume that.

  • compiler/GHC/Types/Hint/Ppr.hs
    ... ... @@ -306,6 +306,20 @@ instance Outputable GhcHint where
    306 306 
                (text "Perhaps it should have a kind signature, like")
    307 307 
                2
    308 308 
                (hsep [text "%(" <> ppr ty, text "::", ppr name <> text ")"])
    309 
    +    SuggestUpgradeForSemaphoreVersionMismatch target required
    310 
    +      -> case target of
    311 
    +           UpgradeCabalInstall ->
    312 
    +                 text "The cabal-install jobserver uses an older semaphore protocol."
    313 
    +              $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v"
    314 
    +                  <> int required <> text " to resolve this.")
    315 
    +           UpgradeJobserver ->
    316 
    +                 text "The jobserver uses an older semaphore protocol."
    317 
    +              $$ (text "Upgrade it to a version that supports semaphore protocol v"
    318 
    +                  <> int required <> text " to resolve this.")
    319 
    +           UpgradeGHC ->
    320 
    +                 text "The jobserver uses a newer semaphore protocol than this GHC."
    321 
    +              $$ (text "Upgrade GHC to a version that supports semaphore protocol v"
    322 
    +                  <> int required <> text " to resolve this.")
    309 323
    310 324 
     perhapsAsPat :: SDoc
    311 325 
     perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

  • docs/users_guide/using-warnings.rst
    ... ... @@ -2721,6 +2721,23 @@ of ``-W(no-)*``.
    2721 2721 
           f :: a %True -> a
    2722 2722 
           g :: a %(k :: Int) -> a
    2723 2723
    2724 
    +.. ghc-flag:: -Wsemaphore-open-failure
    2725 
    +    :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
    2726 
    +    :type: dynamic
    2727 
    +    :reverse: -Wno-semaphore-open-failure
    2728 
    +    :category:
    2729 
    +
    2730 
    +    :since: 10.0.1
    2731 
    +
    2732 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2733 
    +    cannot be opened (e.g. the socket does not exist, the protocol
    2734 
    +    version is incompatible, or a system error occurred).  When this
    2735 
    +    occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
    2736 
    +
    2737 
    +    A common cause is ``cabal-install`` and GHC being built against
    2738 
    +    different versions of the ``semaphore-compat`` library; upgrading
    2739 
    +    both to versions that use the same protocol resolves the mismatch.
    2740 
    +
    2724 2741 
     ----
    2725 2742
    2726 2743 
     If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.

  • docs/users_guide/using.rst
    ... ... @@ -797,7 +797,12 @@ There are two kinds of participants in the GHC Jobserver protocol:
    797 797
    798 798 
         Perform compilation in parallel when possible, coordinating with other
    799 799 
         processes through the semaphore ⟨sem⟩ (specified as a string).
    800 
    -    Error if the semaphore doesn't exist.
    800 
    +
    801 
    +    If the semaphore cannot be opened (e.g. the socket does not exist
    802 
    +    or its protocol version is incompatible with this GHC), GHC emits
    803 
    +    a :ghc-flag:`-Wsemaphore-open-failure` warning and compiles
    804 
    +    sequentially, using only the implicit token inherited from the
    805 
    +    parent process.
    801 806
    802 807 
         Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`,
    803 808 
         and vice-versa.

  • hadrian/src/Flavour.hs
    ... ... @@ -149,10 +149,6 @@ werror =
    149 149 
                 -- unix has many unused imports
    150 150 
               , package unix
    151 151 
                   ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"]
    152 
    -            -- semaphore-compat relies on sem_getvalue as provided by unix, which is
    153 
    -            -- not implemented on Darwin and therefore throws a deprecation warning
    154 
    -          , package semaphoreCompat
    155 
    -              ? mconcat [arg "-Wwarn=deprecations"]
    156 152 
               ]
    157 153 
         , builder Ghc
    158 154 
             ? package rts

  • libraries/semaphore-compat
    1 
    -Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1
    1 
    +Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f

  • testsuite/tests/diagnostic-codes/codes.stdout
    ... ... @@ -21,6 +21,7 @@
    21 21 
     [GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
    22 22 
     [GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration)
    23 23 
     [GHC-66599] is untested (constructor = DriverNoConfiguredLLVMToolchain)
    24 
    +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure)
    24 25 
     [GHC-81325] is untested (constructor = ExpectingMoreArguments)
    25 26 
     [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
    26 27 
     [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help