May 2026 - ghc-commits

[Git][ghc/ghc] Deleted branch wip/sjakobi/T23414
by Simon Jakobi (＠sjakobi) 26 May '26

26 May '26

Simon Jakobi deleted branch wip/sjakobi/T23414 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 5 commits: fix tests to do with imports and api
by Rodrigo Mesquita (＠alt-romes) 26 May '26

26 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 7e982905 by Rodrigo Mesquita at 2026-05-25T13:57:58+01:00 fix tests to do with imports and api - - - - - 72c06a5e by Rodrigo Mesquita at 2026-05-25T13:59:01+01:00 fix bco assembler perf test - - - - - 55b51547 by Rodrigo Mesquita at 2026-05-25T14:01:24+01:00 accept more re-ordering uniques - - - - - 3e47049d by Rodrigo Mesquita at 2026-05-25T16:15:45+01:00 more test outputs - - - - - 989b38cb by Rodrigo Mesquita at 2026-05-26T11:48:29+01:00 accept wildcard ppr changes root cause: ```diff nlWildConPat :: DataCon -> LPat GhcPs +-- The pattern (K {}) nlWildConPat con = noLocA $ ConPat { pat_con_ext = noAnn , pat_con = noLocA $ getRdrName con - , pat_args = PrefixCon $ - replicate (dataConSourceArity con) - nlWildPat + , pat_args = RecCon $ HsRecFields + { rec_ext = noExtField + , rec_flds = [] + , rec_dotdot = Nothing } } ``` OK, that's better. - - - - - 53 changed files: - testsuite/tests/ado/T13242a.stderr - testsuite/tests/annotations/should_fail/annfail10.stderr - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/corelint/LintEtaExpand.hs - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/deriving/should_compile/T20496.stderr - testsuite/tests/ghc-api/T8628.hs - testsuite/tests/hiefile/should_run/T23120.stdout - testsuite/tests/iface/IfaceSharingIfaceType.hs - testsuite/tests/iface/IfaceSharingName.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/javascript/T24495.hs - testsuite/tests/perf/should_run/ByteCodeAsm.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs - testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs - testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/simple-plugin/Simple/ReplacePlugin.hs - testsuite/tests/plugins/static-plugins.stdout - testsuite/tests/simplCore/should_compile/T16038/T16038.stdout - testsuite/tests/simplCore/should_compile/str-rules.hs - testsuite/tests/tcplugins/ArgsPlugin.hs - testsuite/tests/tcplugins/EmitWantedPlugin.hs - testsuite/tests/tcplugins/RewritePlugin.hs - testsuite/tests/tcplugins/T26395_Plugin.hs - testsuite/tests/tcplugins/TyFamPlugin.hs - testsuite/tests/th/T14741.hs - testsuite/tests/th/T21547.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T12921.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T15883b.stderr - testsuite/tests/typecheck/should_fail/T15883c.stderr - testsuite/tests/typecheck/should_fail/T15883d.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T5095.stderr - testsuite/tests/typecheck/should_fail/T7279.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_PatternBindingExistential.stderr - testsuite/tests/typecheck/should_fail/tcfail072.stderr - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/typecheck/should_fail/tcfail133.stderr - testsuite/tests/typecheck/should_run/T22510.stdout - testsuite/tests/unboxedsums/unboxedsums_unit_tests.hs - testsuite/tests/warnings/should_compile/DerivingTypeable.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a36be5129e3164182bcc87c1f5a546… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a36be5129e3164182bcc87c1f5a546… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/multi-caret] Hack: Carry diagnostic related spans through MessageClass
by Simon Jakobi (＠sjakobi2) 26 May '26

26 May '26

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: b8806c7d by Simon Jakobi at 2026-05-26T12:41:25+02:00 Hack: Carry diagnostic related spans through MessageClass - - - - - 8 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -369,7 +369,7 @@ msg msg_class doc = do loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx let sty = case msg_class of - MCDiagnostic _ _ _ -> err_sty + MCDiagnostic _ _ _ _ -> err_sty MCDump -> dump_sty _ -> user_sty err_sty = mkErrStyle name_ppr_ctx ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -58,7 +58,7 @@ printMessage logger msg_opts opts message logJsonMsg logger messageClass jsonMessage - | otherwise = logMsg (pushLogHook renderWithSourceSpans logger) messageClass location doc + | otherwise = logMsg logger messageClass location doc where logflags :: LogFlags logflags = logFlags logger @@ -67,7 +67,7 @@ printMessage logger msg_opts opts message doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) messageClass :: MessageClass - messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) + messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) relatedSpans style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -81,21 +81,15 @@ printMessage logger msg_opts opts message diagnostic :: a diagnostic = errMsgDiagnostic message + relatedSpans :: [SrcSpan] + relatedSpans = diagnosticRelatedLocations diagnostic + sourceSpans :: NonEmpty SrcSpan - sourceSpans = location :| diagnosticRelatedLocations diagnostic + sourceSpans = location :| relatedSpans severity :: Severity severity = errMsgSeverity message - renderWithSourceSpans :: LogAction -> LogAction - renderWithSourceSpans fallback logflags' msg_class' srcSpan' msg' = - case msg_class' of - MCDiagnostic _ _ _ -> do - decorated <- decorateDiagnostic logflags' msg_class' srcSpan' sourceSpans msg' - fallback logflags' MCInfo noSrcSpan decorated - _ -> - fallback logflags' msg_class' srcSpan' msg' - messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1426,9 +1426,9 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msgClass !srcSpan !msg = do let action = logMsg logger msgClass srcSpan msg case msgClass of - MCDiagnostic SevWarning _reason _code + MCDiagnostic SevWarning _reason _code _relatedSpans -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code + MCDiagnostic SevError _reason _code _relatedSpans -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) MCFatal -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -491,7 +491,7 @@ data MessageClass -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) [SrcSpan] -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -505,6 +505,9 @@ data MessageClass -- this diagnostic. If you are creating a message not tied to any -- error-message type, then use Nothing. In the long run, this really -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. + -- + -- The list of 'SrcSpan's carries additional locations related to the + -- diagnostic. The primary location is supplied separately to the 'LogAction'. {- Note [Suppressing Messages] @@ -564,7 +567,7 @@ instance ToJson MessageClass where json MCInteractive = JSString "MCInteractive" json MCDump = JSString "MCDump" json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason code) = + json (MCDiagnostic sev reason code _) = JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) instance ToJson DiagnosticCode where @@ -658,7 +661,7 @@ mkLocMessageWarningGroups -> SDoc mkLocMessageWarningGroups show_warn_groups msg_class locn msg = case msg_class of - MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg + MCDiagnostic severity reason code _ -> formatDiagnostic show_warn_groups locn severity reason code msg _ -> sdocOption sdocColScheme $ \col_scheme -> let msg_colour = getMessageClassColour msg_class col_scheme @@ -783,7 +786,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg msg) getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity +getMessageClassColour (MCDiagnostic severity _reason _code _) = getSeverityColour severity getMessageClassColour MCFatal = Col.sFatal getMessageClassColour _ = const mempty ===================================== compiler/GHC/Types/Error.hs-boot ===================================== @@ -10,7 +10,7 @@ data MessageClass | MCInteractive | MCDump | MCInfo - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) [SrcSpan] data Severity = SevIgnore ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -287,7 +287,7 @@ pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ mkLocMessage - (MCDiagnostic sev reason (diagnosticCode e)) + (MCDiagnostic sev reason (diagnosticCode e) (diagnosticRelatedLocations e)) s (formatBulleted $ diagnosticMessage opts e) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -370,8 +370,8 @@ defaultLogJsonAction logflags msg_class jsdoc = MCInteractive -> putStrSDoc msg MCInfo -> printErrs msg MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printErrs msg + MCDiagnostic SevIgnore _ _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code _ -> printErrs msg where printOut = defaultLogActionHPrintDoc logflags False stdout printErrs = defaultLogActionHPrintDoc logflags False stderr @@ -381,7 +381,7 @@ defaultLogJsonAction logflags msg_class jsdoc = -- See Note [JSON Error Messages] -- this is to be removed jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message +jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _ _) _ _ = return () -- suppress the message jsonLogActionWithHandle out logflags msg_class srcSpan msg = defaultLogActionHPutStrDoc logflags True out @@ -423,9 +423,9 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInteractive -> putStrSDoc msg MCInfo -> printErrs msg MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> - decorateDiagnostic logflags msg_class srcSpan (srcSpan :| []) msg >>= printErrs + MCDiagnostic SevIgnore _ _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code relatedSpans -> + decorateDiagnostic logflags msg_class srcSpan (srcSpan :| relatedSpans) msg >>= printErrs where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err ===================================== ghc/GHCi/UI.hs ===================================== @@ -914,7 +914,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg_class srcSpan msg = do old_log_action dflags msg_class srcSpan msg case msg_class of - MCDiagnostic SevError _reason _code -> case srcSpan of + MCDiagnostic SevError _reason _code _relatedSpans -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8806c7da29c8ab8147b3c49750d5c0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8806c7da29c8ab8147b3c49750d5c0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] EPA: Record semicolons in HsModifier
by Marge Bot (＠marge-bot) 26 May '26

