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

Commits:

15 changed files:

Changes:

  • compiler/GHC/Driver/Errors/Ppr.hs
    ... ... @@ -282,6 +282,15 @@ instance Diagnostic DriverMessage where
    282 282 
           -> mkSimpleDecorated $
    283 283 
             vcat [ text "The following modules are missing a linkable which is needed for creating a library:"
    284 284 
                  , nest 2 $ hcat (map ppr mods) ]
    285 
    +    DriverSemaphoreVersionMismatch received supported
    286 
    +      -> mkSimpleDecorated $
    287 
    +        text "Semaphore version mismatch (received v" <> int received <>
    288 
    +        text ", this GHC supports v" <> int supported <>
    289 
    +        text "); ignoring -jsem and compiling sequentially."
    290 
    +    DriverSemaphoreOpenFailure reason
    291 
    +      -> mkSimpleDecorated $
    292 
    +        text "Failed to open -jsem semaphore:" <+> text reason <>
    293 
    +        text "; ignoring -jsem and compiling sequentially."
    285 294
    286 295 
       diagnosticReason = \case
    287 296 
         DriverUnknownMessage m
    ... ... @@ -355,6 +364,10 @@ instance Diagnostic DriverMessage where
    355 364 
           -> WarningWithoutFlag
    356 365 
         DriverMissingLinkableForModule {}
    357 366 
           -> ErrorWithoutFlag
    367 
    +    DriverSemaphoreVersionMismatch {}
    368 
    +      -> WarningWithFlag Opt_WarnSemaphoreVersionMismatch
    369 
    +    DriverSemaphoreOpenFailure {}
    370 
    +      -> WarningWithFlag Opt_WarnSemaphoreOpenFailure
    358 371
    359 372 
       diagnosticHints = \case
    360 373 
         DriverUnknownMessage m
    ... ... @@ -430,5 +443,14 @@ instance Diagnostic DriverMessage where
    430 443 
           -> noHints
    431 444 
         DriverMissingLinkableForModule {}
    432 445 
           -> noHints
    446 
    +    DriverSemaphoreVersionMismatch received _supported
    447 
    +      | received < _supported
    448 
    +      -> [UnknownHint (text "The parent process (e.g. cabal-install) uses an older semaphore protocol."
    449 
    +           $$ text "Upgrading cabal-install may resolve this." :: SDoc)]
    450 
    +      | otherwise
    451 
    +      -> [UnknownHint (text "The parent process (e.g. cabal-install) uses a newer semaphore protocol."
    452 
    +           $$ text "Upgrading GHC may resolve this." :: SDoc)]
    453 
    +    DriverSemaphoreOpenFailure {}
    454 
    +      -> noHints
    433 455
    434 456 
       diagnosticCode = constructorCode @GHC

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -419,6 +419,23 @@ data DriverMessage where
    419 419
    420 420 
       DriverMissingLinkableForModule :: ![Module] -> DriverMessage
    421 421
    422 
    +  {-| DriverSemaphoreVersionMismatch is a warning that occurs when GHC
    423 
    +      receives a @-jsem@ semaphore name whose protocol version is incompatible
    424 
    +      with the version this GHC supports.  GHC ignores @-jsem@ and compiles
    425 
    +      sequentially.
    426 
    +
    427 
    +      The first field is the received version (or 1 for unversioned names),
    428 
    +      the second is the version this GHC supports.
    429 
    +  -}
    430 
    +  DriverSemaphoreVersionMismatch :: !Int -> !Int -> DriverMessage
    431 
    +
    432 
    +  {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to
    433 
    +      open the semaphore specified by @-jsem@ (e.g. the socket does not exist
    434 
    +      or a system error occurred).  GHC ignores @-jsem@ and compiles
    435 
    +      sequentially.
    436 
    +  -}
    437 
    +  DriverSemaphoreOpenFailure :: !String -> DriverMessage
    438 
    +
    422 439 
     deriving instance Generic DriverMessage
    423 440
    424 441 
     data DriverMessageOpts =

  • compiler/GHC/Driver/Flags.hs
    ... ... @@ -1110,6 +1110,8 @@ data WarningFlag =
    1110 1110 
            -- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig
    1111 1111 
        | Opt_WarnUnusableUnpackPragmas                   -- Since 9.14
    1112 1112 
        | Opt_WarnPatternNamespaceSpecifier               -- Since 9.14
    1113 
    +   | Opt_WarnSemaphoreVersionMismatch               -- Since 10.0.1
    1114 
    +   | Opt_WarnSemaphoreOpenFailure                   -- Since 10.0.1
    1113 1115 
        deriving (Eq, Ord, Show, Enum, Bounded)
    1114 1116
    1115 1117 
     -- | Return the names of a WarningFlag
    ... ... @@ -1231,6 +1233,8 @@ warnFlagNames wflag = case wflag of
    1231 1233 
       Opt_WarnRuleLhsEqualities                       -> "rule-lhs-equalities" :| []
    1232 1234 
       Opt_WarnUnusableUnpackPragmas                   -> "unusable-unpack-pragmas" :| []
    1233 1235 
       Opt_WarnPatternNamespaceSpecifier               -> "pattern-namespace-specifier" :| []
    1236 
    +  Opt_WarnSemaphoreVersionMismatch               -> "semaphore-version-mismatch" :| []
    1237 
    +  Opt_WarnSemaphoreOpenFailure                   -> "semaphore-open-failure" :| []
    1234 1238
    1235 1239 
     -- -----------------------------------------------------------------------------
    1236 1240 
     -- Standard sets of warning options
    ... ... @@ -1376,7 +1380,9 @@ standardWarnings -- see Note [Documenting warning flags]
    1376 1380 
             Opt_WarnUselessSpecialisations,
    1377 1381 
             Opt_WarnDeprecatedPragmas,
    1378 1382 
             Opt_WarnRuleLhsEqualities,
    1379 
    -        Opt_WarnUnusableUnpackPragmas
    1383 
    +        Opt_WarnUnusableUnpackPragmas,
    1384 
    +        Opt_WarnSemaphoreVersionMismatch,
    1385 
    +        Opt_WarnSemaphoreOpenFailure
    1380 1386 
           ]
    1381 1387
    1382 1388 
     -- | Things you get with @-W@.

  • compiler/GHC/Driver/MakeAction.hs
    ... ... @@ -28,6 +28,16 @@ import GHC.Driver.Errors.Types
    28 28 
     import GHC.Driver.Messager
    29 29 
     import GHC.Driver.MakeSem
    30 30
    31 
    +import System.Semaphore
    32 
    +  ( SemaphoreError(..)
    33 
    +  , semaphoreVersion, versionsAreCompatible, parseSemaphoreName )
    34 
    +
    35 
    +import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig )
    36 
    +import GHC.Driver.Errors ( printOrThrowDiagnostics )
    37 
    +import GHC.Driver.Errors.Types ( DriverMessage(..), GhcMessage(..) )
    38 
    +import GHC.Types.Error ( singleMessage )
    39 
    +import GHC.Types.SrcLoc ( noSrcSpan )
    40 
    +import GHC.Utils.Error ( mkPlainMsgEnvelope )
    31 41 
     import GHC.Utils.Logger
    32 42 
     import GHC.Utils.TmpFs
    33 43
    ... ... @@ -122,17 +132,34 @@ runNjobsAbstractSem n_jobs action = do
    122 132 
         resetNumCapabilities = set_num_caps n_capabilities
    123 133 
       MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
    124 134
    125 
    -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
    135 
    +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
    126 136 
     #if defined(wasm32_HOST_ARCH)
    127 
    -runWorkerLimit _ action = do
    137 
    +runWorkerLimit _logger _dflags _ action = do
    128 138 
       lock <- newMVar ()
    129 139 
       action $ AbstractSem (takeMVar lock) (putMVar lock ())
    130 140 
     #else
    131 
    -runWorkerLimit worker_limit action = case worker_limit of
    141 
    +runWorkerLimit logger dflags worker_limit action = case worker_limit of
    132 142 
         NumProcessorsLimit n_jobs ->
    133 143 
           runNjobsAbstractSem n_jobs action
    134 144 
         JSemLimit sem ->
    135 
    -      runJSemAbstractSem sem action
    145 
    +      let received_ver = case parseSemaphoreName (getSemaphoreName sem) of
    146 
    +            Just (ver, _) -> ver
    147 
    +            Nothing       -> 1
    148 
    +      in if versionsAreCompatible received_ver semaphoreVersion
    149 
    +         then do
    150 
    +           result <- MC.try $ runJSemAbstractSem sem action
    151 
    +           case result of
    152 
    +             Right a -> return a
    153 
    +             Left (err :: SemaphoreError) -> do
    154 
    +               let diag = DriverSemaphoreOpenFailure (show err)
    155 
    +                   msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    156 
    +               printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    157 
    +               runNjobsAbstractSem 1 action
    158 
    +         else do
    159 
    +           let diag = DriverSemaphoreVersionMismatch received_ver semaphoreVersion
    160 
    +               msg  = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag
    161 
    +           printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg)
    162 
    +           runNjobsAbstractSem 1 action
    136 163 
     #endif
    137 164
    138 165 
     -- | Build and run a pipeline
    ... ... @@ -159,7 +186,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
    159 186 
       thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
    160 187 
       let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
    161 188
    162 
    -  runWorkerLimit worker_limit $ \abstract_sem -> do
    189 
    +  runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do
    163 190 
         let env = MakeEnv { hsc_env = thread_safe_hsc_env
    164 191 
                           , withLogger = withParLog log_queue_queue_var
    165 192 
                           , compile_sem = abstract_sem

  • compiler/GHC/Driver/MakeSem.hs
    ... ... @@ -439,7 +439,7 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
    439 439 
     -- | Create a new jobserver using the given semaphore handle.
    440 440 
     makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
    441 441 
     makeJobserver sem_name = do
    442 
    -  semaphore <- openSemaphore sem_name
    442 
    +  semaphore <- openSemaphore sem_name >>= either MC.throwM pure
    443 443 
       let
    444 444 
         init_jobs =
    445 445 
           Jobs { tokensOwned = 1

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

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

  • docs/users_guide/using-warnings.rst
    ... ... @@ -2706,6 +2706,37 @@ of ``-W(no-)*``.
    2706 2706
    2707 2707 
             import Data.List.NonEmpty (data (:|))
    2708 2708
    2709 
    +.. ghc-flag:: -Wsemaphore-version-mismatch
    2710 
    +    :shortdesc: warn when GHC receives a ``-jsem`` semaphore whose protocol
    2711 
    +        version is incompatible with the version this GHC supports.
    2712 
    +    :type: dynamic
    2713 
    +    :reverse: -Wno-semaphore-version-mismatch
    2714 
    +    :category:
    2715 
    +
    2716 
    +    :since: 10.0.1
    2717 
    +
    2718 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2719 
    +    name indicates a protocol version that is incompatible with this GHC
    2720 
    +    (e.g. an unversioned v1 name passed to a v2 GHC, or vice versa).
    2721 
    +    When this occurs, GHC ignores ``-jsem`` and compiles modules sequentially.
    2722 
    +
    2723 
    +    This situation typically arises when ``cabal-install`` and GHC are built
    2724 
    +    against different versions of the ``semaphore-compat`` library.  Upgrading
    2725 
    +    both to versions that use the same protocol resolves the mismatch.
    2726 
    +
    2727 
    +.. ghc-flag:: -Wsemaphore-open-failure
    2728 
    +    :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore.
    2729 
    +    :type: dynamic
    2730 
    +    :reverse: -Wno-semaphore-open-failure
    2731 
    +    :category:
    2732 
    +
    2733 
    +    :since: 10.0.1
    2734 
    +
    2735 
    +    Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore
    2736 
    +    cannot be opened (e.g. the socket does not exist or a system error
    2737 
    +    occurred).  When this occurs, GHC ignores ``-jsem`` and compiles
    2738 
    +    modules sequentially.
    2739 
    +
    2709 2740 
     ----
    2710 2741
    2711 2742 
     If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.

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

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

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

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

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

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

  • libraries/semaphore-compat
    1 
    -Subproject commit ba87d1bb0209bd9f29bda1c878ddf345f8a2b199
    1 
    +Subproject commit e67d577b50b6630c589be188fcaf86b58629d782

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