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,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, SemaphoreIdentifier )
    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 
    +    SemaphoreIdentifier
    77 
    +      -- ^ Semaphore identifier from @-jsem@
    70 78 
       deriving Eq
    71 79
    72 80 
     -- | Environment used when compiling a module
    ... ... @@ -122,17 +130,24 @@ 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 @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
    144 
    +      case result of
    145 
    +        Right a -> return a
    146 
    +        Left err -> do
    147 
    +          let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
    148 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    149 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    150 
    +          runNjobsAbstractSem 1 action
    136 151 
     #endif
    137 152
    138 153 
     -- | Build and run a pipeline
    ... ... @@ -159,7 +174,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    159 174 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    160 175 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    161 176
    162 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    177 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    163 178 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    164 179 
                           , withLogger = withParLog log_queue_queue_var
    165 180 
                           , 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,30 @@ 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 
    +-- Called from the jobserver loop's exit handler, which runs masked.
    200 
    +-- Relies on the invariant from 'acquireThread' that a forked child
    201 
    +-- always fills its 'threadFinished' TMVar before it dies; this is what
    202 
    +-- lets the 'takeTMVar' below terminate after the 'killThread'.
    203 
    +drainActiveChild :: Jobserver -> IO ()
    204 
    +drainActiveChild (Jobserver { activeChild = active_tvar }) = do
    205 
    +  mb <- readTVarIO active_tvar
    206 
    +  for_ mb $ \(tid, tmv) -> do
    207 
    +    killThread tid
    208 
    +    void $ atomically (takeTMVar tmv)
    209 
    +    atomically $ writeTVar active_tvar Nothing
    210 
    +
    211 
    +-- | Release every token currently in 'heldTokens'.
    212 
    +--
    213 
    +-- Called from the jobserver loop's exit handler, which runs masked,
    214 
    +-- after 'drainActiveChild': no other thread is mutating 'JobResources'
    215 
    +-- at this point.
    216 
    +releaseAllHeld :: Jobserver -> IO ()
    217 
    +releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do
    218 
    +  Jobs { heldTokens = toks } <- readTVarIO jobs_tvar
    219 
    +  forM_ toks $ \t ->
    220 
    +    void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t)
    203 221
    204 222 
     -- | Dispatch the available tokens acquired from the semaphore
    205 223 
     -- to the pending jobs in the job server.
    ... ... @@ -252,7 +270,7 @@ tracedAtomically origin act = do
    252 270 
       return a
    253 271
    254 272 
     renderJobResources :: String -> JobResources -> String
    255 
    -renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $
    273 
    +renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $
    256 274 
       JSObject [ ("name", JSString origin)
    257 275 
                , ("owned", JSInt own)
    258 276 
                , ("free", JSInt free)
    ... ... @@ -262,61 +280,68 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON
    262 280
    263 281 
     -- | Spawn a new thread that waits on the semaphore in order to acquire
    264 282 
     -- an additional token.
    283 
    +--
    284 
    +-- The child is forked masked so the only async-exception delivery point
    285 
    +-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then
    286 
    +-- always runs to completion, so 'threadFinished' is always filled.
    287 
    +--
    288 
    +-- The (tid, threadFinished) pair is also published to 'activeChild' so
    289 
    +-- shutdown can drain the child even after the in-loop 'JobserverState'
    290 
    +-- is gone.
    265 291 
     acquireThread :: Jobserver -> IO JobserverAction
    266 
    -acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    292 
    +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do
    267 293 
         threadFinished_tmvar <- newEmptyTMVarIO
    268 
    -    let
    269 
    -      wait_result_action :: Either MC.SomeException Bool -> IO ()
    270 
    -      wait_result_action wait_res =
    294 
    +    tid <- MC.mask_ $ do
    295 
    +      tid <- forkIO $ do
    296 
    +        wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem
    271 297 
             tracedAtomically_ "acquire_thread" do
    272 298 
               (r, jb) <- case wait_res of
    273 299 
                 Left (e :: MC.SomeException) -> do
    274 300 
                   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)
    301 
    +            Right tok -> do
    302 
    +              modifyJobResources jobs_tvar \ jobs ->
    303 
    +                return (Nothing, addToken tok jobs)
    282 304 
               putTMVar threadFinished_tmvar r
    283 305 
               return jb
    284 
    -    wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action
    285 
    -    labelThread (waitingThreadId wait_id) "acquire_thread"
    286 
    -    return $ Acquiring { activeWaitId   = wait_id
    306 
    +      atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar))
    307 
    +      return tid
    308 
    +    labelThread tid "acquire_thread"
    309 
    +    return $ Acquiring { activeThreadId = tid
    287 310 
                            , threadFinished = threadFinished_tmvar }
    288 311
    289 312 
     -- | Spawn a thread to release ownership of one resource from the semaphore,
    290 313 
     -- provided we have spare resources and no pending jobs.
    291 314 
     releaseThread :: Jobserver -> IO JobserverAction
    292 
    -releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
    315 
    +releaseThread (Jobserver { jobs = jobs_tvar }) = do
    293 316 
       threadFinished_tmvar <- newEmptyTMVarIO
    294 317 
       MC.mask_ do
    295 318 
         -- Pre-release the resource so that another thread doesn't take control of it
    296 319 
         -- just as we release the lock on the semaphore.
    297 
    -    still_ok_to_release
    320 
    +    mb_tok
    298 321 
           <- tracedAtomically "pre_release" $
    299 322 
              modifyJobResources jobs_tvar \ jobs ->
    300 323 
                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
    324 
    +           then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs
    325 
    +                in return (Just tok, jobs')
    326 
    +           else return (Nothing, jobs)
    327 
    +    case mb_tok of
    328 
    +      Nothing ->
    329 
    +        -- Not OK to release: there are other pending jobs that could make use of the token.
    330 
    +        return Idle
    331 
    +      Just tok -> do
    332 
    +        tid <- forkIO $ do
    333 
    +          x <- MC.try @_ @MC.SomeException $ releaseSemaphoreToken tok
    334 
    +          tracedAtomically_ "post-release" $ do
    335 
    +            (r, jobs) <- case x of
    336 
    +              Left (e :: MC.SomeException) -> do
    337 
    +                modifyJobResources jobs_tvar \ jobs ->
    338 
    +                  return (Just e, addToken tok jobs)
    339 
    +              Right _ -> do
    340 
    +                return (Nothing, Nothing)
    341 
    +            putTMVar threadFinished_tmvar r
    342 
    +            return jobs
    343 
    +        labelThread tid "release_thread"
    344 
    +        return Idle
    320 345
    321 346 
     -- | When there are pending jobs but no free tokens,
    322 347 
     -- spawn a thread to acquire a new token from the semaphore.
    ... ... @@ -363,13 +388,14 @@ tryRelease _ _ = retry
    363 388 
     -- | Wait for an active thread to finish. Once it finishes:
    364 389 
     --
    365 390 
     --  - set the 'JobserverAction' to 'Idle',
    391 
    +--  - clear the 'activeChild' handle,
    366 392 
     --  - update the number of capabilities to reflect the number
    367 393 
     --    of owned tokens from the semaphore.
    368 394 
     tryNoticeIdle :: JobserverOptions
    369 
    -              -> TVar JobResources
    395 
    +              -> Jobserver
    370 396 
                   -> JobserverState
    371 397 
                   -> STM (IO JobserverState)
    372 
    -tryNoticeIdle opts jobs_tvar jobserver_state
    398 
    +tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state
    373 399 
       | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state
    374 400 
       = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar
    375 401 
       | otherwise
    ... ... @@ -381,6 +407,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state
    381 407 
         sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do
    382 408 
           mb_ex <- takeTMVar threadFinished_tmvar
    383 409 
           for_ mb_ex MC.throwM
    410 
    +      writeTVar active_tvar Nothing
    384 411 
           Jobs { tokensOwned } <- readTVar jobs_tvar
    385 412 
           can_change_numcaps <- readTVar can_change_numcaps_tvar
    386 413 
           guard can_change_numcaps
    ... ... @@ -404,11 +431,11 @@ tryStopThread :: TVar JobResources
    404 431 
                   -> STM (IO JobserverState)
    405 432 
     tryStopThread jobs_tvar jsj = do
    406 433 
       case jobserverAction jsj of
    407 
    -    Acquiring { activeWaitId = wait_id } -> do
    434 
    +    Acquiring { activeThreadId = tid } -> do
    408 435 
          jobs <- readTVar jobs_tvar
    409 436 
          guard $ null (jobsWaiting jobs)
    410 437 
          return do
    411 
    -       interruptWaitOnSemaphore wait_id
    438 
    +       killThread tid
    412 439 
            return $ jsj { jobserverAction = Idle }
    413 440 
         _ -> retry
    414 441
    ... ... @@ -430,30 +457,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
    430 457 
           action <- atomically $ asum $ (\x -> x s) <$>
    431 458 
             [ tryRelease    sjs
    432 459 
             , tryAcquire    opts sjs
    433 
    -        , tryNoticeIdle opts jobs_tvar
    460 
    +        , tryNoticeIdle opts sjs
    434 461 
             , tryStopThread jobs_tvar
    435 462 
             ]
    436 463 
           s <- action
    437 464 
           loop s
    438 465
    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
    466 
    +-- | Create a new jobserver using the given semaphore identifier.
    467 
    +makeJobserver :: SemaphoreIdentifier -> IO (AbstractSem, IO ())
    468 
    +makeJobserver sem_ident = do
    469 
    +  semaphore <- openSemaphore sem_ident >>= either MC.throwM pure
    443 470 
       let
    444 471 
         init_jobs =
    445 472 
           Jobs { tokensOwned = 1
    446 473 
                , tokensFree  = 1
    447 474 
                , jobsWaiting = NilOL
    475 
    +           , heldTokens  = []
    448 476 
                }
    449 477 
       jobs_tvar <- newTVarIO init_jobs
    478 
    +  active_tvar <- newTVarIO Nothing
    450 479 
       let
    451 480 
         opts = defaultJobserverOptions -- TODO: allow this to be configured
    452 
    -    sjs = Jobserver { jSemaphore = semaphore
    453 
    -                    , jobs       = jobs_tvar }
    481 
    +    sjs = Jobserver { jSemaphore  = semaphore
    482 
    +                    , jobs        = jobs_tvar
    483 
    +                    , activeChild = active_tvar }
    454 484 
       loop_finished_mvar <- newEmptyMVar
    455 485 
       loop_tid <- forkIOWithUnmask \ unmask -> do
    456 486 
         r <- try $ unmask $ jobserverLoop opts sjs
    487 
    +    -- Always-run exit handler: any child the loop spawned is still alive
    488 
    +    -- in its own thread, so drain it before touching jobs_tvar. No one
    489 
    +    -- else can mutate the resources once both are dead.
    490 
    +    drainActiveChild sjs
    491 
    +    releaseAllHeld sjs
    457 492 
         putMVar loop_finished_mvar $
    458 493 
           case r of
    459 494 
             Left e
    ... ... @@ -467,8 +502,8 @@ makeJobserver sem_name = do
    467 502 
         acquireSem = acquireJob jobs_tvar
    468 503 
         releaseSem = releaseJob jobs_tvar
    469 504 
         cleanupSem = do
    470 
    -      -- this is interruptible
    471 
    -      cleanupJobserver sjs
    505 
    +      -- Trigger the loop's exit handler; it drains the active child and
    506 
    +      -- releases all held tokens, then signals loop_finished_mvar.
    472 507 
           killThread loop_tid
    473 508 
           mb_ex <- takeMVar loop_finished_mvar
    474 509 
           for_ mb_ex MC.throwM
    ... ... @@ -477,12 +512,12 @@ makeJobserver sem_name = do
    477 512
    478 513 
     -- | Implement an abstract semaphore using a semaphore 'Jobserver'
    479 514 
     -- which queries the system semaphore of the given name for resources.
    480 
    -runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use
    515 
    +runJSemAbstractSem :: SemaphoreIdentifier   -- ^ the semaphore identifier (from @-jsem@)
    481 516 
                        -> (AbstractSem -> IO a) -- ^ the operation to run
    482 517 
                                                 -- which requires a semaphore
    483 518 
                        -> IO a
    484 
    -runJSemAbstractSem sem action = MC.mask \ unmask -> do
    485 
    -  (abs, cleanup) <- makeJobserver sem
    519 
    +runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do
    520 
    +  (abs, cleanup) <- makeJobserver sem_ident
    486 521 
       r <- try $ unmask $ action abs
    487 522 
       case r of
    488 523 
         Left (e1 :: MC.SomeException) -> do
    ... ... @@ -517,8 +552,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre
    517 552 
     is increased, the token is immediately reused (see `modifyJobResources`).
    518 553
    519 554 
     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.
    555 
    +jobs, `acquireThread` forks a child that calls the interruptible
    556 
    +`waitOnSemaphore`. The child is forked in the masked state, so the only place
    557 
    +an async exception can be delivered is the wait itself; once the wait returns,
    558 
    +the child's STM commit always completes, recording either the new token in
    559 
    +`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar)
    560 
    +pair is also published in `activeChild` so the loop's exit handler can drain
    561 
    +the child on shutdown even after the in-loop `JobserverState` is gone.
    522 562
    523 563 
     When GHC has free tokens (tokens from the semaphore that it is not using),
    524 564 
     no pending jobs, and the debounce has expired, then `releaseThread` will
    ... ... @@ -531,6 +571,12 @@ This second token is no longer needed, so we should cancel the wait
    531 571 
     (as it would not be used to do any work, and not be returned until the debounce).
    532 572 
     We only need to kill `acquireJob`, because `releaseJob` never blocks.
    533 573
    574 
    +Shutdown starts with `killThread loop_tid`. The loop's exit handler then
    575 
    +runs `drainActiveChild` followed by `releaseAllHeld`; only then does the
    576 
    +loop signal `loop_finished_mvar`. This sequence makes the heldTokens
    577 
    +snapshot consistent because no other thread can mutate it once the loop and
    578 
    +its child are both dead.
    579 
    +
    534 580 
     Note [Eventlog Messages for jsem]
    535 581 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    536 582 
     It can be tricky to verify that the work is shared adequately across different

  • 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 baa6d17eadcb88f5b0300dfaf6ca510374ffc8e7

  • 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