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

Commits:

19 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 
    +  ``cleanupSem`` used to snapshot ``heldTokens`` and release them
    8 
    +  before killing the loop, while the loop's in-flight acquire/release
    9 
    +  children could still be mutating it. Cleanup now runs inside the
    10 
    +  loop's own exit handler, after draining the active child via a new
    11 
    +  ``activeChild`` TVar, so the snapshot has no concurrent mutator.

  • 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 ``-j<N>`` 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 on Linux/POSIX, but will lose the cross-process
    22 
    +  ``-jsem`` coordination and fall back to ``-j<N>`` 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,15 @@ 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 
    +    DriverSemaphoreVersionMismatch received supported
    302 
    +      -> mkSimpleDecorated $
    303 
    +        text "Semaphore version mismatch (received v" <> int (getSemaphoreProtocolVersion received) <>
    304 
    +        text ", this GHC supports v" <> int (getSemaphoreProtocolVersion supported) <>
    305 
    +        text "); ignoring -jsem and compiling sequentially."
    306 
    +    DriverSemaphoreOpenFailure err
    307 
    +      -> mkSimpleDecorated $
    308 
    +        text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <>
    309 
    +        text "; ignoring -jsem and compiling sequentially."
    285 310
    286 311 
       diagnosticReason = \case
    287 312 
         DriverUnknownMessage m
    ... ... @@ -355,6 +380,10 @@ instance Diagnostic DriverMessage where
    355 380 
           -> WarningWithoutFlag
    356 381 
         DriverMissingLinkableForModule {}
    357 382 
           -> ErrorWithoutFlag
    383 
    +    DriverSemaphoreVersionMismatch {}
    384 
    +      -> WarningWithFlag Opt_WarnSemaphoreVersionMismatch
    385 
    +    DriverSemaphoreOpenFailure {}
    386 
    +      -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
    358 387
    359 388 
       diagnosticHints = \case
    360 389 
         DriverUnknownMessage m
    ... ... @@ -430,5 +459,14 @@ instance Diagnostic DriverMessage where
    430 459 
           -> noHints
    431 460 
         DriverMissingLinkableForModule {}
    432 461 
           -> noHints
    462 
    +    DriverSemaphoreVersionMismatch received _supported
    463 
    +      | received < _supported
    464 
    +      -> [UnknownHint (text "The parent process (e.g. cabal-install) uses an older semaphore protocol."
    465 
    +           $$ text "Upgrading cabal-install may resolve this." :: SDoc)]
    466 
    +      | otherwise
    467 
    +      -> [UnknownHint (text "The parent process (e.g. cabal-install) uses a newer semaphore protocol."
    468 
    +           $$ text "Upgrading GHC may resolve this." :: SDoc)]
    469 
    +    DriverSemaphoreOpenFailure {}
    470 
    +      -> noHints
    433 471
    434 472 
       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, SemaphoreProtocolVersion )
    40 41 
     import GHC.Tc.Errors.Types
    41 42 
     import GHC.Iface.Errors.Types
    42 43
    ... ... @@ -419,6 +420,23 @@ data DriverMessage where
    419 420
    420 421 
       DriverMissingLinkableForModule :: ![Module] -> DriverMessage
    421 422
    423 
    +  {-| DriverSemaphoreVersionMismatch is a warning that occurs when GHC
    424 
    +      receives a @-jsem@ semaphore name whose protocol version is incompatible
    425 
    +      with the version this GHC supports.  GHC ignores @-jsem@ and compiles
    426 
    +      sequentially.
    427 
    +
    428 
    +      The first field is the received version (or 1 for unversioned names),
    429 
    +      the second is the version this GHC supports.
    430 
    +  -}
    431 
    +  DriverSemaphoreVersionMismatch :: !SemaphoreProtocolVersion -> !SemaphoreProtocolVersion -> DriverMessage
    432 
    +
    433 
    +  {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
    434 
    +      open the semaphore specified by @-jsem@ (e.g. the socket does not exist
    435 
    +      or a system error occurred).  GHC ignores @-jsem@ and compiles
    436 
    +      sequentially.
    437 
    +  -}
    438 
    +  DriverSemaphoreOpenFailure :: !SemaphoreError -> DriverMessage
    439 
    +
    422 440 
     deriving instance Generic DriverMessage
    423 441
    424 442 
     data DriverMessageOpts =

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

  • compiler/GHC/Driver/MakeAction.hs
    ... ... @@ -28,6 +28,14 @@ import GHC.Driver.Errors.Types
    28 28 
     import GHC.Driver.Messager
    29 29 
     import GHC.Driver.MakeSem
    30 30
    31 
    +import System.Semaphore
    32 
    +  ( SemaphoreError(..) )
    33 
    +
    34 
    +import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
    35 
    +import GHC.Driver.Errors ( printOrThrowDiagnostics )
    36 
    +import GHC.Types.Error ( singleMessage )
    37 
    +import GHC.Types.SrcLoc ( noSrcSpan )
    38 
    +import GHC.Utils.Error ( mkPlainMsgEnvelope )
    31 39 
     import GHC.Utils.Logger
    32 40 
     import GHC.Utils.TmpFs
    33 41
    ... ... @@ -49,7 +57,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit
    49 57 
     mkWorkerLimit dflags =
    50 58 
       case parMakeCount dflags of
    51 59 
         Nothing -> pure $ num_procs 1
    52 
    -    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))
    60 
    +    Just (ParMakeSemaphore h) -> pure (JSemLimit h)
    53 61 
         Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
    54 62 
         Just (ParMakeThisMany n) -> pure $ num_procs n
    55 63 
       where
    ... ... @@ -65,8 +73,8 @@ isWorkerLimitSequential (JSemLimit {}) = False
    65 73 
     data WorkerLimit
    66 74 
       = NumProcessorsLimit Int
    67 75 
       | JSemLimit
    68 
    -    SemaphoreName
    69 
    -      -- ^ Semaphore name to use
    76 
    +    String
    77 
    +      -- ^ Raw semaphore identifier from @-jsem@
    70 78 
       deriving Eq
    71 79
    72 80 
     -- | Environment used when compiling a module
    ... ... @@ -122,17 +130,29 @@ runNjobsAbstractSem n_jobs action = do
    122 130 
         resetNumCapabilities = set_num_caps n_capabilities
    123 131 
       MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
    124 132
    125 
    -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
    133 
    +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
    126 134 
     #if defined(wasm32_HOST_ARCH)
    127 
    -runWorkerLimit _ action = do
    135 
    +runWorkerLimit _logger _dflags _ action = do
    128 136 
       lock <- newMVar ()
    129 137 
       action $ AbstractSem (takeMVar lock) (putMVar lock ())
    130 138 
     #else
    131 
    -runWorkerLimit worker_limit action = case worker_limit of
    139 
    +runWorkerLimit logger dflags worker_limit action = case worker_limit of
    132 140 
         NumProcessorsLimit n_jobs ->
    133 141 
           runNjobsAbstractSem n_jobs action
    134 
    -    JSemLimit sem ->
    135 
    -      runJSemAbstractSem sem action
    142 
    +    JSemLimit sem_ident -> do
    143 
    +      result <- MC.try $ runJSemAbstractSem sem_ident action
    144 
    +      case result of
    145 
    +        Right a -> return a
    146 
    +        Left (SemaphoreIncompatibleVersion actual expected) -> do
    147 
    +          let diag = DriverSemaphoreVersionMismatch actual expected
    148 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    149 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    150 
    +          runNjobsAbstractSem 1 action
    151 
    +        Left (err :: SemaphoreError) -> do
    152 
    +          let diag = DriverSemaphoreOpenFailure err
    153 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    154 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    155 
    +          runNjobsAbstractSem 1 action
    136 156 
     #endif
    137 157
    138 158 
     -- | Build and run a pipeline
    ... ... @@ -159,7 +179,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    159 179 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    160 180 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    161 181
    162 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    182 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    163 183 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    164 184 
                           , withLogger = withParLog log_queue_queue_var
    165 185 
                           , compile_sem = abstract_sem

  • compiler/GHC/Driver/MakeSem.hs
    ... ... @@ -9,9 +9,6 @@ module GHC.Driver.MakeSem
    9 9 
         -- by a system semaphore (Posix/Windows)
    10 10 
         runJSemAbstractSem
    11 11
    12 
    -  -- * System semaphores
    13 
    -  , Semaphore, SemaphoreName(..)
    14 
    -
    15 12 
       -- * Abstract semaphores
    16 13 
       , AbstractSem(..)
    17 14 
       , withAbstractSem
    ... ... @@ -46,11 +43,14 @@ import Debug.Trace
    46 43 
     -- available from the semaphore.
    47 44 
     data Jobserver
    48 45 
       = Jobserver
    49 
    -  { jSemaphore :: !Semaphore
    46 
    +  { jSemaphore :: !ClientSemaphore
    50 47 
         -- ^ The semaphore which controls available resources
    51 48 
       , jobs :: !(TVar JobResources)
    52 49 
         -- ^ The currently pending jobs, and the resources
    53 50 
         -- obtained from the semaphore
    51 
    +  , activeChild :: !(TVar (Maybe (ThreadId, TMVar (Maybe MC.SomeException))))
    52 
    +    -- ^ Handle on the current acquire thread (if any). The loop's exit
    53 
    +    -- handler reads this to drain a still-running child on shutdown.
    54 54 
       }
    55 55
    56 56 
     data JobserverOptions
    ... ... @@ -81,6 +81,9 @@ data JobResources
    81 81 
       , jobsWaiting :: !(OrdList (TMVar ()))
    82 82 
         -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into
    83 83 
         -- the TMVar will allow the job to continue.
    84 
    +  , heldTokens  :: [SemaphoreToken]
    85 
    +    -- ^ Actual semaphore tokens (for release/cleanup).
    86 
    +    -- Length should equal tokensOwned - 1 (the implicit token has no SemaphoreToken).
    84 87 
       }
    85 88
    86 89 
     instance Outputable JobResources where
    ... ... @@ -93,9 +96,9 @@ instance Outputable JobResources where
    93 96 
               ] )
    94 97
    95 98 
     -- | Add one new token.
    96 
    -addToken :: JobResources -> JobResources
    97 
    -addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })
    98 
    -  = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }
    99 
    +addToken :: SemaphoreToken -> JobResources -> JobResources
    100 
    +addToken tok jobs@( Jobs { tokensOwned = owned, tokensFree = free, heldTokens = toks })
    101 
    +  = jobs { tokensOwned = owned + 1, tokensFree = free + 1, heldTokens = tok : toks }
    99 102
    100 103 
     -- | Free one token.
    101 104 
     addFreeToken :: JobResources -> JobResources
    ... ... @@ -111,12 +114,14 @@ removeFreeToken jobs@( Jobs { tokensFree = free })
    111 114 
           (text "removeFreeToken:" <+> ppr free)
    112 115 
       $ jobs { tokensFree = free - 1 }
    113 116
    114 
    --- | Return one owned token.
    115 
    -removeOwnedToken :: JobResources -> JobResources
    116 
    -removeOwnedToken jobs@( Jobs { tokensOwned = owned })
    117 
    +-- | Return one owned token, extracting the 'SemaphoreToken' for release.
    118 
    +removeOwnedToken :: JobResources -> (SemaphoreToken, JobResources)
    119 
    +removeOwnedToken jobs@( Jobs { tokensOwned = owned, heldTokens = toks })
    117 120 
       = assertPpr (owned > 1)
    118 121 
           (text "removeOwnedToken:" <+> ppr owned)
    119 
    -  $ jobs { tokensOwned = owned - 1 }
    122 
    +  $ case toks of
    123 
    +      (t:rest) -> (t, jobs { tokensOwned = owned - 1, heldTokens = rest })
    124 
    +      []       -> panic "removeOwnedToken: no held tokens"
    120 125
    121 126 
     -- | Add one new job to the end of the list of pending jobs.
    122 127 
     addJob :: TMVar () -> JobResources -> JobResources
    ... ... @@ -143,7 +148,7 @@ data JobserverAction
    143 148 
       = Idle
    144 149 
       -- | A thread is waiting for a token on the semaphore.
    145 150 
       | Acquiring
    146 
    -    { activeWaitId   :: WaitId
    151 
    +    { activeThreadId :: ThreadId
    147 152 
         , threadFinished :: TMVar (Maybe MC.SomeException) }
    148 153
    149 154 
     -- | Retrieve the 'TMVar' that signals if the current thread has finished,
    ... ... @@ -189,17 +194,26 @@ releaseJob jobs_tvar = do
    189 194 
           return ((), addFreeToken jobs)
    190 195
    191 196
    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
    197 
    +-- | Kill the current acquire thread, if any, and wait for it to exit.
    198 
    +--
    199 
    +-- Relies on the invariant from 'acquireThread' that a forked child always
    200 
    +-- fills its 'threadFinished' TMVar before it dies; this is what lets the
    201 
    +-- 'takeTMVar' below terminate after the 'killThread'.
    202 
    +drainActiveChild :: Jobserver -> IO ()
    203 
    +drainActiveChild (Jobserver { activeChild = active_tvar }) = do
    204 
    +  mb <- readTVarIO active_tvar
    205 
    +  for_ mb $ \(tid, tmv) -> do
    206 
    +    killThread tid
    207 
    +    void $ atomically (takeTMVar tmv)
    208 
    +    atomically $ writeTVar active_tvar Nothing
    209 
    +
    210 
    +-- | Release every token currently in 'heldTokens'. Safe to call only when
    211 
    +-- nothing else is mutating the 'JobResources' TVar.
    212 
    +releaseAllHeld :: Jobserver -> IO ()
    213 
    +releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do
    214 
    +  Jobs { heldTokens = toks } <- readTVarIO jobs_tvar
    215 
    +  forM_ toks $ \t ->
    216 
    +    void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t)
    203 217
    204 218 
     -- | Dispatch the available tokens acquired from the semaphore
    205 219 
     -- to the pending jobs in the job server.
    ... ... @@ -252,7 +266,7 @@ tracedAtomically origin act = do
    252 266 
       return a
    253 267
    254 268 
     renderJobResources :: String -> JobResources -> String
    255 
    -renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $
    269 
    +renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $
    256 270 
       JSObject [ ("name", JSString origin)
    257 271 
                , ("owned", JSInt own)
    258 272 
                , ("free", JSInt free)
    ... ... @@ -262,61 +276,66 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON
    262 276
    263 277 
     -- | Spawn a new thread that waits on the semaphore in order to acquire
    264 278 
     -- an additional token.
    279 
    +--
    280 
    +-- The child is forked masked so the only async-exception delivery point
    281 
    +-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then
    282 
    +-- always runs to completion, so 'threadFinished' is always filled.
    283 
    +--
    284 
    +-- The (tid, threadFinished) pair is also published to 'activeChild' so
    285 
    +-- shutdown can drain the child even after the in-loop 'JobserverState'
    286 
    +-- is gone.
    265 287 
     acquireThread :: Jobserver -> IO JobserverAction
    266 
    -acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    288 
    +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do
    267 289 
         threadFinished_tmvar <- newEmptyTMVarIO
    268 
    -    let
    269 
    -      wait_result_action :: Either MC.SomeException Bool -> IO ()
    270 
    -      wait_result_action wait_res =
    290 
    +    tid <- MC.mask_ $ do
    291 
    +      tid <- forkIO $ do
    292 
    +        wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem
    271 293 
             tracedAtomically_ "acquire_thread" do
    272 294 
               (r, jb) <- case wait_res of
    273 295 
                 Left (e :: MC.SomeException) -> do
    274 296 
                   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)
    297 
    +            Right tok -> do
    298 
    +              modifyJobResources jobs_tvar \ jobs ->
    299 
    +                return (Nothing, addToken tok jobs)
    282 300 
               putTMVar threadFinished_tmvar r
    283 301 
               return jb
    284 
    -    wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action
    285 
    -    labelThread (waitingThreadId wait_id) "acquire_thread"
    286 
    -    return $ Acquiring { activeWaitId   = wait_id
    302 
    +      atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar))
    303 
    +      return tid
    304 
    +    labelThread tid "acquire_thread"
    305 
    +    return $ Acquiring { activeThreadId = tid
    287 306 
                            , threadFinished = threadFinished_tmvar }
    288 307
    289 308 
     -- | Spawn a thread to release ownership of one resource from the semaphore,
    290 309 
     -- provided we have spare resources and no pending jobs.
    291 310 
     releaseThread :: Jobserver -> IO JobserverAction
    292 
    -releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    311 
    +releaseThread (Jobserver { jobs = jobs_tvar }) = do
    293 312 
       threadFinished_tmvar <- newEmptyTMVarIO
    294 313 
       MC.mask_ do
    295 314 
         -- Pre-release the resource so that another thread doesn't take control of it
    296 315 
         -- just as we release the lock on the semaphore.
    297 
    -    still_ok_to_release
    316 
    +    mb_tok
    298 317 
           <- tracedAtomically "pre_release" $
    299 318 
              modifyJobResources jobs_tvar \ jobs ->
    300 319 
                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
    320 
    +           then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs
    321 
    +                in return (Just tok, jobs')
    322 
    +           else return (Nothing, jobs)
    323 
    +    case mb_tok of
    324 
    +      Nothing -> return Idle
    325 
    +      Just tok -> do
    326 
    +        tid <- forkIO $ do
    327 
    +          x <- MC.try $ releaseSemaphoreToken tok
    328 
    +          tracedAtomically_ "post-release" $ do
    329 
    +            (r, jobs) <- case x of
    330 
    +              Left (e :: MC.SomeException) -> do
    331 
    +                modifyJobResources jobs_tvar \ jobs ->
    332 
    +                  return (Just e, addToken tok jobs)
    333 
    +              Right _ -> do
    334 
    +                return (Nothing, Nothing)
    335 
    +            putTMVar threadFinished_tmvar r
    336 
    +            return jobs
    337 
    +        labelThread tid "release_thread"
    338 
    +        return Idle
    320 339
    321 340 
     -- | When there are pending jobs but no free tokens,
    322 341 
     -- spawn a thread to acquire a new token from the semaphore.
    ... ... @@ -363,13 +382,14 @@ tryRelease _ _ = retry
    363 382 
     -- | Wait for an active thread to finish. Once it finishes:
    364 383 
     --
    365 384 
     --  - set the 'JobserverAction' to 'Idle',
    385 
    +--  - clear the 'activeChild' handle,
    366 386 
     --  - update the number of capabilities to reflect the number
    367 387 
     --    of owned tokens from the semaphore.
    368 388 
     tryNoticeIdle :: JobserverOptions
    369 
    -              -> TVar JobResources
    389 
    +              -> Jobserver
    370 390 
                   -> JobserverState
    371 391 
                   -> STM (IO JobserverState)
    372 
    -tryNoticeIdle opts jobs_tvar jobserver_state
    392 
    +tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state
    373 393 
       | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state
    374 394 
       = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar
    375 395 
       | otherwise
    ... ... @@ -381,6 +401,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state
    381 401 
         sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do
    382 402 
           mb_ex <- takeTMVar threadFinished_tmvar
    383 403 
           for_ mb_ex MC.throwM
    404 
    +      writeTVar active_tvar Nothing
    384 405 
           Jobs { tokensOwned } <- readTVar jobs_tvar
    385 406 
           can_change_numcaps <- readTVar can_change_numcaps_tvar
    386 407 
           guard can_change_numcaps
    ... ... @@ -404,11 +425,11 @@ tryStopThread :: TVar JobResources
    404 425 
                   -> STM (IO JobserverState)
    405 426 
     tryStopThread jobs_tvar jsj = do
    406 427 
       case jobserverAction jsj of
    407 
    -    Acquiring { activeWaitId = wait_id } -> do
    428 
    +    Acquiring { activeThreadId = tid } -> do
    408 429 
          jobs <- readTVar jobs_tvar
    409 430 
          guard $ null (jobsWaiting jobs)
    410 431 
          return do
    411 
    -       interruptWaitOnSemaphore wait_id
    432 
    +       killThread tid
    412 433 
            return $ jsj { jobserverAction = Idle }
    413 434 
         _ -> retry
    414 435
    ... ... @@ -430,30 +451,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
    430 451 
           action <- atomically $ asum $ (\x -> x s) <$>
    431 452 
             [ tryRelease    sjs
    432 453 
             , tryAcquire    opts sjs
    433 
    -        , tryNoticeIdle opts jobs_tvar
    454 
    +        , tryNoticeIdle opts sjs
    434 455 
             , tryStopThread jobs_tvar
    435 456 
             ]
    436 457 
           s <- action
    437 458 
           loop s
    438 459
    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
    460 
    +-- | Create a new jobserver using the given semaphore identifier.
    461 
    +makeJobserver :: String -> IO (AbstractSem, IO ())
    462 
    +makeJobserver sem_ident = do
    463 
    +  semaphore <- openSemaphore sem_ident >>= either MC.throwM pure
    443 464 
       let
    444 465 
         init_jobs =
    445 466 
           Jobs { tokensOwned = 1
    446 467 
                , tokensFree  = 1
    447 468 
                , jobsWaiting = NilOL
    469 
    +           , heldTokens  = []
    448 470 
                }
    449 471 
       jobs_tvar <- newTVarIO init_jobs
    472 
    +  active_tvar <- newTVarIO Nothing
    450 473 
       let
    451 474 
         opts = defaultJobserverOptions -- TODO: allow this to be configured
    452 
    -    sjs = Jobserver { jSemaphore = semaphore
    453 
    -                    , jobs       = jobs_tvar }
    475 
    +    sjs = Jobserver { jSemaphore  = semaphore
    476 
    +                    , jobs        = jobs_tvar
    477 
    +                    , activeChild = active_tvar }
    454 478 
       loop_finished_mvar <- newEmptyMVar
    455 479 
       loop_tid <- forkIOWithUnmask \ unmask -> do
    456 480 
         r <- try $ unmask $ jobserverLoop opts sjs
    481 
    +    -- Always-run exit handler: any child the loop spawned is still alive
    482 
    +    -- in its own thread, so drain it before touching jobs_tvar. No one
    483 
    +    -- else can mutate the resources once both are dead.
    484 
    +    drainActiveChild sjs
    485 
    +    releaseAllHeld sjs
    457 486 
         putMVar loop_finished_mvar $
    458 487 
           case r of
    459 488 
             Left e
    ... ... @@ -467,8 +496,8 @@ makeJobserver sem_name = do
    467 496 
         acquireSem = acquireJob jobs_tvar
    468 497 
         releaseSem = releaseJob jobs_tvar
    469 498 
         cleanupSem = do
    470 
    -      -- this is interruptible
    471 
    -      cleanupJobserver sjs
    499 
    +      -- Trigger the loop's exit handler; it drains the active child and
    500 
    +      -- releases all held tokens, then signals loop_finished_mvar.
    472 501 
           killThread loop_tid
    473 502 
           mb_ex <- takeMVar loop_finished_mvar
    474 503 
           for_ mb_ex MC.throwM
    ... ... @@ -477,12 +506,12 @@ makeJobserver sem_name = do
    477 506
    478 507 
     -- | Implement an abstract semaphore using a semaphore 'Jobserver'
    479 508 
     -- which queries the system semaphore of the given name for resources.
    480 
    -runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use
    509 
    +runJSemAbstractSem :: String                -- ^ the semaphore identifier (from @-jsem@)
    481 510 
                        -> (AbstractSem -> IO a) -- ^ the operation to run
    482 511 
                                                 -- which requires a semaphore
    483 512 
                        -> IO a
    484 
    -runJSemAbstractSem sem action = MC.mask \ unmask -> do
    485 
    -  (abs, cleanup) <- makeJobserver sem
    513 
    +runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do
    514 
    +  (abs, cleanup) <- makeJobserver sem_ident
    486 515 
       r <- try $ unmask $ action abs
    487 516 
       case r of
    488 517 
         Left (e1 :: MC.SomeException) -> do
    ... ... @@ -517,8 +546,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre
    517 546 
     is increased, the token is immediately reused (see `modifyJobResources`).
    518 547
    519 548 
     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.
    549 
    +jobs, `acquireThread` forks a child that calls the interruptible
    550 
    +`waitOnSemaphore`. The child is forked in the masked state, so the only place
    551 
    +an async exception can be delivered is the wait itself; once the wait returns,
    552 
    +the child's STM commit always completes, recording either the new token in
    553 
    +`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar)
    554 
    +pair is also published in `activeChild` so the loop's exit handler can drain
    555 
    +the child on shutdown even after the in-loop `JobserverState` is gone.
    522 556
    523 557 
     When GHC has free tokens (tokens from the semaphore that it is not using),
    524 558 
     no pending jobs, and the debounce has expired, then `releaseThread` will
    ... ... @@ -531,6 +565,12 @@ This second token is no longer needed, so we should cancel the wait
    531 565 
     (as it would not be used to do any work, and not be returned until the debounce).
    532 566 
     We only need to kill `acquireJob`, because `releaseJob` never blocks.
    533 567
    568 
    +Shutdown starts with `killThread loop_tid`. The loop's exit handler then
    569 
    +runs `drainActiveChild` followed by `releaseAllHeld`; only then does the
    570 
    +loop signal `loop_finished_mvar`. This sequence makes the heldTokens
    571 
    +snapshot consistent because no other thread can mutate it once the loop and
    572 
    +its child are both dead.
    573 
    +
    534 574 
     Note [Eventlog Messages for jsem]
    535 575 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    536 576 
     It can be tricky to verify that the work is shared adequately across different

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -2445,6 +2445,8 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
    2445 2445 
       Opt_WarnUnusableUnpackPragmas -> warnSpec x
    2446 2446 
       Opt_WarnPatternNamespaceSpecifier -> warnSpec x
    2447 2447 
       Opt_WarnUnrecognisedModifiers -> warnSpec x
    2448 
    +  Opt_WarnSemaphoreVersionMismatch -> warnSpec x
    2449 
    +  Opt_WarnSemaphoreOpenFailure -> warnSpec x
    2448 2450
    2449 2451 
     warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
    2450 2452 
     warningGroupsDeps = map mk warningGroups

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -403,6 +403,8 @@ 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 "DriverSemaphoreVersionMismatch"                = 56206
    407 
    +  GhcDiagnosticCode "DriverSemaphoreOpenFailure"                    = 19877
    406 408
    407 409 
       -- Constraint solver diagnostic codes
    408 410 
       GhcDiagnosticCode "BadTelescope"                                  = 97739

  • docs/users_guide/using-warnings.rst
    ... ... @@ -2721,6 +2721,37 @@ of ``-W(no-)*``.
    2721 2721 
           f :: a %True -> a
    2722 2722 
           g :: a %(k :: Int) -> a
    2723 2723
    2724 
    +.. ghc-flag:: -Wsemaphore-version-mismatch
    2725 
    +    :shortdesc: warn when GHC receives a ``-jsem`` semaphore whose protocol
    2726 
    +        version is incompatible with the version this GHC supports.
    2727 
    +    :type: dynamic
    2728 
    +    :reverse: -Wno-semaphore-version-mismatch
    2729 
    +    :category:
    2730 
    +
    2731 
    +    :since: 10.0.1
    2732 
    +
    2733 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2734 
    +    name indicates a protocol version that is incompatible with this GHC
    2735 
    +    (e.g. an unversioned v1 name passed to a v2 GHC, or vice versa).
    2736 
    +    When this occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
    2737 
    +
    2738 
    +    This situation typically arises when ``cabal-install`` and GHC are built
    2739 
    +    against different versions of the ``semaphore-compat`` library.  Upgrading
    2740 
    +    both to versions that use the same protocol resolves the mismatch.
    2741 
    +
    2742 
    +.. ghc-flag:: -Wsemaphore-open-failure
    2743 
    +    :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
    2744 
    +    :type: dynamic
    2745 
    +    :reverse: -Wno-semaphore-open-failure
    2746 
    +    :category:
    2747 
    +
    2748 
    +    :since: 10.0.1
    2749 
    +
    2750 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2751 
    +    cannot be opened (e.g. the socket does not exist or a system error
    2752 
    +    occurred).  When this occurs, GHC ignores ``-jsem`` and compiles
    2753 
    +    modules sequentially.
    2754 
    +
    2724 2755 
     ----
    2725 2756
    2726 2757 
     If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.

  • docs/users_guide/using.rst
    ... ... @@ -797,7 +797,14 @@ 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's protocol version is incompatible, GHC emits a
    802 
    +    :ghc-flag:`-Wsemaphore-version-mismatch` warning and compiles
    803 
    +    sequentially.  If the semaphore cannot be opened for other reasons
    804 
    +    (e.g. the socket does not exist), GHC emits a
    805 
    +    :ghc-flag:`-Wsemaphore-open-failure` warning and compiles
    806 
    +    sequentially.  In both cases GHC uses only the implicit token
    807 
    +    inherited from the parent process.
    801 808
    802 809 
         Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`,
    803 810 
         and vice-versa.

  • hadrian/cabal.project
    1 1 
     packages: ./
    2 2 
               ../utils/ghc-toolchain/
    3 3 
               ../libraries/ghc-platform/
    4 
    +          ../libraries/semaphore-compat/
    4 5
    5 6 
     -- This essentially freezes the build plan for hadrian
    6 7 
     -- It would be wise to keep this up to date with the state set in .gitlab/ci.sh.

  • hadrian/hadrian.cabal
    ... ... @@ -172,6 +172,7 @@ executable hadrian
    172 172 
                            , base16-bytestring    >= 0.1.1 && < 1.1.0.0
    173 173 
                            , ghc-platform
    174 174 
                            , ghc-toolchain
    175 
    +                       , semaphore-compat
    175 176 
         ghc-options:       -Wall
    176 177 
                            -Wincomplete-record-updates
    177 178 
                            -Wredundant-constraints

  • 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

  • hadrian/src/Rules/Generate.hs
    ... ... @@ -25,6 +25,7 @@ import Utilities
    25 25 
     import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp))
    26 26 
     import GHC.Platform.ArchOS
    27 27 
     import Settings.Program (ghcWithInterpreter)
    28 
    +import System.Semaphore (semaphoreVersion, getSemaphoreProtocolVersion)
    28 29
    29 30 
     -- | Track this file to rebuild generated files whenever it changes.
    30 31 
     trackGenerateHs :: Expr ()
    ... ... @@ -488,6 +489,7 @@ generateSettings settingsFile = do
    488 489 
             , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays)
    489 490 
             , ("Relative Global Package DB", pure rel_pkg_db)
    490 491 
             , ("base unit-id", pure base_unit_id)
    492 
    +        , ("Semaphore version", pure (show (getSemaphoreProtocolVersion semaphoreVersion)))
    491 493 
             ]
    492 494 
         let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
    493 495 
         pure $ case settings of

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -231,6 +231,10 @@ packageArgs = do
    231 231 
             , package hpcBin
    232 232 
               ? builder (Cabal Flags) ? arg "-build-tool-depends"
    233 233
    234 
    +        ------------------------------ semaphore-compat ----------------------------
    235 
    +        , package semaphoreCompat
    236 
    +          ? builder (Cabal Flags) ? arg "-build-testing"
    237 
    +
    234 238 
             ]
    235 239
    236 240 
     ghcInternalArgs :: Args

  • hadrian/stack.yaml
    ... ... @@ -16,6 +16,7 @@ packages:
    16 16 
     - '.'
    17 17 
     - '../utils/ghc-toolchain'
    18 18 
     - '../libraries/ghc-platform'
    19 
    +- '../libraries/semaphore-compat'
    19 20
    20 21 
     nix:
    21 22 
       enable: false

  • libraries/semaphore-compat
    1 
    -Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1
    1 
    +Subproject commit 2453a03c00e25e30e321816d53c8dbdb113de08b

  • testsuite/tests/diagnostic-codes/codes.stdout
    ... ... @@ -21,6 +21,8 @@
    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-56206] is untested (constructor = DriverSemaphoreVersionMismatch)
    25 
    +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure)
    24 26 
     [GHC-81325] is untested (constructor = ExpectingMoreArguments)
    25 27 
     [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
    26 28 
     [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