26 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 17be4f1f by Alan Zimmerman at 2026-05-26T04:54:52-04:00 EPA: Record semicolons in HsModifier Ensure the semi colons are captured in the ParsedSource for code like %True;; %False; instance C D It makes HsModifier (and hence HsModifierOf) LocatedA, so the semi colons can be recorded as [TrailingAnn] Also rename pprHsModifiers to pprLHsModifiers to match. Closes #27294 - - - - - 33 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/Language/Haskell/Syntax/Type.hs - testsuite/tests/printer/PprModifiers.hs - utils/check-exact/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17be4f1f6be288a03c87778797964cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17be4f1f6be288a03c87778797964cd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Marge Bot (＠marge-bot) 26 May '26

26 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8db331a3 by Zubin Duggal at 2026-05-26T04:54:03-04:00 Update to semaphore-compat 2.0.0 using v2 of the protocol On Linux and other POSIX platforms, GHC's -jsem jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix domain sockets in place of POSIX named semaphores. This avoids the libc-ABI issues that affected the old implementation. Windows is unaffected and continues to use the v1 protocol (Win32 named semaphores); its reported protocol version remains v1. When GHC receives a -jsem name whose protocol version it does not support, it emits a -Wsemaphore-version-mismatch warning and falls back to -j<N> rather than crashing. ghc --info exposes the supported version in a new "Semaphore version" entry so cabal-install can detect a mismatch before invoking GHC. Users on a cabal-install that predates the v2 update will continue to build successfully on Linux/POSIX, but will lose the cross-process -jsem coordination and fall back to -j<N> per GHC invocation. Users must upgrade to a cabal-install that supports protocol v2 to recover full parallelism. Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot heldTokens and release them before killing the loop, while the loop's in-flight acquire/release children could still be mutating it. Cleanup now runs inside the loop's own exit handler, after draining the active child via a new activeChild TVar, so the snapshot has no concurrent mutator. See also: - GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673 - cabal-install patch: https://github.com/haskell/cabal/pull/11628 - semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8 Bump semaphore-compat submodule to 2.0.0 Fixes #25087 and #27253 - - - - - 16 changed files: - + changelog.d/jobserver-leak-fix - + changelog.d/semaphore-v2 - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Flavour.hs - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout Changes: ===================================== changelog.d/jobserver-leak-fix ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27253 +mrs: !15729 +synopsis: + Fix a token leak in the ``-jsem`` jobserver shutdown path +description: + A build interrupted by Ctrl-C while a ``-jsem`` token transfer was in + flight could leak that token. ===================================== changelog.d/semaphore-v2 ===================================== @@ -0,0 +1,30 @@ +section: compiler +issues: #25087 +mrs: !15729 +synopsis: + Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2) +description: + On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client + now speaks v2 of the semaphore-compat protocol, which uses Unix + domain sockets in place of POSIX named semaphores. This avoids the + libc-ABI issues that affected the old implementation. Windows is + unaffected and continues to use the v1 protocol (Win32 named + semaphores); its reported protocol version remains v1. + + When GHC receives a ``-jsem`` name whose protocol version it does not + support, it now emits a ``-Wsemaphore-version-mismatch`` warning and + falls back to ``-j1`` rather than crashing. ``ghc --info`` exposes the + supported version in a new ``"Semaphore version"`` entry so + cabal-install can detect a mismatch before invoking GHC. + + Users on a ``cabal-install`` that predates the v2 update will continue + to build successfully, but on Linux/POSIX will lose the cross-process + ``-jsem`` coordination and fall back to ``-j1`` per GHC invocation. + To recover full parallelism, upgrade to a ``cabal-install`` that + supports protocol v2. + + See also: + + - the `GHC proposal amendment <https://github.com/ghc-proposals/ghc-proposals/pull/673>`_ + - the `cabal-install patch <https://github.com/haskell/cabal/pull/11628>`_ + - the `semaphore-compat library MR <https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8>`_ ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -24,6 +24,8 @@ import GHC.Types.Hint import GHC.Types.SrcLoc import Data.Version +import System.Semaphore + ( SemaphoreError(..), getSemaphoreProtocolVersion ) import Language.Haskell.Syntax.Decls (RuleDecl(..)) import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) @@ -90,6 +92,20 @@ instance Diagnostic GhcMessage where instance HasDefaultDiagnosticOpts DriverMessageOpts where defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) +pprSemaphoreError :: SemaphoreError -> SDoc +pprSemaphoreError = \case + SemaphoreAlreadyExists nm -> + text "a semaphore named" <+> quotes (text nm) <+> text "already exists" + SemaphoreDoesNotExist nm -> + text "no semaphore named" <+> quotes (text nm) + SemaphoreIncompatibleVersion got want -> + text "protocol version mismatch (got v" + <> int (getSemaphoreProtocolVersion got) + <> text ", supported v" + <> int (getSemaphoreProtocolVersion want) <> text ")" + SemaphoreOtherError ioe -> + text (show ioe) + instance Diagnostic DriverMessage where type DiagnosticOpts DriverMessage = DriverMessageOpts diagnosticMessage opts = \case @@ -282,6 +298,10 @@ instance Diagnostic DriverMessage where -> mkSimpleDecorated $ vcat [ text "The following modules are missing a linkable which is needed for creating a library:" , nest 2 $ hcat (map ppr mods) ] + DriverSemaphoreOpenFailure _ err + -> mkSimpleDecorated $ + text "Failed to open -jsem semaphore:" <+> pprSemaphoreError err <> + text "; ignoring -jsem and compiling sequentially." diagnosticReason = \case DriverUnknownMessage m @@ -355,6 +375,8 @@ instance Diagnostic DriverMessage where -> WarningWithoutFlag DriverMissingLinkableForModule {} -> ErrorWithoutFlag + DriverSemaphoreOpenFailure {} + -> WarningWithFlag Opt_WarnSemaphoreOpenFailure diagnosticHints = \case DriverUnknownMessage m @@ -430,5 +452,19 @@ instance Diagnostic DriverMessage where -> noHints DriverMissingLinkableForModule {} -> noHints + DriverSemaphoreOpenFailure buildingCabal (SemaphoreIncompatibleVersion received supported) + | received < supported + -> let required = getSemaphoreProtocolVersion supported + target = case buildingCabal of + YesBuildingCabalPackage -> UpgradeCabalInstall + NoBuildingCabalPackage -> UpgradeJobserver + in [SuggestUpgradeForSemaphoreVersionMismatch target required] + | received > supported + -> [SuggestUpgradeForSemaphoreVersionMismatch + UpgradeGHC (getSemaphoreProtocolVersion received)] + | otherwise + -> noHints + DriverSemaphoreOpenFailure {} + -> noHints diagnosticCode = constructorCode @GHC ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -37,6 +37,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Generics ( Generic ) +import System.Semaphore ( SemaphoreError ) import GHC.Tc.Errors.Types import GHC.Iface.Errors.Types @@ -419,6 +420,17 @@ data DriverMessage where DriverMissingLinkableForModule :: ![Module] -> DriverMessage + {-| DriverSemaphoreOpenFailure is a warning that occurs when GHC fails to + open the semaphore specified by @-jsem@, e.g. the socket does not + exist, the protocol version is incompatible, or a system error + occurred. GHC ignores @-jsem@ and compiles sequentially. + + The 'BuildingCabalPackage' flag controls whether the diagnostic + hint suggests upgrading @cabal-install@ (it only does so when GHC + is invoked by Cabal). + -} + DriverSemaphoreOpenFailure :: !BuildingCabalPackage -> !SemaphoreError -> DriverMessage + deriving instance Generic DriverMessage data DriverMessageOpts = ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1115,6 +1115,7 @@ data WarningFlag = | Opt_WarnUnusableUnpackPragmas -- ^ @since 9.14 | Opt_WarnPatternNamespaceSpecifier -- ^ @since 9.14 | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 + | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1237,6 +1238,7 @@ warnFlagNames wflag = case wflag of Opt_WarnUnusableUnpackPragmas -> "unusable-unpack-pragmas" :| [] Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| [] Opt_WarnUnrecognisedModifiers -> "unrecognised-modifiers" :| [] + Opt_WarnSemaphoreOpenFailure -> "semaphore-open-failure" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options @@ -1383,7 +1385,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnDeprecatedPragmas, Opt_WarnRuleLhsEqualities, Opt_WarnUnusableUnpackPragmas, - Opt_WarnUnrecognisedModifiers + Opt_WarnUnrecognisedModifiers, + Opt_WarnSemaphoreOpenFailure ] -- | Things you get with @-W@. ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -28,16 +28,39 @@ import GHC.Driver.Errors.Types import GHC.Driver.Messager import GHC.Driver.MakeSem +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import System.Semaphore + ( SemaphoreIdentifier ) +#else +import System.Semaphore + ( SemaphoreError, SemaphoreIdentifier ) +#endif + +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) +import GHC.Driver.Config.Diagnostic ( initDiagOpts, initPrintConfig ) +import GHC.Driver.Errors ( printOrThrowDiagnostics ) +import GHC.Types.Error ( singleMessage ) +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Utils.Error ( mkPlainMsgEnvelope ) +#endif import GHC.Utils.Logger import GHC.Utils.TmpFs +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import Control.Concurrent ( ThreadId, killThread, forkIOWithUnmask ) +#else import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) +#endif import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Monad import qualified Control.Monad.Catch as MC +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +import GHC.Conc ( getNumProcessors ) +#else import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +#endif import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.LogQueue import Control.Concurrent.STM @@ -49,7 +72,7 @@ mkWorkerLimit :: DynFlags -> IO WorkerLimit mkWorkerLimit dflags = case parMakeCount dflags of Nothing -> pure $ num_procs 1 - Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) + Just (ParMakeSemaphore h) -> pure (JSemLimit h) Just ParMakeNumProcessors -> num_procs <$> getNumProcessors Just (ParMakeThisMany n) -> pure $ num_procs n where @@ -65,8 +88,8 @@ isWorkerLimitSequential (JSemLimit {}) = False data WorkerLimit = NumProcessorsLimit Int | JSemLimit - SemaphoreName - -- ^ Semaphore name to use + SemaphoreIdentifier + -- ^ Semaphore identifier from @-jsem@ deriving Eq -- | Environment used when compiling a module @@ -106,6 +129,7 @@ runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = } in runAllPipelines (NumProcessorsLimit 1) env all_pipelines +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a runNjobsAbstractSem n_jobs action = do compile_sem <- newQSem n_jobs @@ -122,17 +146,26 @@ runNjobsAbstractSem n_jobs action = do resetNumCapabilities = set_num_caps n_capabilities MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a -#if defined(wasm32_HOST_ARCH) -runWorkerLimit _ action = do +#endif + +runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) +runWorkerLimit _logger _dflags _ action = do lock <- newMVar () action $ AbstractSem (takeMVar lock) (putMVar lock ()) #else -runWorkerLimit worker_limit action = case worker_limit of +runWorkerLimit logger dflags worker_limit action = case worker_limit of NumProcessorsLimit n_jobs -> runNjobsAbstractSem n_jobs action - JSemLimit sem -> - runJSemAbstractSem sem action + JSemLimit sem_ident -> do + result <- MC.try @_ @SemaphoreError $ runJSemAbstractSem sem_ident action + case result of + Right a -> return a + Left err -> do + let diag = DriverSemaphoreOpenFailure (checkBuildingCabalPackage dflags) err + msg = singleMessage $ mkPlainMsgEnvelope (initDiagOpts dflags) noSrcSpan diag + printOrThrowDiagnostics logger (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> msg) + runNjobsAbstractSem 1 action #endif -- | Build and run a pipeline @@ -159,7 +192,7 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } - runWorkerLimit worker_limit $ \abstract_sem -> do + runWorkerLimit (hsc_logger plugin_hsc_env) (hsc_dflags plugin_hsc_env) worker_limit $ \abstract_sem -> do let env = MakeEnv { hsc_env = thread_safe_hsc_env , withLogger = withParLog log_queue_queue_var , compile_sem = abstract_sem @@ -245,4 +278,4 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () -waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar \ No newline at end of file +waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Driver/MakeSem.hs ===================================== @@ -1,23 +1,33 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | Implementation of a jobserver using system semaphores. -- -- module GHC.Driver.MakeSem - ( -- * JSem: parallelism semaphore backed + ( +#if !(defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)) + -- * JSem: parallelism semaphore backed -- by a system semaphore (Posix/Windows) - runJSemAbstractSem - - -- * System semaphores - , Semaphore, SemaphoreName(..) + runJSemAbstractSem, +#endif -- * Abstract semaphores - , AbstractSem(..) + AbstractSem(..) , withAbstractSem ) where +#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH) + +import System.Semaphore + ( AbstractSem(..) + , withAbstractSem + ) + +#else + import GHC.Prelude import GHC.Conc import GHC.Data.OrdList @@ -27,6 +37,15 @@ import GHC.Utils.Panic import GHC.Utils.Json import System.Semaphore + ( AbstractSem(..) + , ClientSemaphore + , SemaphoreIdentifier + , SemaphoreToken + , openSemaphore + , releaseSemaphoreToken + , waitOnSemaphore + , withAbstractSem + ) import Control.Monad import qualified Control.Monad.Catch as MC @@ -46,11 +65,14 @@ import Debug.Trace -- available from the semaphore. data Jobserver = Jobserver - { jSemaphore :: !Semaphore + { jSemaphore :: !ClientSemaphore -- ^ The semaphore which controls available resources , jobs :: !(TVar JobResources) -- ^ The currently pending jobs, and the resources -- obtained from the semaphore + , activeChild :: !(TVar (Maybe (ThreadId, TMVar (Maybe MC.SomeException)))) + -- ^ Handle on the current acquire thread (if any). The loop's exit + -- handler reads this to drain a still-running child on shutdown. } data JobserverOptions @@ -81,6 +103,9 @@ data JobResources , jobsWaiting :: !(OrdList (TMVar ())) -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into -- the TMVar will allow the job to continue. + , heldTokens :: [SemaphoreToken] + -- ^ Actual semaphore tokens (for release/cleanup). + -- Length should equal tokensOwned - 1 (the implicit token has no SemaphoreToken). } instance Outputable JobResources where @@ -93,9 +118,9 @@ instance Outputable JobResources where ] ) -- | Add one new token. -addToken :: JobResources -> JobResources -addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free }) - = jobs { tokensOwned = owned + 1, tokensFree = free + 1 } +addToken :: SemaphoreToken -> JobResources -> JobResources +addToken tok jobs@( Jobs { tokensOwned = owned, tokensFree = free, heldTokens = toks }) + = jobs { tokensOwned = owned + 1, tokensFree = free + 1, heldTokens = tok : toks } -- | Free one token. addFreeToken :: JobResources -> JobResources @@ -111,12 +136,14 @@ removeFreeToken jobs@( Jobs { tokensFree = free }) (text "removeFreeToken:" <+> ppr free) $ jobs { tokensFree = free - 1 } --- | Return one owned token. -removeOwnedToken :: JobResources -> JobResources -removeOwnedToken jobs@( Jobs { tokensOwned = owned }) +-- | Return one owned token, extracting the 'SemaphoreToken' for release. +removeOwnedToken :: JobResources -> (SemaphoreToken, JobResources) +removeOwnedToken jobs@( Jobs { tokensOwned = owned, heldTokens = toks }) = assertPpr (owned > 1) (text "removeOwnedToken:" <+> ppr owned) - $ jobs { tokensOwned = owned - 1 } + $ case toks of + (t:rest) -> (t, jobs { tokensOwned = owned - 1, heldTokens = rest }) + [] -> panic "removeOwnedToken: no held tokens" -- | Add one new job to the end of the list of pending jobs. addJob :: TMVar () -> JobResources -> JobResources @@ -143,7 +170,7 @@ data JobserverAction = Idle -- | A thread is waiting for a token on the semaphore. | Acquiring - { activeWaitId :: WaitId + { activeThreadId :: ThreadId , threadFinished :: TMVar (Maybe MC.SomeException) } -- | Retrieve the 'TMVar' that signals if the current thread has finished, @@ -189,17 +216,30 @@ releaseJob jobs_tvar = do return ((), addFreeToken jobs) --- | Release all tokens owned from the semaphore (to clean up --- the jobserver at the end). -cleanupJobserver :: Jobserver -> IO () -cleanupJobserver (Jobserver { jSemaphore = sem - , jobs = jobs_tvar }) - = do - Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar - let toks_to_release = owned - 1 - -- Subtract off the implicit token: whoever spawned the ghc process - -- in the first place is responsible for that token. - releaseSemaphore sem toks_to_release +-- | Kill the current acquire thread, if any, and wait for it to exit. +-- +-- Called from the jobserver loop's exit handler, which runs masked. +-- Relies on the invariant from 'acquireThread' that a forked child +-- always fills its 'threadFinished' TMVar before it dies; this is what +-- lets the 'takeTMVar' below terminate after the 'killThread'. +drainActiveChild :: Jobserver -> IO () +drainActiveChild (Jobserver { activeChild = active_tvar }) = do + mb <- readTVarIO active_tvar + for_ mb $ \(tid, tmv) -> do + killThread tid + void $ atomically (takeTMVar tmv) + atomically $ writeTVar active_tvar Nothing + +-- | Release every token currently in 'heldTokens'. +-- +-- Called from the jobserver loop's exit handler, which runs masked, +-- after 'drainActiveChild': no other thread is mutating 'JobResources' +-- at this point. +releaseAllHeld :: Jobserver -> IO () +releaseAllHeld (Jobserver { jobs = jobs_tvar }) = do + Jobs { heldTokens = toks } <- readTVarIO jobs_tvar + forM_ toks $ \t -> + void $ MC.try @_ @MC.SomeException (releaseSemaphoreToken t) -- | Dispatch the available tokens acquired from the semaphore -- to the pending jobs in the job server. @@ -252,7 +292,7 @@ tracedAtomically origin act = do return a renderJobResources :: String -> JobResources -> String -renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $ +renderJobResources origin (Jobs own free pending _heldToks) = showSDocUnsafe $ renderJSON $ JSObject [ ("name", JSString origin) , ("owned", JSInt own) , ("free", JSInt free) @@ -262,61 +302,68 @@ renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON -- | Spawn a new thread that waits on the semaphore in order to acquire -- an additional token. +-- +-- The child is forked masked so the only async-exception delivery point +-- is the interruptible 'waitOnSemaphore'; the STM commit afterwards then +-- always runs to completion, so 'threadFinished' is always filled. +-- +-- The (tid, threadFinished) pair is also published to 'activeChild' so +-- shutdown can drain the child even after the in-loop 'JobserverState' +-- is gone. acquireThread :: Jobserver -> IO JobserverAction -acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar, activeChild = active_tvar }) = do threadFinished_tmvar <- newEmptyTMVarIO - let - wait_result_action :: Either MC.SomeException Bool -> IO () - wait_result_action wait_res = + tid <- MC.mask_ $ do + tid <- forkIO $ do + wait_res <- MC.try @_ @MC.SomeException $ waitOnSemaphore sem tracedAtomically_ "acquire_thread" do (r, jb) <- case wait_res of Left (e :: MC.SomeException) -> do return $ (Just e, Nothing) - Right success -> do - if success - then do - modifyJobResources jobs_tvar \ jobs -> - return (Nothing, addToken jobs) - else - return (Nothing, Nothing) + Right tok -> do + modifyJobResources jobs_tvar \ jobs -> + return (Nothing, addToken tok jobs) putTMVar threadFinished_tmvar r return jb - wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action - labelThread (waitingThreadId wait_id) "acquire_thread" - return $ Acquiring { activeWaitId = wait_id + atomically $ writeTVar active_tvar (Just (tid, threadFinished_tmvar)) + return tid + labelThread tid "acquire_thread" + return $ Acquiring { activeThreadId = tid , threadFinished = threadFinished_tmvar } -- | Spawn a thread to release ownership of one resource from the semaphore, -- provided we have spare resources and no pending jobs. releaseThread :: Jobserver -> IO JobserverAction -releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do +releaseThread (Jobserver { jobs = jobs_tvar }) = do threadFinished_tmvar <- newEmptyTMVarIO MC.mask_ do -- Pre-release the resource so that another thread doesn't take control of it -- just as we release the lock on the semaphore. - still_ok_to_release + mb_tok <- tracedAtomically "pre_release" $ modifyJobResources jobs_tvar \ jobs -> if guardRelease jobs - -- TODO: should this also debounce? - then return (True , removeOwnedToken $ removeFreeToken jobs) - else return (False, jobs) - if not still_ok_to_release - then return Idle - else do - tid <- forkIO $ do - x <- MC.try $ releaseSemaphore sem 1 - tracedAtomically_ "post-release" $ do - (r, jobs) <- case x of - Left (e :: MC.SomeException) -> do - modifyJobResources jobs_tvar \ jobs -> - return (Just e, addToken jobs) - Right _ -> do - return (Nothing, Nothing) - putTMVar threadFinished_tmvar r - return jobs - labelThread tid "release_thread" - return Idle + then let (tok, jobs') = removeOwnedToken $ removeFreeToken jobs + in return (Just tok, jobs') + else return (Nothing, jobs) + case mb_tok of + Nothing -> + -- Not OK to release: there are other pending jobs that could make use of the token. + return Idle + Just tok -> do + tid <- forkIO $ do + x <- MC.try @_ @MC.SomeException $ releaseSemaphoreToken tok + tracedAtomically_ "post-release" $ do + (r, jobs) <- case x of + Left (e :: MC.SomeException) -> do + modifyJobResources jobs_tvar \ jobs -> + return (Just e, addToken tok jobs) + Right _ -> do + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jobs + labelThread tid "release_thread" + return Idle -- | When there are pending jobs but no free tokens, -- spawn a thread to acquire a new token from the semaphore. @@ -363,13 +410,14 @@ tryRelease _ _ = retry -- | Wait for an active thread to finish. Once it finishes: -- -- - set the 'JobserverAction' to 'Idle', +-- - clear the 'activeChild' handle, -- - update the number of capabilities to reflect the number -- of owned tokens from the semaphore. tryNoticeIdle :: JobserverOptions - -> TVar JobResources + -> Jobserver -> JobserverState -> STM (IO JobserverState) -tryNoticeIdle opts jobs_tvar jobserver_state +tryNoticeIdle opts (Jobserver { jobs = jobs_tvar, activeChild = active_tvar }) jobserver_state | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar | otherwise @@ -381,6 +429,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do mb_ex <- takeTMVar threadFinished_tmvar for_ mb_ex MC.throwM + writeTVar active_tvar Nothing Jobs { tokensOwned } <- readTVar jobs_tvar can_change_numcaps <- readTVar can_change_numcaps_tvar guard can_change_numcaps @@ -404,11 +453,11 @@ tryStopThread :: TVar JobResources -> STM (IO JobserverState) tryStopThread jobs_tvar jsj = do case jobserverAction jsj of - Acquiring { activeWaitId = wait_id } -> do + Acquiring { activeThreadId = tid } -> do jobs <- readTVar jobs_tvar guard $ null (jobsWaiting jobs) return do - interruptWaitOnSemaphore wait_id + killThread tid return $ jsj { jobserverAction = Idle } _ -> retry @@ -430,30 +479,38 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar }) action <- atomically $ asum $ (\x -> x s) <$> [ tryRelease sjs , tryAcquire opts sjs - , tryNoticeIdle opts jobs_tvar + , tryNoticeIdle opts sjs , tryStopThread jobs_tvar ] s <- action loop s --- | Create a new jobserver using the given semaphore handle. -makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ()) -makeJobserver sem_name = do - semaphore <- openSemaphore sem_name +-- | Create a new jobserver using the given semaphore identifier. +makeJobserver :: SemaphoreIdentifier -> IO (AbstractSem, IO ()) +makeJobserver sem_ident = do + semaphore <- openSemaphore sem_ident >>= either MC.throwM pure let init_jobs = Jobs { tokensOwned = 1 , tokensFree = 1 , jobsWaiting = NilOL + , heldTokens = [] } jobs_tvar <- newTVarIO init_jobs + active_tvar <- newTVarIO Nothing let opts = defaultJobserverOptions -- TODO: allow this to be configured - sjs = Jobserver { jSemaphore = semaphore - , jobs = jobs_tvar } + sjs = Jobserver { jSemaphore = semaphore + , jobs = jobs_tvar + , activeChild = active_tvar } loop_finished_mvar <- newEmptyMVar loop_tid <- forkIOWithUnmask \ unmask -> do r <- try $ unmask $ jobserverLoop opts sjs + -- Always-run exit handler: any child the loop spawned is still alive + -- in its own thread, so drain it before touching jobs_tvar. No one + -- else can mutate the resources once both are dead. + drainActiveChild sjs + releaseAllHeld sjs putMVar loop_finished_mvar $ case r of Left e @@ -467,8 +524,8 @@ makeJobserver sem_name = do acquireSem = acquireJob jobs_tvar releaseSem = releaseJob jobs_tvar cleanupSem = do - -- this is interruptible - cleanupJobserver sjs + -- Trigger the loop's exit handler; it drains the active child and + -- releases all held tokens, then signals loop_finished_mvar. killThread loop_tid mb_ex <- takeMVar loop_finished_mvar for_ mb_ex MC.throwM @@ -477,12 +534,12 @@ makeJobserver sem_name = do -- | Implement an abstract semaphore using a semaphore 'Jobserver' -- which queries the system semaphore of the given name for resources. -runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use +runJSemAbstractSem :: SemaphoreIdentifier -- ^ the semaphore identifier (from @-jsem@) -> (AbstractSem -> IO a) -- ^ the operation to run -- which requires a semaphore -> IO a -runJSemAbstractSem sem action = MC.mask \ unmask -> do - (abs, cleanup) <- makeJobserver sem +runJSemAbstractSem sem_ident action = MC.mask \ unmask -> do + (abs, cleanup) <- makeJobserver sem_ident r <- try $ unmask $ action abs case r of Left (e1 :: MC.SomeException) -> do @@ -517,8 +574,13 @@ increases the number of `free` jobs. If there are more pending jobs when the fre is increased, the token is immediately reused (see `modifyJobResources`). The `jobServerLoop` interacts with the system semaphore: when there are pending -jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a -token is obtained, it increases the owned count. +jobs, `acquireThread` forks a child that calls the interruptible +`waitOnSemaphore`. The child is forked in the masked state, so the only place +an async exception can be delivered is the wait itself; once the wait returns, +the child's STM commit always completes, recording either the new token in +`heldTokens` or the failure exception in `threadFinished`. The (tid, tmvar) +pair is also published in `activeChild` so the loop's exit handler can drain +the child on shutdown even after the in-loop `JobserverState` is gone. When GHC has free tokens (tokens from the semaphore that it is not using), no pending jobs, and the debounce has expired, then `releaseThread` will @@ -531,6 +593,12 @@ This second token is no longer needed, so we should cancel the wait (as it would not be used to do any work, and not be returned until the debounce). We only need to kill `acquireJob`, because `releaseJob` never blocks. +Shutdown starts with `killThread loop_tid`. The loop's exit handler then +runs `drainActiveChild` followed by `releaseAllHeld`; only then does the +loop signal `loop_finished_mvar`. This sequence makes the heldTokens +snapshot consistent because no other thread can mutate it once the loop and +its child are both dead. + Note [Eventlog Messages for jsem] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be tricky to verify that the work is shared adequately across different @@ -540,3 +608,5 @@ to analyse this output and report statistics about core saturation in the GitHub repo (https://github.com/mpickering/ghc-jsem-analyse) -} + +#endif ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -289,6 +289,8 @@ import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) import GHC.Toolchain import GHC.Toolchain.Program +import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion ) + import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -2445,6 +2447,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnUnusableUnpackPragmas -> warnSpec x Opt_WarnPatternNamespaceSpecifier -> warnSpec x Opt_WarnUnrecognisedModifiers -> warnSpec x + Opt_WarnSemaphoreOpenFailure -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups @@ -3628,6 +3631,8 @@ compilerInfo dflags ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make@. ("Support parallel --make", "YES"), + -- The semaphore protocol version supported by @-jsem@. + ("Semaphore version", show (getSemaphoreProtocolVersion semaphoreVersion)), -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in -- installed package info. ("Support reexported-modules", "YES"), ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -403,6 +403,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284 GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599 GhcDiagnosticCode "DriverMissingLinkableForModule" = 47338 + GhcDiagnosticCode "DriverSemaphoreOpenFailure" = 19877 -- Constraint solver diagnostic codes GhcDiagnosticCode "BadTelescope" = 97739 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Types.Hint ( , StarIsType(..) , UntickedPromotedThing(..) , AssumedDerivingStrategy(..) + , SemaphoreUpgradeTarget(..) , SigLike(..) , pprUntickedConstructor, isBareSymbol , suggestExtension @@ -538,6 +539,28 @@ data GhcHint {-| Suggest adding signature to modifier -} | SuggestModifierSignature (HsModifier GhcRn) Name + {-| Suggest upgrading either the @-jsem@ jobserver or GHC itself to + support the given semaphore protocol version. + + Triggered by 'GHC.Driver.Errors.Types.DriverSemaphoreOpenFailure' + carrying a 'System.Semaphore.SemaphoreIncompatibleVersion'. + -} + | SuggestUpgradeForSemaphoreVersionMismatch !SemaphoreUpgradeTarget !Int + -- ^ The 'Int' is the required protocol version. + +-- | What the user should upgrade to resolve an @-jsem@ semaphore +-- protocol version mismatch. +data SemaphoreUpgradeTarget + = UpgradeCabalInstall + -- ^ Jobserver is @cabal-install@ (we are building a Cabal package) + -- and speaks an older protocol than GHC. + | UpgradeJobserver + -- ^ Jobserver (not @cabal-install@) speaks an older protocol than + -- GHC. + | UpgradeGHC + -- ^ Jobserver speaks a newer protocol than GHC. + deriving (Eq, Show) + -- | The deriving strategy that was assumed when not explicitly listed in the -- source. This is used solely by the missing-deriving-strategies warning. -- There's no `Via` case because we never assume that. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -306,6 +306,20 @@ instance Outputable GhcHint where (text "Perhaps it should have a kind signature, like") 2 (hsep [text "%(" <> ppr ty, text "::", ppr name <> text ")"]) + SuggestUpgradeForSemaphoreVersionMismatch target required + -> case target of + UpgradeCabalInstall -> + text "The cabal-install jobserver uses an older semaphore protocol." + $$ (text "Upgrade cabal-install to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") + UpgradeJobserver -> + text "The jobserver uses an older semaphore protocol." + $$ (text "Upgrade it to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") + UpgradeGHC -> + text "The jobserver uses a newer semaphore protocol than this GHC." + $$ (text "Upgrade GHC to a version that supports semaphore protocol v" + <> int required <> text " to resolve this.") perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2721,6 +2721,23 @@ of ``-W(no-)*``. f :: a %True -> a g :: a %(k :: Int) -> a +.. ghc-flag:: -Wsemaphore-open-failure + :shortdesc: warn when GHC cannot open the ``-jsem`` semaphore. + :type: dynamic + :reverse: -Wno-semaphore-open-failure + :category: + + :since: 10.0.1 + + Warn when GHC is invoked with :ghc-flag:`-jsem` but the semaphore + cannot be opened (e.g. the socket does not exist, the protocol + version is incompatible, or a system error occurred). When this + occurs, GHC ignores ``-jsem`` and compiles modules sequentially. + + A common cause is ``cabal-install`` and GHC being built against + different versions of the ``semaphore-compat`` library; upgrading + both to versions that use the same protocol resolves the mismatch. + ---- If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice. ===================================== docs/users_guide/using.rst ===================================== @@ -797,7 +797,12 @@ There are two kinds of participants in the GHC Jobserver protocol: Perform compilation in parallel when possible, coordinating with other processes through the semaphore ⟨sem⟩ (specified as a string). - Error if the semaphore doesn't exist. + + If the semaphore cannot be opened (e.g. the socket does not exist + or its protocol version is incompatible with this GHC), GHC emits + a :ghc-flag:`-Wsemaphore-open-failure` warning and compiles + sequentially, using only the implicit token inherited from the + parent process. Use of ``-jsem`` will override use of :ghc-flag:`-j[⟨n⟩]`, and vice-versa. ===================================== hadrian/src/Flavour.hs ===================================== @@ -149,10 +149,6 @@ werror = -- unix has many unused imports , package unix ? mconcat [arg "-Wwarn=unused-imports", arg "-Wwarn=unused-top-binds"] - -- semaphore-compat relies on sem_getvalue as provided by unix, which is - -- not implemented on Darwin and therefore throws a deprecation warning - , package semaphoreCompat - ? mconcat [arg "-Wwarn=deprecations"] ] , builder Ghc ? package rts ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1 +Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -21,6 +21,7 @@ [GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode) [GHC-74284] is untested (constructor = DriverInstantiationNodeInDependencyGeneration) [GHC-66599] is untested (constructor = DriverNoConfiguredLLVMToolchain) +[GHC-19877] is untested (constructor = DriverSemaphoreOpenFailure) [GHC-81325] is untested (constructor = ExpectingMoreArguments) [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt) [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8db331a381ae47ad9ad5c8613f5d3e2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8db331a381ae47ad9ad5c8613f5d3e2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/9.10.4-batch1] rts: CCS.h - Backport CCS_SYSTEM_OR_NULL macro
by Andreas Klebinger (＠AndreasK) 26 May '26

26 May '26

Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC Commits: 381d513d by Andreas Klebinger at 2026-05-26T10:07:14+02:00 rts: CCS.h - Backport CCS_SYSTEM_OR_NULL macro - - - - - 1 changed file: - rts/include/rts/prof/CCS.h Changes: ===================================== rts/include/rts/prof/CCS.h ===================================== @@ -220,9 +220,14 @@ extern CostCentre * RTS_VAR(CC_LIST); // registered CC list #define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader)) #define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs +/* Allow using CCS_SYSTEM somewhat consistently with/without profiling mode */ +#define CCS_SYSTEM_OR_NULL CCS_SYSTEM + #else /* !PROFILING */ #define CCS_ALLOC(ccs, amount) doNothing() #define ENTER_CCS_THUNK(cap,p) doNothing() +#define CCS_SYSTEM_OR_NULL NULL + #endif /* PROFILING */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/381d513d5d7d88409bc8dce211068b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/381d513d5d7d88409bc8dce211068b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Ensure that SetOps.{minusList,unionListsOrd} can be specialized
by Marge Bot (＠marge-bot) 26 May '26

26 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 579aa0b7 by Simon Jakobi at 2026-05-25T16:31:26-04:00 Ensure that SetOps.{minusList,unionListsOrd} can be specialized ...by marking them INLINABLE. Haddock allocates 0.1–0.3% less as a result. This also removes some redundant constraints on unionListsOrd. - - - - - cccf45da by Cheng Shao at 2026-05-25T16:32:13-04:00 wasm: ensure post-linker output is synchronous ESM This patch fixes wasm backend's post-linker output script to ensure it's synchronous ESM and doesn't use top-level await, which doesn't work in ServiceWorkers. Fixes #27257. - - - - - 57195fed by Zubin Duggal at 2026-05-25T21:13:24-04:00 Update to semaphore-compat 2.0.0 using v2 of the protocol On Linux and other POSIX platforms, GHC's -jsem jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix domain sockets in place of POSIX named semaphores. This avoids the libc-ABI issues that affected the old implementation. Windows is unaffected and continues to use the v1 protocol (Win32 named semaphores); its reported protocol version remains v1. When GHC receives a -jsem name whose protocol version it does not support, it emits a -Wsemaphore-version-mismatch warning and falls back to -j<N> rather than crashing. ghc --info exposes the supported version in a new "Semaphore version" entry so cabal-install can detect a mismatch before invoking GHC. Users on a cabal-install that predates the v2 update will continue to build successfully on Linux/POSIX, but will lose the cross-process -jsem coordination and fall back to -j<N> per GHC invocation. Users must upgrade to a cabal-install that supports protocol v2 to recover full parallelism. Also fix a leak in cleanupSem (#27253): cleanupSem used to snapshot heldTokens and release them before killing the loop, while the loop's in-flight acquire/release children could still be mutating it. Cleanup now runs inside the loop's own exit handler, after draining the active child via a new activeChild TVar, so the snapshot has no concurrent mutator. See also: - GHC proposal amendment: https://github.com/ghc-proposals/ghc-proposals/pull/673 - cabal-install patch: https://github.com/haskell/cabal/pull/11628 - semaphore-compat MR: https://gitlab.haskell.org/ghc/semaphore-compat/-/merge_requests/8 Bump semaphore-compat submodule to 2.0.0 Fixes #25087 and #27253 - - - - - 0fddadda by Alan Zimmerman at 2026-05-25T21:13:25-04:00 EPA: Record semicolons in HsModifier Ensure the semi colons are captured in the ParsedSource for code like %True;; %False; instance C D It makes HsModifier (and hence HsModifierOf) LocatedA, so the semi colons can be recorded as [TrailingAnn] Also rename pprHsModifiers to pprLHsModifiers to match. Closes #27294 - - - - - 52 changed files: - + changelog.d/jobserver-leak-fix - + changelog.d/semaphore-v2 - + changelog.d/wasm-fix-serviceworker - compiler/GHC/Data/List/SetOps.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - hadrian/src/Flavour.hs - libraries/semaphore-compat - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/printer/PprModifiers.hs - utils/check-exact/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/jsffi/prelude.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a76e7aaabb9453c834192af00bfe9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a76e7aaabb9453c834192af00bfe9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/az/T27294-modifier-semis
by Alan Zimmerman (＠alanz) 25 May '26

25 May '26

Alan Zimmerman pushed new branch wip/az/T27294-modifier-semis at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/T27294-modifier-semis You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] wasm: ensure post-linker output is synchronous ESM
by Marge Bot (＠marge-bot) 25 May '26

