Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC

Commits:

18 changed files:

Changes:

  • changelog.d/bump-process
    1 
    +section: packaging
    2 
    +issues: #27144
    3 
    +mrs: !16096
    4 
    +synopsis:
    5 
    +  bump submodule to v1.6.29.0
    6 
    +description:
    7 
    +  This submodule bump resolves a segfault on macos 15 with
    8 
    +  certain command line SDK versions.

  • 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
    ... ... @@ -29,6 +29,8 @@ import GHC.Types.Hint
    29 29 
     import GHC.Types.SrcLoc
    30 30 
     import Data.Version
    31 31
    32 
    +import System.Semaphore
    33 
    +  ( SemaphoreError(..), getSemaphoreProtocolVersion )
    32 34 
     import Language.Haskell.Syntax.Decls (RuleDecl(..))
    33 35 
     import GHC.Tc.Errors.Types (TcRnMessage)
    34 36 
     import GHC.HsToCore.Errors.Types (DsMessage)
    ... ... @@ -95,6 +97,20 @@ instance Diagnostic GhcMessage where
    95 97 
     instance HasDefaultDiagnosticOpts DriverMessageOpts where
    96 98 
       defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)
    97 99
    100 
    +pprSemaphoreError :: SemaphoreError -> SDoc
    101 
    +pprSemaphoreError = \case
    102 
    +  SemaphoreAlreadyExists nm ->
    103 
    +    text "a semaphore named" <+> quotes (text nm) <+> text "already exists"
    104 
    +  SemaphoreDoesNotExist nm ->
    105 
    +    text "no semaphore named" <+> quotes (text nm)
    106 
    +  SemaphoreIncompatibleVersion got want ->
    107 
    +    text "protocol version mismatch (got v"
    108 
    +    <> int (getSemaphoreProtocolVersion got)
    109 
    +    <> text ", supported v"
    110 
    +    <> int (getSemaphoreProtocolVersion want) <> text ")"
    111 
    +  SemaphoreOtherError ioe ->
    112 
    +    text (show ioe)
    113 
    +
    98 114 
     instance Diagnostic DriverMessage where
    99 115 
       type DiagnosticOpts DriverMessage = DriverMessageOpts
    100 116 
       diagnosticMessage opts = \case
    ... ... @@ -277,6 +293,10 @@ instance Diagnostic DriverMessage where
    277 293 
                 ++ " and "
    278 294 
                 ++ llvmVersionStr supportedLlvmVersionUpperBound
    279 295 
                 ++ ") and reinstall GHC to ensure -fllvm works")
    296 
    +    DriverSemaphoreOpenFailure _ err
    297 
    +      -> mkSimpleDecorated $
    298 
    +        text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <>
    299 
    +        text "; ignoring -jsem and compiling sequentially."
    280 300
    281 301 
       diagnosticReason = \case
    282 302 
         DriverUnknownMessage m
    ... ... @@ -348,6 +368,8 @@ instance Diagnostic DriverMessage where
    348 368 
           -> ErrorWithoutFlag
    349 369 
         DriverNoConfiguredLLVMToolchain
    350 370 
           -> WarningWithoutFlag
    371 
    +    DriverSemaphoreOpenFailure {}
    372 
    +      -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
    351 373
    352 374 
       diagnosticHints = \case
    353 375 
         DriverUnknownMessage m
    ... ... @@ -421,5 +443,19 @@ instance Diagnostic DriverMessage where
    421 443 
           -> noHints
    422 444 
         DriverNoConfiguredLLVMToolchain
    423 445 
           -> noHints
    446 
    +    DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported)
    447 
    +      | received < supported
    448 
    +      -> let required = getSemaphoreProtocolVersion supported
    449 
    +             target = case buildingCabal of
    450 
    +               YesBuildingCabalPackage -> UpgradeCabalInstall
    451 
    +               NoBuildingCabalPackage  -> UpgradeJobserver
    452 
    +         in [SuggestUpgradeForSemaphoreVersionMismatch target required]
    453 
    +      | received > supported
    454 
    +      -> [SuggestUpgradeForSemaphoreVersionMismatch
    455 
    +            UpgradeGHC (getSemaphoreProtocolVersion received)]
    456 
    +      | otherwise
    457 
    +      -> noHints
    458 
    +    DriverSemaphoreOpenFailure {}
    459 
    +      -> noHints
    424 460
    425 461 
       diagnosticCode = constructorCode

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -40,6 +40,7 @@ import qualified GHC.LanguageExtensions as LangExt
    40 40
    41 41 
     import GHC.Generics ( Generic )
    42 42
    43 
    +import System.Semaphore ( SemaphoreError )
    43 44 
     import GHC.Tc.Errors.Types
    44 45 
     import GHC.Iface.Errors.Types
    45 46
    ... ... @@ -410,6 +411,17 @@ data DriverMessage where
    410 411 
       -}
    411 412 
       DriverNoConfiguredLLVMToolchain :: DriverMessage
    412 413
    414 
    +  {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
    415 
    +      open the semaphore specified by @-jsem@, e.g. the socket does not
    416 
    +      exist, the protocol version is incompatible, or a system error
    417 
    +      occurred.  GHC ignores @-jsem@ and compiles sequentially.
    418 
    +
    419 
    +      The 'BuildingCabalPackage' flag controls whether the diagnostic
    420 
    +      hint suggests upgrading @cabal-install@ (it only does so when GHC
    421 
    +      is invoked by Cabal).
    422 
    +  -}
    423 
    +  DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage
    424 
    +
    413 425 
     deriving instance Generic DriverMessage
    414 426
    415 427 
     data DriverMessageOpts =

  • compiler/GHC/Driver/Flags.hs
    ... ... @@ -1070,6 +1070,7 @@ data WarningFlag =
    1070 1070 
        | Opt_WarnDeprecatedTypeAbstractions              -- Since 9.10
    1071 1071 
        | Opt_WarnDefaultedExceptionContext               -- Since 9.10
    1072 1072 
        | Opt_WarnViewPatternSignatures                   -- Since 9.12
    1073 
    +   | Opt_WarnSemaphoreOpenFailure                   -- Since 10.0.1
    1073 1074 
        deriving (Eq, Ord, Show, Enum, Bounded)
    1074 1075
    1075 1076 
     -- | Return the names of a WarningFlag
    ... ... @@ -1187,6 +1188,7 @@ warnFlagNames wflag = case wflag of
    1187 1188 
       Opt_WarnDeprecatedTypeAbstractions              -> "deprecated-type-abstractions" :| []
    1188 1189 
       Opt_WarnDefaultedExceptionContext               -> "defaulted-exception-context" :| []
    1189 1190 
       Opt_WarnViewPatternSignatures                   -> "view-pattern-signatures" :| []
    1191 
    +  Opt_WarnSemaphoreOpenFailure                   -> "semaphore-open-failure" :| []
    1190 1192
    1191 1193 
     -- -----------------------------------------------------------------------------
    1192 1194 
     -- Standard sets of warning options
    ... ... @@ -1328,7 +1330,8 @@ standardWarnings -- see Note [Documenting warning flags]
    1328 1330 
             Opt_WarnInconsistentFlags,
    1329 1331 
             Opt_WarnDataKindsTC,
    1330 1332 
             Opt_WarnTypeEqualityOutOfScope,
    1331 
    -        Opt_WarnViewPatternSignatures
    1333 
    +        Opt_WarnViewPatternSignatures,
    1334 
    +        Opt_WarnSemaphoreOpenFailure
    1332 1335 
           ]
    1333 1336
    1334 1337 
     -- | Things you get with -W

  • compiler/GHC/Driver/Make.hs
    1 1 
     {-# LANGUAGE NondecreasingIndentation #-}
    2 2
    3 
    +{-# LANGUAGE CPP #-}
    3 4 
     {-# LANGUAGE GADTs #-}
    4 5 
     {-# LANGUAGE DerivingStrategies #-}
    5 6 
     {-# LANGUAGE ApplicativeDo #-}
    ... ... @@ -54,7 +55,6 @@ import GHC.Platform.Ways
    54 55
    55 56 
     import GHC.Driver.Config.Finder (initFinderOpts)
    56 57 
     import GHC.Driver.Config.Parser (initParserOpts)
    57 
    -import GHC.Driver.Config.Diagnostic
    58 58 
     import GHC.Driver.Phases
    59 59 
     import GHC.Driver.Pipeline
    60 60 
     import GHC.Driver.Session
    ... ... @@ -87,6 +87,15 @@ import GHC.Utils.Outputable
    87 87 
     import GHC.Utils.Panic
    88 88 
     import GHC.Utils.Misc
    89 89 
     import GHC.Utils.Error
    90 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    91 
    +import System.Semaphore
    92 
    +  ( SemaphoreIdentifier )
    93 
    +#else
    94 
    +import System.Semaphore
    95 
    +  ( SemaphoreError, SemaphoreIdentifier )
    96 
    +#endif
    97 
    +
    98 
    +import GHC.Driver.Config.Diagnostic
    90 99 
     import GHC.Utils.Logger
    91 100 
     import GHC.Utils.Fingerprint
    92 101 
     import GHC.Utils.TmpFs
    ... ... @@ -113,7 +122,11 @@ import Data.Either ( rights, partitionEithers, lefts )
    113 122 
     import qualified Data.Map as Map
    114 123 
     import qualified Data.Set as Set
    115 124
    125 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    126 
    +import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask )
    127 
    +#else
    116 128 
     import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
    129 
    +#endif
    117 130 
     import qualified GHC.Conc as CC
    118 131 
     import Control.Concurrent.MVar
    119 132 
     import Control.Monad
    ... ... @@ -128,7 +141,11 @@ import System.Directory
    128 141 
     import System.FilePath
    129 142 
     import System.IO        ( fixIO )
    130 143
    144 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    145 
    +import GHC.Conc ( getNumProcessors )
    146 
    +#else
    131 147 
     import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
    148 
    +#endif
    132 149 
     import Control.Monad.IO.Class
    133 150 
     import Control.Monad.Trans.Reader
    134 151 
     import GHC.Driver.Pipeline.LogQueue
    ... ... @@ -668,7 +685,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit
    668 685 
     mkWorkerLimit dflags =
    669 686 
       case parMakeCount dflags of
    670 687 
         Nothing -> pure $ num_procs 1
    671 
    -    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))
    688 
    +    Just (ParMakeSemaphore h) -> pure (JSemLimit h)
    672 689 
         Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
    673 690 
         Just (ParMakeThisMany n) -> pure $ num_procs n
    674 691 
       where
    ... ... @@ -684,8 +701,8 @@ isWorkerLimitSequential (JSemLimit {}) = False
    684 701 
     data WorkerLimit
    685 702 
       = NumProcessorsLimit Int
    686 703 
       | JSemLimit
    687 
    -    SemaphoreName
    688 
    -      -- ^ Semaphore name to use
    704 
    +    SemaphoreIdentifier
    705 
    +      -- ^ Semaphore identifier from @-jsem@
    689 706 
       deriving Eq
    690 707
    691 708 
     -- | Generalized version of 'load' which also supports a custom
    ... ... @@ -2888,6 +2905,7 @@ runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =
    2888 2905 
                         }
    2889 2906 
       in runAllPipelines (NumProcessorsLimit 1) env all_pipelines
    2890 2907
    2908 
    +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH))
    2891 2909 
     runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
    2892 2910 
     runNjobsAbstractSem n_jobs action = do
    2893 2911 
       compile_sem <- newQSem n_jobs
    ... ... @@ -2904,12 +2922,27 @@ runNjobsAbstractSem n_jobs action = do
    2904 2922 
         resetNumCapabilities = set_num_caps n_capabilities
    2905 2923 
       MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
    2906 2924
    2907 
    -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
    2908 
    -runWorkerLimit worker_limit action = case worker_limit of
    2925 
    +#endif
    2926 
    +
    2927 
    +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
    2928 
    +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
    2929 
    +runWorkerLimit _logger _dflags _ action = do
    2930 
    +  lock <- newMVar ()
    2931 
    +  action $ AbstractSem (takeMVar lock) (putMVar lock ())
    2932 
    +#else
    2933 
    +runWorkerLimit logger dflags worker_limit action = case worker_limit of
    2909 2934 
         NumProcessorsLimit n_jobs ->
    2910 2935 
           runNjobsAbstractSem n_jobs action
    2911 
    -    JSemLimit sem ->
    2912 
    -      runJSemAbstractSem sem action
    2936 
    +    JSemLimit sem_ident -> do
    2937 
    +      result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
    2938 
    +      case result of
    2939 
    +        Right a -> return a
    2940 
    +        Left err -> do
    2941 
    +          let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
    2942 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    2943 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    2944 
    +          runNjobsAbstractSem 1 action
    2945 
    +#endif
    2913 2946
    2914 2947 
     -- | Build and run a pipeline
    2915 2948 
     runParPipelines :: WorkerLimit -- ^ How to limit work parallelism
    ... ... @@ -2935,7 +2968,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    2935 2968 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    2936 2969 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    2937 2970
    2938 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    2971 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    2939 2972 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    2940 2973 
                           , withLogger = withParLog log_queue_queue_var
    2941 2974 
                           , compile_sem = abstract_sem
    ... ... @@ -3040,3 +3073,4 @@ which can be checked easily using ghc-debug.
    3040 3073 
        Where? See Note [ModuleNameSet, efficiency and space leaks], a variety of places
    3041 3074 
               in the driver are responsible.
    3042 3075 
     -}
    3076 
    +

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

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -273,6 +273,8 @@ import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))
    273 273
    274 274 
     import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
    275 275
    276 
    +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion )
    277 
    +
    276 278 
     import Data.IORef
    277 279 
     import Control.Arrow ((&&&))
    278 280 
     import Control.Monad
    ... ... @@ -2349,6 +2351,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
    2349 2351 
       Opt_WarnDeprecatedTypeAbstractions -> warnSpec x
    2350 2352 
       Opt_WarnDefaultedExceptionContext -> warnSpec x
    2351 2353 
       Opt_WarnViewPatternSignatures -> warnSpec x
    2354 
    +  Opt_WarnSemaphoreOpenFailure -> warnSpec x
    2352 2355
    2353 2356 
     warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
    2354 2357 
     warningGroupsDeps = map mk warningGroups
    ... ... @@ -3417,6 +3420,8 @@ compilerInfo dflags
    3417 3420 
            ("Support dynamic-too",         showBool $ not isWindows),
    3418 3421 
            -- Whether or not we support the @-j@ flag with @--make@.
    3419 3422 
            ("Support parallel --make",     "YES"),
    3423 
    +       -- The semaphore protocol version supported by @-jsem@.
    3424 
    +       ("Semaphore version",           show (getSemaphoreProtocolVersion semaphoreVersion)),
    3420 3425 
            -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in
    3421 3426 
            -- installed package info.
    3422 3427 
            ("Support reexported-modules",  "YES"),

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -325,6 +325,7 @@ type family GhcDiagnosticCode c = n | n -> c where
    325 325 
       GhcDiagnosticCode "DriverModuleGraphCycle"                        = 92213
    326 326 
       GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284
    327 327 
       GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain"               = 66599
    328 
    +  GhcDiagnosticCode "DriverSemaphoreOpenFailure"                    = 19877
    328 329
    329 330 
       -- Constraint solver diagnostic codes
    330 331 
       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 
       , pprUntickedConstructor, isBareSymbol
    15 16 
       , suggestExtension
    16 17 
       , suggestExtensionWithInfo
    ... ... @@ -505,6 +506,28 @@ data GhcHint
    505 506 
       {-| Suggest add parens to pattern `e -> p :: t` -}
    506 507 
       | SuggestParenthesizePatternRHS
    507 508
    509 
    +  {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to
    510 
    +      support the given semaphore protocol version.
    511 
    +
    512 
    +      Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure'
    513 
    +      carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'.
    514 
    +  -}
    515 
    +  | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int
    516 
    +    -- ^ The 'Int' is the required protocol version.
    517 
    +
    518 
    +-- | What the user should upgrade to resolve an @-jsem@ semaphore
    519 
    +--   protocol version mismatch.
    520 
    +data SemaphoreUpgradeTarget
    521 
    +  = UpgradeCabalInstall
    522 
    +    -- ^ Jobserver is @cabal-install@ (we are building a Cabal package)
    523 
    +    --   and speaks an older protocol than GHC.
    524 
    +  | UpgradeJobserver
    525 
    +    -- ^ Jobserver (not @cabal-install@) speaks an older protocol than
    526 
    +    --   GHC.
    527 
    +  | UpgradeGHC
    528 
    +    -- ^ Jobserver speaks a newer protocol than GHC.
    529 
    +  deriving (Eq, Show)
    530 
    +
    508 531 
     -- | The deriving strategy that was assumed when not explicitly listed in the
    509 532 
     --   source. This is used solely by the missing-deriving-strategies warning.
    510 533 
     --   There's no `Via` case because we never assume that.

  • compiler/GHC/Types/Hint/Ppr.hs
    ... ... @@ -288,6 +288,20 @@ instance Outputable GhcHint where
    288 288 
             (hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig])
    289 289 
         SuggestParenthesizePatternRHS
    290 290 
           -> text "Parenthesize the RHS of the view pattern"
    291 
    +    SuggestUpgradeForSemaphoreVersionMismatch target required
    292 
    +      -> case target of
    293 
    +           UpgradeCabalInstall ->
    294 
    +                 text "The cabal-install jobserver uses an older semaphore protocol."
    295 
    +              $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v"
    296 
    +                  <> int required <> text " to resolve this.")
    297 
    +           UpgradeJobserver ->
    298 
    +                 text "The jobserver uses an older semaphore protocol."
    299 
    +              $$ (text "Upgrade it to a version that supports semaphore protocol v"
    300 
    +                  <> int required <> text " to resolve this.")
    301 
    +           UpgradeGHC ->
    302 
    +                 text "The jobserver uses a newer semaphore protocol than this GHC."
    303 
    +              $$ (text "Upgrade GHC to a version that supports semaphore protocol v"
    304 
    +                  <> int required <> text " to resolve this.")
    291 305
    292 306 
     perhapsAsPat :: SDoc
    293 307 
     perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

  • docs/users_guide/using-warnings.rst
    ... ... @@ -2629,6 +2629,25 @@ of ``-W(no-)*``.
    2629 2629 
         To make the code forwards-compatible and silence the warning, users are
    2630 2630 
         advised to add parentheses manually.
    2631 2631
    2632 
    +.. ghc-flag:: -Wsemaphore-open-failure
    2633 
    +    :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
    2634 
    +    :type: dynamic
    2635 
    +    :reverse: -Wno-semaphore-open-failure
    2636 
    +    :category:
    2637 
    +
    2638 
    +    :since: 9.12.5
    2639 
    +
    2640 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2641 
    +    cannot be opened (e.g. the socket does not exist, the protocol
    2642 
    +    version is incompatible, or a system error occurred).  When this
    2643 
    +    occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
    2644 
    +
    2645 
    +    A common cause is ``cabal-install`` and GHC being built against
    2646 
    +    different versions of the ``semaphore-compat`` library; upgrading
    2647 
    +    both to versions that use the same protocol resolves the mismatch.
    2648 
    +
    2649 
    +----
    2650 
    +
    2632 2651 
     If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
    2633 2652 
     It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
    2634 2653 
     sanity, not yours.)

  • 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
    ... ... @@ -136,10 +136,6 @@ werror =
    136 136 
                 -- unix has many unused imports
    137 137 
               , package unix
    138 138 
                   ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"]
    139 
    -            -- semaphore-compat relies on sem_getvalue as provided by unix, which is
    140 
    -            -- not implemented on Darwin and therefore throws a deprecation warning
    141 
    -          , package semaphoreCompat
    142 
    -              ? mconcat [arg "-Wwarn=deprecations"]
    143 139 
               ]
    144 140 
         , builder Ghc
    145 141 
             ? package rts

  • libraries/process
    1 
    -Subproject commit f7d51387ba7f7f6079f3a9d5ce011ad9359b7dbb
    1 
    +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4

  • libraries/semaphore-compat
    1 
    -Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051
    1 
    +Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f

  • testsuite/tests/diagnostic-codes/codes.stdout
    ... ... @@ -43,6 +43,7 @@
    43 43 
     [GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
    44 44 
     [GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration)
    45 45 
     [GHC-66599] is untested (constructor = DriverNoConfiguredLLVMToolchain)
    46 
    +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure)
    46 47 
     [GHC-06200] is untested (constructor = BlockedEquality)
    47 48 
     [GHC-81325] is untested (constructor = ExpectingMoreArguments)
    48 49 
     [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)

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