Zubin pushed to branch wip/semaphore-v2-9.10 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
    ... ... @@ -26,6 +26,8 @@ import GHC.Types.Hint
    26 26 
     import GHC.Types.SrcLoc
    27 27 
     import Data.Version
    28 28
    29 
    +import System.Semaphore
    30 
    +  ( SemaphoreError(..), getSemaphoreProtocolVersion )
    29 31 
     import Language.Haskell.Syntax.Decls (RuleDecl(..))
    30 32 
     import GHC.Tc.Errors.Types (TcRnMessage)
    31 33 
     import GHC.HsToCore.Errors.Types (DsMessage)
    ... ... @@ -91,6 +93,20 @@ instance Diagnostic GhcMessage where
    91 93 
     instance HasDefaultDiagnosticOpts DriverMessageOpts where
    92 94 
       defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)
    93 95
    96 
    +pprSemaphoreError :: SemaphoreError -> SDoc
    97 
    +pprSemaphoreError = \case
    98 
    +  SemaphoreAlreadyExists nm ->
    99 
    +    text "a semaphore named" <+> quotes (text nm) <+> text "already exists"
    100 
    +  SemaphoreDoesNotExist nm ->
    101 
    +    text "no semaphore named" <+> quotes (text nm)
    102 
    +  SemaphoreIncompatibleVersion got want ->
    103 
    +    text "protocol version mismatch (got v"
    104 
    +    <> int (getSemaphoreProtocolVersion got)
    105 
    +    <> text ", supported v"
    106 
    +    <> int (getSemaphoreProtocolVersion want) <> text ")"
    107 
    +  SemaphoreOtherError ioe ->
    108 
    +    text (show ioe)
    109 
    +
    94 110 
     instance Diagnostic DriverMessage where
    95 111 
       type DiagnosticOpts DriverMessage = DriverMessageOpts
    96 112 
       diagnosticMessage opts = \case
    ... ... @@ -238,6 +254,10 @@ instance Diagnostic DriverMessage where
    238 254 
           -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg
    239 255 
         DriverDeprecatedFlag arg msg
    240 256 
           -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg
    257 
    +    DriverSemaphoreOpenFailure _ err
    258 
    +      -> mkSimpleDecorated $
    259 
    +        text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <>
    260 
    +        text "; ignoring -jsem and compiling sequentially."
    241 261
    242 262 
       diagnosticReason = \case
    243 263 
         DriverUnknownMessage m
    ... ... @@ -303,6 +323,8 @@ instance Diagnostic DriverMessage where
    303 323 
           -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags
    304 324 
         DriverDeprecatedFlag {}
    305 325 
           -> WarningWithFlag Opt_WarnDeprecatedFlags
    326 
    +    DriverSemaphoreOpenFailure {}
    327 
    +      -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
    306 328
    307 329 
       diagnosticHints = \case
    308 330 
         DriverUnknownMessage m
    ... ... @@ -370,5 +392,19 @@ instance Diagnostic DriverMessage where
    370 392 
           -> noHints
    371 393 
         DriverDeprecatedFlag {}
    372 394 
           -> noHints
    395 
    +    DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported)
    396 
    +      | received < supported
    397 
    +      -> let required = getSemaphoreProtocolVersion supported
    398 
    +             target = case buildingCabal of
    399 
    +               YesBuildingCabalPackage -> UpgradeCabalInstall
    400 
    +               NoBuildingCabalPackage  -> UpgradeJobserver
    401 
    +         in [SuggestUpgradeForSemaphoreVersionMismatch target required]
    402 
    +      | received > supported
    403 
    +      -> [SuggestUpgradeForSemaphoreVersionMismatch
    404 
    +            UpgradeGHC (getSemaphoreProtocolVersion received)]
    405 
    +      | otherwise
    406 
    +      -> noHints
    407 
    +    DriverSemaphoreOpenFailure {}
    408 
    +      -> noHints
    373 409
    374 410 
       diagnosticCode = constructorCode

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -39,6 +39,7 @@ import qualified GHC.LanguageExtensions as LangExt
    39 39
    40 40 
     import GHC.Generics ( Generic )
    41 41
    42 
    +import System.Semaphore ( SemaphoreError )
    42 43 
     import GHC.Tc.Errors.Types
    43 44 
     import GHC.Iface.Errors.Types
    44 45
    ... ... @@ -384,6 +385,17 @@ data DriverMessage where
    384 385
    385 386 
       DriverDeprecatedFlag :: String -> String -> DriverMessage
    386 387
    388 
    +  {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
    389 
    +      open the semaphore specified by @-jsem@, e.g. the socket does not
    390 
    +      exist, the protocol version is incompatible, or a system error
    391 
    +      occurred.  GHC ignores @-jsem@ and compiles sequentially.
    392 
    +
    393 
    +      The 'BuildingCabalPackage' flag controls whether the diagnostic
    394 
    +      hint suggests upgrading @cabal-install@ (it only does so when GHC
    395 
    +      is invoked by Cabal).
    396 
    +  -}
    397 
    +  DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage
    398 
    +
    387 399 
     deriving instance Generic DriverMessage
    388 400
    389 401 
     data DriverMessageOpts =

  • compiler/GHC/Driver/Flags.hs
    ... ... @@ -714,6 +714,7 @@ data WarningFlag =
    714 714 
        | Opt_WarnDataKindsTC                             -- Since 9.10
    715 715 
        | Opt_WarnDeprecatedTypeAbstractions              -- Since 9.10
    716 716 
        | Opt_WarnDefaultedExceptionContext               -- Since 9.10
    717 
    +   | Opt_WarnSemaphoreOpenFailure                    -- Since 9.10.4
    717 718 
        deriving (Eq, Ord, Show, Enum, Bounded)
    718 719
    719 720 
     -- | Return the names of a WarningFlag
    ... ... @@ -830,6 +831,7 @@ warnFlagNames wflag = case wflag of
    830 831 
       Opt_WarnDataKindsTC                             -> "data-kinds-tc" :| []
    831 832 
       Opt_WarnDeprecatedTypeAbstractions              -> "deprecated-type-abstractions" :| []
    832 833 
       Opt_WarnDefaultedExceptionContext               -> "defaulted-exception-context" :| []
    834 
    +  Opt_WarnSemaphoreOpenFailure                    -> "semaphore-open-failure" :| []
    833 835
    834 836 
     -- -----------------------------------------------------------------------------
    835 837 
     -- Standard sets of warning options
    ... ... @@ -970,7 +972,8 @@ standardWarnings -- see Note [Documenting warning flags]
    970 972 
             Opt_WarnTypeEqualityRequiresOperators,
    971 973 
             Opt_WarnInconsistentFlags,
    972 974 
             Opt_WarnDataKindsTC,
    973 
    -        Opt_WarnTypeEqualityOutOfScope
    975 
    +        Opt_WarnTypeEqualityOutOfScope,
    976 
    +        Opt_WarnSemaphoreOpenFailure
    974 977 
           ]
    975 978
    976 979 
     -- | Things you get with -W

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -66,6 +66,9 @@ import GHC.Driver.Errors.Types
    66 66 
     import GHC.Driver.Main
    67 67 
     import GHC.Driver.MakeSem
    68 68
    69 
    +import System.Semaphore
    70 
    +  ( SemaphoreError, SemaphoreIdentifier )
    71 
    +
    69 72 
     import GHC.Parser.Header
    70 73
    71 74 
     import GHC.Iface.Load      ( cannotFindModule )
    ... ... @@ -665,7 +668,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit
    665 668 
     mkWorkerLimit dflags =
    666 669 
       case parMakeCount dflags of
    667 670 
         Nothing -> pure $ num_procs 1
    668 
    -    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))
    671 
    +    Just (ParMakeSemaphore h) -> pure (JSemLimit h)
    669 672 
         Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
    670 673 
         Just (ParMakeThisMany n) -> pure $ num_procs n
    671 674 
       where
    ... ... @@ -681,8 +684,8 @@ isWorkerLimitSequential (JSemLimit {}) = False
    681 684 
     data WorkerLimit
    682 685 
       = NumProcessorsLimit Int
    683 686 
       | JSemLimit
    684 
    -    SemaphoreName
    685 
    -      -- ^ Semaphore name to use
    687 
    +    SemaphoreIdentifier
    688 
    +      -- ^ Semaphore identifier from @-jsem@
    686 689 
       deriving Eq
    687 690
    688 691 
     -- | Generalized version of 'load' which also supports a custom
    ... ... @@ -2900,12 +2903,19 @@ runNjobsAbstractSem n_jobs action = do
    2900 2903 
         resetNumCapabilities = set_num_caps n_capabilities
    2901 2904 
       MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
    2902 2905
    2903 
    -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
    2904 
    -runWorkerLimit worker_limit action = case worker_limit of
    2906 
    +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
    2907 
    +runWorkerLimit logger dflags worker_limit action = case worker_limit of
    2905 2908 
         NumProcessorsLimit n_jobs ->
    2906 2909 
           runNjobsAbstractSem n_jobs action
    2907 
    -    JSemLimit sem ->
    2908 
    -      runJSemAbstractSem sem action
    2910 
    +    JSemLimit sem_ident -> do
    2911 
    +      result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action
    2912 
    +      case result of
    2913 
    +        Right a -> return a
    2914 
    +        Left err -> do
    2915 
    +          let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err
    2916 
    +              msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    2917 
    +          printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    2918 
    +          runNjobsAbstractSem 1 action
    2909 2919
    2910 2920 
     -- | Build and run a pipeline
    2911 2921 
     runParPipelines :: WorkerLimit -- ^ How to limit work parallelism
    ... ... @@ -2931,7 +2941,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    2931 2941 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    2932 2942 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    2933 2943
    2934 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    2944 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    2935 2945 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    2936 2946 
                           , withLogger = withParLog log_queue_queue_var
    2937 2947 
                           , compile_sem = abstract_sem

  • compiler/GHC/Driver/MakeSem.hs
    1 1 
     {-# LANGUAGE BlockArguments #-}
    2 
    +{-# LANGUAGE CPP #-}
    2 3 
     {-# LANGUAGE NamedFieldPuns #-}
    3 4 
     {-# LANGUAGE RecordWildCards #-}
    4 5 
     {-# LANGUAGE TupleSections #-}
    ... ... @@ -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
    ... ... @@ -268,6 +268,8 @@ import GHC.Core.Opt.CallerCC
    268 268
    269 269 
     import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
    270 270
    271 
    +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion )
    272 
    +
    271 273 
     import Data.IORef
    272 274 
     import Control.Arrow ((&&&))
    273 275 
     import Control.Monad
    ... ... @@ -2351,6 +2353,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
    2351 2353 
       Opt_WarnDataKindsTC -> warnSpec x
    2352 2354 
       Opt_WarnDeprecatedTypeAbstractions -> warnSpec x
    2353 2355 
       Opt_WarnDefaultedExceptionContext -> warnSpec x
    2356 
    +  Opt_WarnSemaphoreOpenFailure -> warnSpec x
    2354 2357
    2355 2358 
     warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
    2356 2359 
     warningGroupsDeps = map mk warningGroups
    ... ... @@ -3640,6 +3643,8 @@ compilerInfo dflags
    3640 3643 
            ("Support dynamic-too",         showBool $ not isWindows),
    3641 3644 
            -- Whether or not we support the @-j@ flag with @--make@.
    3642 3645 
            ("Support parallel --make",     "YES"),
    3646 
    +       -- The semaphore protocol version supported by @-jsem@.
    3647 
    +       ("Semaphore version",           show (getSemaphoreProtocolVersion semaphoreVersion)),
    3643 3648 
            -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in
    3644 3649 
            -- installed package info.
    3645 3650 
            ("Support reexported-modules",  "YES"),

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -318,6 +318,7 @@ type family GhcDiagnosticCode c = n | n -> c where
    318 318 
       GhcDiagnosticCode "DriverPackageTrustIgnored"                     = 83552
    319 319 
       GhcDiagnosticCode "DriverUnrecognisedFlag"                        = 93741
    320 320 
       GhcDiagnosticCode "DriverDeprecatedFlag"                          = 53692
    321 
    +  GhcDiagnosticCode "DriverSemaphoreOpenFailure"                    = 19877
    321 322
    322 323 
       -- Constraint solver diagnostic codes
    323 324 
       GhcDiagnosticCode "BadTelescope"                                  = 97739

  • compiler/GHC/Types/Hint.hs
    ... ... @@ -10,6 +10,7 @@ module GHC.Types.Hint (
    10 10 
       , SimilarName(..)
    11 11 
       , StarIsType(..)
    12 12 
       , UntickedPromotedThing(..)
    13 
    +  , SemaphoreUpgradeTarget(..)
    13 14 
       , pprUntickedConstructor, isBareSymbol
    14 15 
       , suggestExtension
    15 16 
       , suggestExtensionWithInfo
    ... ... @@ -477,6 +478,28 @@ data GhcHint
    477 478 
       {-| Suggest binding explicitly; e.g   data T @k (a :: F k) = .... -}
    478 479 
       | SuggestBindTyVarExplicitly Name
    479 480
    481 
    +  {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to
    482 
    +      support the given semaphore protocol version.
    483 
    +
    484 
    +      Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure'
    485 
    +      carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'.
    486 
    +  -}
    487 
    +  | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int
    488 
    +    -- ^ The 'Int' is the required protocol version.
    489 
    +
    490 
    +-- | What the user should upgrade to resolve an @-jsem@ semaphore
    491 
    +--   protocol version mismatch.
    492 
    +data SemaphoreUpgradeTarget
    493 
    +  = UpgradeCabalInstall
    494 
    +    -- ^ Jobserver is @cabal-install@ (we are building a Cabal package)
    495 
    +    --   and speaks an older protocol than GHC.
    496 
    +  | UpgradeJobserver
    497 
    +    -- ^ Jobserver (not @cabal-install@) speaks an older protocol than
    498 
    +    --   GHC.
    499 
    +  | UpgradeGHC
    500 
    +    -- ^ Jobserver speaks a newer protocol than GHC.
    501 
    +  deriving (Eq, Show)
    502 
    +
    480 503 
     -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
    481 504 
     -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
    482 505 
     -- to instantiate a particular signature, where the first argument is

  • compiler/GHC/Types/Hint/Ppr.hs
    ... ... @@ -260,6 +260,20 @@ instance Outputable GhcHint where
    260 260 
         SuggestBindTyVarExplicitly tv
    261 261 
           -> text "bind" <+> quotes (ppr tv)
    262 262 
              <+> text "explicitly with" <+> quotes (char '@' <> ppr tv)
    263 
    +    SuggestUpgradeForSemaphoreVersionMismatch target required
    264 
    +      -> case target of
    265 
    +           UpgradeCabalInstall ->
    266 
    +                 text "The cabal-install jobserver uses an older semaphore protocol."
    267 
    +              $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v"
    268 
    +                  <> int required <> text " to resolve this.")
    269 
    +           UpgradeJobserver ->
    270 
    +                 text "The jobserver uses an older semaphore protocol."
    271 
    +              $$ (text "Upgrade it to a version that supports semaphore protocol v"
    272 
    +                  <> int required <> text " to resolve this.")
    273 
    +           UpgradeGHC ->
    274 
    +                 text "The jobserver uses a newer semaphore protocol than this GHC."
    275 
    +              $$ (text "Upgrade GHC to a version that supports semaphore protocol v"
    276 
    +                  <> int required <> text " to resolve this.")
    263 277
    264 278 
     perhapsAsPat :: SDoc
    265 279 
     perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

  • docs/users_guide/using-warnings.rst
    ... ... @@ -2611,6 +2611,23 @@ of ``-W(no-)*``.
    2611 2611 
         evidence is available. As this behavior may result in dropped exception context
    2612 2612 
         this warning is provided to give notice when defaulting occurs.
    2613 2613
    2614 
    +.. ghc-flag:: -Wsemaphore-open-failure
    2615 
    +    :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
    2616 
    +    :type: dynamic
    2617 
    +    :reverse: -Wno-semaphore-open-failure
    2618 
    +    :category:
    2619 
    +
    2620 
    +    :since: 9.10.4
    2621 
    +
    2622 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2623 
    +    cannot be opened (e.g. the socket does not exist, the protocol
    2624 
    +    version is incompatible, or a system error occurred).  When this
    2625 
    +    occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
    2626 
    +
    2627 
    +    A common cause is ``cabal-install`` and GHC being built against
    2628 
    +    different versions of the ``semaphore-compat`` library; upgrading
    2629 
    +    both to versions that use the same protocol resolves the mismatch.
    2630 
    +
    2614 2631 
     If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
    2615 2632 
     It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
    2616 2633 
     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
    ... ... @@ -131,10 +131,6 @@ werror =
    131 131 
                 -- unix has many unused imports
    132 132 
               , package unix
    133 133 
                   ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"]
    134 
    -            -- semaphore-compat relies on sem_getvalue as provided by unix, which is
    135 
    -            -- not implemented on Darwin and therefore throws a deprecation warning
    136 
    -          , package semaphoreCompat
    137 
    -              ? mconcat [arg "-Wwarn=deprecations"]
    138 134 
               ]
    139 135 
         , builder Ghc
    140 136 
             ? package rts

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

  • testsuite/tests/diagnostic-codes/codes.stdout
    ... ... @@ -41,6 +41,7 @@
    41 41 
     [GHC-19971] is untested (constructor = DriverBackpackModuleNotFound)
    42 42 
     [GHC-37141] is untested (constructor = DriverCannotLoadInterfaceFile)
    43 43 
     [GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
    44 
    +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure)
    44 45 
     [GHC-06200] is untested (constructor = BlockedEquality)
    45 46 
     [GHC-81325] is untested (constructor = ExpectingMoreArguments)
    46 47 
     [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 Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/76276222f409d51bf5c0c5c4178af226eb8fb118 at 1793356067