25 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cccf45da by Cheng Shao at 2026-05-25T16:32:13-04:00 wasm: ensure post-linker output is synchronous ESM This patch fixes wasm backend's post-linker output script to ensure it's synchronous ESM and doesn't use top-level await, which doesn't work in ServiceWorkers. Fixes #27257. - - - - - 2 changed files: - + changelog.d/wasm-fix-serviceworker - utils/jsffi/prelude.mjs Changes: ===================================== changelog.d/wasm-fix-serviceworker ===================================== @@ -0,0 +1,4 @@ +section: wasm-backend +synopsis: Ensure post-linker output is synchronous ESM and fix loading in ServiceWorker +issues: #27257 +mrs: !16093 ===================================== utils/jsffi/prelude.mjs ===================================== @@ -39,19 +39,13 @@ export class JSValManager { // To benchmark different setImmediate() implementations in the // browser, use https://github.com/jphpsf/setImmediate-shim-demo as a // starting point. -export const setImmediate = await (async () => { - // node, bun, or other scripts might have set this up in the browser +export const setImmediate = (() => { + // node, deno, bun, or other scripts might have set this up in the + // browser if (globalThis.setImmediate) { return globalThis.setImmediate; } - // deno - if (globalThis.Deno) { - try { - return (await import("node:timers")).setImmediate; - } catch {} - } - // https://developer.mozilla.org/en-US/docs/Web/API/Scheduler/postTask if (globalThis.scheduler) { return (cb, ...args) => scheduler.postTask(() => cb(...args)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cccf45da01988801b0c97f7e7ed0160… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cccf45da01988801b0c97f7e7ed0160… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/interpolated-strings] [ci skip] wip
by Brandon Chinn (＠brandonchinn178) 25 May '26

25 May '26

Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: 82274ff5 by Brandon Chinn at 2026-05-25T13:32:44-07:00 [ci skip] wip - - - - - 9 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Rename/String.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/Data/String/Interpolate/Basic/Experimental.hs - libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs - testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs - testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout - testsuite/tests/qualified-strings/should_run/Example/SQL.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -282,7 +282,11 @@ basicKnownKeyNames fromStringName, -- Interpolated strings - interpolateStringName, + interpolateRawName, + interpolateValueName, + interpolateAppendName, + interpolateEmptyName, + interpolateFinalizeName, -- Enum stuff enumFromName, enumFromThenName, @@ -1090,8 +1094,17 @@ minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpK negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey -- Module GHC.Internal.Data.String.Interpolate -interpolateStringName :: Name -interpolateStringName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateString") interpolateStringKey +interpolateRawName + , interpolateValueName + , interpolateAppendName + , interpolateEmptyName + , interpolateFinalizeName + :: Name +interpolateRawName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateRaw" ) interpolateRawKey +interpolateValueName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateValue" ) interpolateValueKey +interpolateAppendName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateAppend" ) interpolateAppendKey +interpolateEmptyName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateEmpty" ) interpolateEmptyKey +interpolateFinalizeName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateFinalize") interpolateFinalizeKey --------------------------------- -- ghc-bignum @@ -2392,8 +2405,17 @@ proxyHashKey :: Unique proxyHashKey = mkPreludeMiscIdUnique 502 -- String interpolation -interpolateStringKey :: Unique -interpolateStringKey = mkPreludeMiscIdUnique 576 +interpolateRawKey + , interpolateValueKey + , interpolateAppendKey + , interpolateEmptyKey + , interpolateFinalizeKey + :: Unique +interpolateRawKey = mkPreludeMiscIdUnique 576 +interpolateValueKey = mkPreludeMiscIdUnique 577 +interpolateAppendKey = mkPreludeMiscIdUnique 578 +interpolateEmptyKey = mkPreludeMiscIdUnique 579 +interpolateFinalizeKey = mkPreludeMiscIdUnique 580 ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES IdUniques 200-499 ===================================== compiler/GHC/Rename/String.hs ===================================== @@ -8,14 +8,12 @@ import GHC.Prelude import Data.Maybe (isNothing) import qualified GHC.Builtin.Names as Builtin -import GHC.Builtin.Types (stringTyConName) import GHC.Data.StringMeta (StringMeta (..)) import GHC.Hs import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Env (lookupNameWithQualifier) -import GHC.Rename.Pat (rnOverLit) +import GHC.Rename.Env (lookupNameWithQualifier, lookupSyntaxName) import GHC.Tc.Utils.Monad -import GHC.Types.Name (mkVarOcc) +import GHC.Types.Name (Name) import GHC.Types.Name.Set (FreeNames, emptyFNs, plusFNs) import GHC.Types.SrcLoc (unLoc) @@ -59,58 +57,46 @@ rewriteInterString :: [HsInterStringPart GhcRn] -> RnM (HsExpr GhcRn, FreeNames) rewriteInterString meta parts = do - overloaded <- xoptM LangExt.OverloadedStrings - convertName <- newName (mkVarOcc "convert") - rawName <- newName (mkVarOcc "raw") - mappendName <- newName (mkVarOcc "mappend") - memptyName <- newName (mkVarOcc "mempty") - - (interpolateStringName, fvs1) <- - case strMetaQualified meta of - Just modName -> lookupNameWithQualifier Builtin.interpolateStringName modName - Nothing -> pure (Builtin.interpolateStringName, emptyFNs) - (parts', fvs2) <- unzip <$> mapM (rewritePart overloaded convertName rawName) parts + mkOverloaded <- get_mkOverloaded + + let lookupName' = lookupName (strMetaQualified meta) + (rawName, fns1) <- lookupName' Builtin.interpolateRawName + (convertName, fns2) <- lookupName' Builtin.interpolateValueName + (appendName, fns3) <- lookupName' Builtin.interpolateAppendName + (emptyName, fns4) <- lookupName' Builtin.interpolateEmptyName + (finalizeName, fns5) <- lookupName' Builtin.interpolateFinalizeName + let expr = - (if not overloaded && isNothing (strMetaQualified meta) then addSig else id) - . nlHsApp (nlHsVar interpolateStringName) - . mkLam - [ nlVarPat convertName - , nlVarPat rawName - , nlVarPat mappendName - , nlVarPat memptyName - ] - $ foldr (\p acc -> nlHsApps mappendName [p, acc]) (nlHsVar memptyName) parts' - - pure (unLoc expr, plusFNs $ [fvs1] ++ fvs2) + unLoc + . mkOverloaded + . nlHsApp (nlHsVar finalizeName) + . foldr (\p acc -> nlHsApps appendName [p, acc]) (nlHsVar emptyName) + $ map (rewritePart convertName rawName) parts + + pure (expr, plusFNs [fns1, fns2, fns3, fns4, fns5]) where - mkLam pats body = mkHsLam (noLocA pats) body - - rewritePart overloaded convertName rawName = \case - HsInterStringRaw st s -> do - (lit, fvs) <- mkStringLit overloaded st s - pure (nlHsApps rawName [lit], fvs) - HsInterStringExpr _ e -> - pure (nlHsApps convertName [e], emptyFNs) - - -- Add ":: String" to the given expression - addSig e = - noLocA . ExprWithTySig noExtField e $ - HsWC - { hswc_ext = [] - , hswc_body = - noLocA - HsSig - { sig_ext = noExtField - , sig_bndrs = HsOuterImplicit [] - , sig_body = nlHsTyVar NotPromoted stringTyConName - } - } - - mkStringLit overloaded st s = do - if overloaded - then do - -- FIXME(bchinn): allow -XRebindableSyntax -- lookupSyntaxName - (expr, fvs) <- rnOverLit noExtField $ OverLit noExtField (HsIsString st s) - pure (noLocA expr, fvs) - else - pure (nlHsLit $ HsString st s, emptyFNs) + rewritePart convertName rawName = \case + HsInterStringRaw st s -> nlHsApps rawName [nlHsLit $ HsString st s] + HsInterStringExpr _ e -> nlHsApps convertName [e] + + -- Handle -XOverloadedStrings + get_mkOverloaded = do + overloaded <- xoptM LangExt.OverloadedStrings + pure $ + if overloaded && isNothing (strMetaQualified meta) + then nlHsApp (nlHsVar Builtin.fromStringName) + else id + +-- | Look up the given name in the following places: +-- 1. If the given module is provided, in the module +-- 2. If -XRebindableSyntax, any name in scope +-- 3. Otherwise, return the built-in name. +lookupName :: Maybe ModuleName -> Name -> RnM (Name, FreeNames) +lookupName mQualMod name + | Just mod <- mQualMod = + lookupNameWithQualifier name mod + | otherwise = do + isRebindable <- xoptM LangExt.RebindableSyntax + if isRebindable + then lookupSyntaxName name + else pure (name, emptyFNs) ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -34,6 +34,7 @@ library import: warnings exposed-modules: Data.String.Interpolate.Experimental + Data.String.Interpolate.Basic.Experimental Data.Sum.Experimental Data.Tuple.Experimental GHC.PrimOps ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Basic/Experimental.hs ===================================== @@ -0,0 +1,23 @@ +module Data.String.Interpolate.Basic.Experimental where + +import Data.String (IsString (..)) + +interpolateRaw :: IsString s => String -> s +interpolateRaw = fromString +{-# INLINE [1] interpolateRaw #-} + +interpolateValue :: s -> s +interpolateValue = id +{-# INLINE [1] interpolateValue #-} + +interpolateAppend :: Monoid s => s -> s -> s +interpolateAppend = mappend +{-# INLINE [1] interpolateAppend #-} + +interpolateEmpty :: Monoid s => s +interpolateEmpty = mempty +{-# INLINE [1] interpolateEmpty #-} + +interpolateFinalize :: s -> s +interpolateFinalize = id +{-# INLINE [1] interpolateFinalize #-} ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs ===================================== @@ -14,8 +14,13 @@ See the proposal for motivation and explanations: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0570-s… -} module Data.String.Interpolate.Experimental ( - SimpleStringInterpolator, - interpolateString, + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, + + -- * Interpolate class Interpolate (..), ) where ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs ===================================== @@ -12,57 +12,85 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} module GHC.Internal.Data.String.Interpolate ( - SimpleStringInterpolator, - interpolateString, + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, + + -- * StringBuilder + StringBuilder (..), + buildString, + + -- * Interpolate class Interpolate (..), ) where import GHC.Internal.Base -import GHC.Internal.Data.Maybe (Maybe (..)) +import GHC.Internal.Data.Monoid (Endo (..)) import GHC.Internal.Data.String (IsString, fromString) -import GHC.Internal.Show (ShowS, showChar, showString, shows) +import GHC.Internal.Show (show) import GHC.Internal.Types -type SimpleStringInterpolator s = - ( forall ss. - (forall a. Interpolate a => a -> s) - -> (s -> s) - -> (s -> ss -> ss) - -> ss - -> ss - ) - -> s +interpolateRaw :: String -> StringBuilder +interpolateRaw = fromString +{-# INLINE [1] interpolateRaw #-} -interpolateString :: (IsString s, Monoid s) => SimpleStringInterpolator s -interpolateString f = mconcat $ f (fromString . interpolate) id (:) [] -{-# INLINE interpolateString #-} +interpolateValue :: Interpolate a => a -> StringBuilder +interpolateValue = interpolate +{-# INLINE [1] interpolateValue #-} -class Interpolate a where - {-# MINIMAL interpolate | interpolateS #-} +interpolateAppend :: StringBuilder -> StringBuilder -> StringBuilder +interpolateAppend = mappend +{-# INLINE [1] interpolateAppend #-} - interpolate :: a -> String - interpolate x = interpolateS x "" +interpolateEmpty :: StringBuilder +interpolateEmpty = mempty +{-# INLINE [1] interpolateEmpty #-} - interpolateS :: a -> ShowS - interpolateS x s = interpolate x <> s +interpolateFinalize :: StringBuilder -> String +interpolateFinalize = buildString +{-# INLINE [1] interpolateFinalize #-} -instance Interpolate String where - interpolateS = showString -instance Interpolate Char where - interpolateS = showChar +{----- StringBuilder -----} + +newtype StringBuilder = StringBuilder (Endo String) + deriving newtype (Semigroup, Monoid) +instance IsString StringBuilder where + fromString s = StringBuilder (Endo (s <>)) + {-# INLINE [1] fromString #-} -#define INTERPOLATE_WITH_SHOW(x) \ - instance Interpolate x where \ - interpolateS = shows -INTERPOLATE_WITH_SHOW(Int) -INTERPOLATE_WITH_SHOW(Double) -INTERPOLATE_WITH_SHOW(Bool) --- FIXME(bchinn): More instances +buildString :: StringBuilder -> String +buildString (StringBuilder (Endo f)) = f "" +{-# INLINE [1] buildString #-} -instance Interpolate a => Interpolate (Maybe a) where - interpolateS Nothing = showString "Nothing" - interpolateS (Just a) = showString "Just (" . interpolateS a . showChar ')' +{---- Interpolate ----} + +class Interpolate a where + interpolate :: (IsString s, Monoid s) => a -> s + +instance Interpolate String where + interpolate = fromString + {-# INLINE [1] interpolate #-} +instance Interpolate Char where + interpolate c = fromString [c] + {-# INLINE [1] interpolate #-} +instance Interpolate Int where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} +instance Interpolate Double where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} +instance Interpolate Bool where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} ===================================== testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs ===================================== @@ -2,10 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StringInterpolation #-} +{-# LANGUAGE TypeFamilies #-} import Data.String.Interpolate.Experimental import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.Lazy.Builder qualified as LazyText +import Data.Text.Lazy.Builder.Int qualified as LazyText +import Data.Text.Lazy.Builder.RealFloat qualified as LazyText +import Data.Text.Lazy qualified as LazyText main :: IO () main = mapM_ runTest allTests @@ -30,14 +35,14 @@ allTests = [ TestCase -- Text { label = """ - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text """ , expression = - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text } -- FIXME(bchinn): overloaded interpolated multiline string ] -- Remove when text provides this instance instance Interpolate Text where - interpolateS = interpolateS . Text.unpack + interpolate = interpolate . Text.unpack ===================================== testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout ===================================== @@ -1,5 +1,5 @@ **************************************** Input: - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text ====> "world hello world True" ===================================== testsuite/tests/qualified-strings/should_run/Example/SQL.hs ===================================== @@ -1,7 +1,13 @@ module Example.SQL ( SqlQuery (..), SqlValue (..), - interpolateString, + + -- * String interpolation + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, ) where import Data.String (IsString (..)) @@ -41,12 +47,17 @@ instance ToSqlQuery String where instance ToSqlQuery Int where toSqlQuery x = SqlQuery{sqlText = "?", sqlValues = [SqlInt x]} -interpolateString :: - ( (forall a. ToSqlQuery a => a -> SqlQuery) -> - (String -> SqlQuery) -> - (SqlQuery -> SqlQuery -> SqlQuery) -> - SqlQuery -> - SqlQuery - ) -> - SqlQuery -interpolateString f = f toSqlQuery fromString (<>) mempty +interpolateRaw :: String -> SqlQuery +interpolateRaw = fromString + +interpolateValue :: ToSqlQuery a => a -> SqlQuery +interpolateValue = toSqlQuery + +interpolateAppend :: SqlQuery -> SqlQuery -> SqlQuery +interpolateAppend = mappend + +interpolateEmpty :: SqlQuery +interpolateEmpty = mempty + +interpolateFinalize :: SqlQuery -> SqlQuery +interpolateFinalize = id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82274ff589c2b9ce56a55ae068005a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82274ff589c2b9ce56a55ae068005a4… You're receiving this email because of your account on gitlab.haskell.org.

1 0