[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] rts: add a few missing i386 relocations in the rts linker
by Magnus (＠MangoIV) 22 May '26
by Magnus (＠MangoIV) 22 May '26
22 May '26
Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC
Commits:
df48432e by Luite Stegeman at 2026-05-22T11:54:49+02:00
rts: add a few missing i386 relocations in the rts linker
(cherry picked from commit 04d143c02e82e9ca03eb75849959d369d07fb81a)
- - - - -
2 changed files:
- rts/linker/Elf.c
- testsuite/tests/th/all.T
Changes:
=====================================
rts/linker/Elf.c
=====================================
@@ -1308,6 +1308,16 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
case COMPAT_R_386_NONE: break;
case COMPAT_R_386_32: *pP = value; break;
case COMPAT_R_386_PC32: *pP = value - P; break;
+ case COMPAT_R_386_PLT32: *pP = value - P; break;
+ case COMPAT_R_386_GOTOFF: *pP = value - (Elf_Addr)oc->info->got_start; break;
+ case COMPAT_R_386_GOTPC: *pP = (Elf_Addr)oc->info->got_start + A - P; break;
+ case COMPAT_R_386_GOT32:
+ case COMPAT_R_386_GOT32X:
+ CHECK(symbol);
+ CHECK(symbol->got_addr);
+ *pP = (Elf_Addr)symbol->got_addr
+ - (Elf_Addr)oc->info->got_start + A;
+ break;
# endif
# if defined(arm_HOST_ARCH)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -626,7 +626,6 @@ test('T25209', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_MultilineStrings', normal, compile_and_run, [''])
test('T25252',
[extra_files(['T25252B.hs', 'T25252_c.c']),
- when(arch('i386'), expect_broken_for(25260,['ext-interp'])),
req_th,
req_c],
compile_and_run, ['-fPIC T25252_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df48432ec29980947c039311a78b537…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df48432ec29980947c039311a78b537…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/ghc-internal-def] TMP: CI: do only x86_64-windows-validate
by David Eichmann (＠DavidEichmann) 22 May '26
by David Eichmann (＠DavidEichmann) 22 May '26
22 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
eee0b5c3 by David Eichmann at 2026-05-22T10:50:15+01:00
TMP: CI: do only x86_64-windows-validate
- - - - -
28 changed files:
- .gitlab-ci.yml
- .gitlab/jobs.yaml
- libraries/Cabal
- libraries/array
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/file-io
- libraries/filepath
- libraries/haskeline
- libraries/hpc
- libraries/libffi-clib
- libraries/mtl
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell-lift
- libraries/template-haskell-quasiquoter
- libraries/terminfo
- libraries/text
- libraries/transformers
- libraries/unix
- libraries/xhtml
- nofib
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee0b5c376b09b9502dcb53d53d8767…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eee0b5c376b09b9502dcb53d53d8767…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/ghc-internal-def] TMP: CI: do only x86_64-windows-validate
by David Eichmann (＠DavidEichmann) 22 May '26
by David Eichmann (＠DavidEichmann) 22 May '26
22 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
cf355321 by David Eichmann at 2026-05-22T10:44:53+01:00
TMP: CI: do only x86_64-windows-validate
- - - - -
27 changed files:
- .gitlab/jobs.yaml
- libraries/Cabal
- libraries/array
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/file-io
- libraries/filepath
- libraries/haskeline
- libraries/hpc
- libraries/libffi-clib
- libraries/mtl
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell-lift
- libraries/template-haskell-quasiquoter
- libraries/terminfo
- libraries/text
- libraries/transformers
- libraries/unix
- libraries/xhtml
- nofib
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf355321b6ccd8ec2f8ae43643e3cc0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf355321b6ccd8ec2f8ae43643e3cc0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/9.10.4-batch1] 13 commits: PPC: display foreign label in panic message (cf #23969)
by Andreas Klebinger (＠AndreasK) 22 May '26
by Andreas Klebinger (＠AndreasK) 22 May '26
22 May '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
f472a3e0 by Sylvain Henry at 2026-05-21T09:50:07+02:00
PPC: display foreign label in panic message (cf #23969)
(cherry picked from commit a59943803a3933e06efa11dc1c2f8c8ded8a4720)
- - - - -
60be463a by Sylvain Henry at 2026-05-21T09:50:40+02:00
PPC NCG: handle JMP to ForeignLabels (#23969)
(cherry picked from commit 6e86d82b4db189227425f45a37d9c32232ffd8db)
- - - - -
543daf76 by Sylvain Henry at 2026-05-21T09:50:46+02:00
PPC NCG: support loading 64-bit value on 32-bit arch (#23969)
(cherry picked from commit 9e4b4b0af76e52398f17c90b7da4ed503ae0c3a4)
- - - - -
b2b8a727 by sheaf at 2026-05-21T11:14:29+02:00
RecordCon lookup: don't allow a TyCon
This commit adds extra logic when looking up a record constructor.
If GHC.Rename.Env.lookupOccRnConstr returns a TyCon (as it may, due to
the logic explained in Note [Pattern to type (P2T) conversion]),
we emit an error saying that the data constructor is not in scope.
This avoids the compiler falling over shortly thereafter, in the call to
'lookupConstructorInfo' inside 'GHC.Rename.Env.lookupRecFieldOcc',
because the record constructor would not have been a ConLike.
Fixes #25056
(cherry picked from commit da306610b9e58cfb7cf2530ebeec7ee8ad17183a)
- - - - -
9e251488 by Andrew Lelechenko at 2026-05-21T11:14:36+02:00
Bump submodule deepseq to 1.5.1.0
(cherry picked from commit 8e462f4d4bdf2a6c34c249e7be8084565600d300)
- - - - -
3b43649f by Wang Xin at 2026-05-21T11:14:36+02:00
Add -mcmodel=medium moduleflag to generated LLVM IR on LoongArch platform
With the Medium code model, the jump range of the generated jump
instruction is larger than that of the Small code model. It's a
temporary fix of the problem descriped in https://gitlab.haskell
.org/ghc/ghc/-/issues/25495. This commit requires that the LLVM
used contains the code of commit 9dd1d451d9719aa91b3bdd59c0c6679
83e1baf05, i.e., version 8.0 and later. Actually we should not
rely on LLVM, so the only way to solve this problem is to implement
the LoongArch backend.
Add new type for codemodel
(cherry picked from commit e70d41406b5d5638b42c4d8222cd03e76bbfeb86)
- - - - -
e3927fa8 by Peng Fan at 2026-05-21T11:14:36+02:00
Pass the mcmodel=medium parameter to CC via GHC
Ensure that GHC-driver builds default to mcmodel=medium, so that GHC
passes this default parameter to CC without having to add it to the
compiled project.
Commit e70d41406b5d5638b42c4d8222cd03e76bbfeb86 does not ensure that all
GHC-built object files have a default model of medium, and will raise an
R_LARCH_B26 overflow error.
(cherry picked from commit 1a3f11314cc7b8dbf9af03dd2ae2cb066a998d63)
- - - - -
402d3d2c by Ben Gamari at 2026-05-21T14:10:07+02:00
rts: Dynamically initialize built-in closures
To resolve #26166 we need to eliminate references to undefined symbols
in the runtime system. One such source of these is the runtime's
static references to `I#` and `C#` due the `stg_INTLIKE` and
`stg_CHARLIKE` arrays.
To avoid this we make these dynamic, initializing them during RTS
start-up.
(cherry picked from commit 39eaaaba5356e3fc9218d8e27375d6de24778cbc)
- - - - -
3a83cea0 by Rodrigo Mesquita at 2026-05-22T10:19:26+02:00
Move code-gen aux symbols from ghc-internal to rts
These symbols were all previously defined in ghc-internal and made the
dependency structure awkward, where the rts may refer to some of these
symbols and had to work around that circular dependency the way
described in #26166.
Moreover, the code generator will produce code that uses these symbols!
Therefore, they should be available in the rts:
PRINCIPLE: If the code generator may produce code which uses this
symbol, then it should be defined in the rts rather than, say,
ghc-internal.
That said, the main motivation is towards fixing #26166.
Towards #26166. Pre-requisite of !14892
(cherry picked from commit ba3e5bddb222008591edb6c3d433d93084170571)
(cherry picked from commit f687ce93a4ef71aebac5d5eb891e72a090092ec0)
- - - - -
e631feac by Ben Gamari at 2026-05-22T11:29:07+02:00
rts: Avoid static symbol references to ghc-internal
This resolves #26166, a bug due to new constraints placed by Apple's
linker on undefined references.
One source of such references in the RTS is the many symbols referenced
in ghc-internal. To mitigate #26166, we make these references dynamic,
as described in Note [RTS/ghc-internal interface].
Fixes #26166
Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com>
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
(cherry picked from commit f31de2a9c2405d6645998460e4b501f9279606b3)
- - - - -
eefb949a by Ben Gamari at 2026-05-22T11:31:14+02:00
compiler: Rename isMathFun -> isLibcFun
This set includes more than just math functions.
(cherry picked from commit 43fdfddc25c36ef4811941231d5755bad065796d)
(cherry picked from commit 99291e88f0498f11317e0f45c4968583c8c6ef0f)
- - - - -
1f37d52e by Ben Gamari at 2026-05-22T11:32:01+02:00
compiler: Add libc allocator functions to libc_funs
Prototypes for these are now visible from `Prim.h`, resulting in
multiple-declaration warnings in the unregisterised job.
(cherry picked from commit 4ed5138f7af532731f88380f98103487a9f15c5a)
(cherry picked from commit d5d081e38f6abf445ad50b355585d2edddfc8173)
- - - - -
c8e310a1 by Ben Gamari at 2026-05-22T11:32:22+02:00
rts: Minimize header dependencies of Prim.h
Otherwise we will end up with redundant and incompatible declarations
resulting in warnings during the unregisterised build.
(cherry picked from commit 9a0a076b80d6fb68d7722d2bb72c17c90ba22cd1)
(cherry picked from commit ef442bd152400dc550fba2ba5fd90fb0f5454614)
- - - - -
62 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/Static.hs
- hadrian/src/Settings/Packages.hs
- libraries/deepseq
- + libraries/ghc-internal/cbits/RtsIface.c
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/include/RtsIfaceSymbols.h
- libraries/ghc-prim/ghc-prim.cabal
- m4/fptools_set_c_ld_flags.m4
- + rts/BuiltinClosures.c
- + rts/BuiltinClosures.h
- rts/CloneStack.h
- rts/Compact.cmm
- rts/ContinuationOps.cmm
- rts/Exception.cmm
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsAPI.c
- rts/RtsStartup.c
- rts/RtsSymbols.c
- + rts/RtsToHsIface.c
- rts/StgMiscClosures.cmm
- rts/StgStdThunks.cmm
- rts/configure.ac
- − rts/external-symbols.list.in
- rts/include/Rts.h
- rts/include/RtsAPI.h
- rts/include/Stg.h
- rts/include/rts/Constants.h
- + rts/include/rts/RtsToHsIface.h
- rts/include/rts/Types.h
- rts/include/stg/MiscClosures.h
- rts/include/stg/Prim.h
- rts/posix/Signals.c
- libraries/ghc-prim/cbits/atomic.c → rts/prim/atomic.c
- libraries/ghc-prim/cbits/bitrev.c → rts/prim/bitrev.c
- libraries/ghc-prim/cbits/bswap.c → rts/prim/bswap.c
- libraries/ghc-prim/cbits/clz.c → rts/prim/clz.c
- libraries/ghc-prim/cbits/ctz.c → rts/prim/ctz.c
- + rts/prim/int64x2minmax.c
- libraries/ghc-prim/cbits/longlong.c → rts/prim/longlong.c
- libraries/ghc-prim/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c
- libraries/ghc-prim/cbits/pdep.c → rts/prim/pdep.c
- libraries/ghc-prim/cbits/pext.c → rts/prim/pext.c
- libraries/ghc-prim/cbits/popcnt.c → rts/prim/popcnt.c
- + rts/prim/vectorQuotRem.c
- libraries/ghc-prim/cbits/word2float.c → rts/prim/word2float.c
- − rts/rts.buildinfo.in
- rts/rts.cabal
- rts/wasm/JSFFI.c
- rts/wasm/scheduler.cmm
- rts/win32/libHSghc-internal.def
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/all.T
- utils/deriveConstants/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ce94e69f4f386c3e558f81874844e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ce94e69f4f386c3e558f81874844e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/semaphore-v2] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Zubin (＠wz1000) 22 May '26
by Zubin (＠wz1000) 22 May '26
22 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
0aba2589 by Zubin Duggal at 2026-05-22T14:25:09+05:30
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,6 +28,21 @@ 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
@@ -49,7 +64,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 +80,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
@@ -122,17 +137,24 @@ 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
+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 +181,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 +267,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 baa6d17eadcb88f5b0300dfaf6ca510374ffc8e7
=====================================
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/0aba25898a35d5ecca9ad59fc167aaa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0aba25898a35d5ecca9ad59fc167aaa…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/semaphore-v2] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Zubin (＠wz1000) 22 May '26
by Zubin (＠wz1000) 22 May '26
22 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
ff490e85 by Zubin Duggal at 2026-05-22T11:47:55+05:30
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,6 +28,21 @@ 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
@@ -49,7 +64,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 +80,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
@@ -122,17 +137,24 @@ 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
+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 +181,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 +267,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,24 +1,35 @@
{-# 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
import GHC.Prelude
+
+#if defined(wasm32_HOST_ARCH) || defined(javascript_HOST_ARCH)
+
+import System.Semaphore
+ ( AbstractSem(..)
+ , withAbstractSem
+ )
+
+#else
+
import GHC.Conc
import GHC.Data.OrdList
import GHC.IO.Exception
@@ -27,6 +38,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 +66,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 +104,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 +119,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 +137,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 +171,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 +217,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 +293,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 +303,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 +411,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 +430,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 +454,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 +480,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 +525,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 +535,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 +575,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 +594,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 +609,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 baa6d17eadcb88f5b0300dfaf6ca510374ffc8e7
=====================================
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/ff490e856d15fa92d72bf4b77d74675…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff490e856d15fa92d72bf4b77d74675…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/semaphore-v2] Update to semaphore-compat 2.0.0 using v2 of the protocol
by Zubin (＠wz1000) 22 May '26
by Zubin (＠wz1000) 22 May '26
22 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
c6a06bff by Zubin Duggal at 2026-05-22T10:28:51+05:30
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,6 +28,14 @@ import GHC.Driver.Errors.Types
import GHC.Driver.Messager
import GHC.Driver.MakeSem
+import System.Semaphore
+ ( SemaphoreError, SemaphoreIdentifier )
+
+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 )
import GHC.Utils.Logger
import GHC.Utils.TmpFs
@@ -49,7 +57,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 +73,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
@@ -122,17 +130,24 @@ runNjobsAbstractSem n_jobs action = do
resetNumCapabilities = set_num_caps n_capabilities
MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
-runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
+runWorkerLimit :: Logger -> DynFlags -> WorkerLimit -> (AbstractSem -> IO a) -> IO a
#if defined(wasm32_HOST_ARCH)
-runWorkerLimit _ action = do
+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 +174,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
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -9,9 +9,6 @@ module GHC.Driver.MakeSem
-- by a system semaphore (Posix/Windows)
runJSemAbstractSem
- -- * System semaphores
- , Semaphore, SemaphoreName(..)
-
-- * Abstract semaphores
, AbstractSem(..)
, withAbstractSem
@@ -46,11 +43,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 +81,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 +96,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 +114,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 +148,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 +194,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 +270,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 +280,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 +388,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 +407,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 +431,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 +457,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 +502,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 +512,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 +552,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 +571,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
=====================================
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 baa6d17eadcb88f5b0300dfaf6ca510374ffc8e7
=====================================
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/c6a06bff6912cde4e95b220ac223197…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6a06bff6912cde4e95b220ac223197…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/az/T27291-namespace-specified-wildcards
by Alan Zimmerman (＠alanz) 21 May '26
by Alan Zimmerman (＠alanz) 21 May '26
21 May '26
Alan Zimmerman pushed new branch wip/az/T27291-namespace-specified-wildcards at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/T27291-namespace-specified…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] TcMPluginHandling: be more lenient when no plugins
by Marge Bot (＠marge-bot) 21 May '26
by Marge Bot (＠marge-bot) 21 May '26
21 May '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7ecc6184 by sheaf at 2026-05-21T15:27:10-04:00
TcMPluginHandling: be more lenient when no plugins
This change ensures that, if a function such as 'typecheckModule' was
invoked with 'NoTcMPlugins', GHC doesn't spuriously complain about TcM
plugins having already been stopped, as there were none to start with.
- - - - -
4 changed files:
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- + testsuite/tests/ghc-api/T27273.hs
- testsuite/tests/ghc-api/all.T
Changes:
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1250,14 +1250,17 @@ emptyTcMPluginsShutdown = TcMPluginsShutdown
data TcMPluginsState
-- | The 'TcM' plugins have not been started.
= TcMPluginsUninitialised
- -- | The 'TcM' plugins have been initialised and not yet stopped.
+ -- | The 'TcM' plugins have been initialised and not yet stopped,
+ -- or there were no 'TcM' plugins to start with.
--
-- We may be in the middle of typechecker, or have finished typechecking
-- and be in the middle of desugaring.
| TcMPluginsRunning !RunningTcMPlugins
- -- | The 'TcM' plugins have been stopped.
+ -- | There were 'TcM' plugins that were running, but they have been stopped.
| TcMPluginsStopped
+-- | A (possibly empty) collection of 'TcM' plugin @run@, @post-tc@ and
+-- @shutdown@ actions.
data RunningTcMPlugins =
RunningTcMPlugins
{ rtcmp_run :: TcMPluginsRun
@@ -1281,11 +1284,20 @@ tcMPluginsShutdownActions = rtcmp_shutdown
-- | Retrieve the 'TcM' plugins from a 'TcMPluginsState'.
--
--- Assumes the plugins have been already started and not yet stopped.
+-- Assumes the plugins (if any) have been already started and not yet stopped.
runningTcMPlugins
:: HasDebugCallStack
=> TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins = \case
- TcMPluginsUninitialised -> panic "runningTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "runningTcMPlugins: TcM plugins already stopped"
+ TcMPluginsUninitialised ->
+ pprPanic "TcM plugins have not been started" $
+ vcat [ text "If you are a GHC API user, make sure to use an appropriate 'TcMPluginHandling'"
+ , text "to ensure that TcM plugins (if any) are initialised before typechecking."
+ ]
+ TcMPluginsStopped ->
+ pprPanic "TcM plugins already stopped" $
+ vcat [ text "If you are a GHC API user and want to proceed to desugaring after typechecking,"
+ , text "make sure you are not using the 'StartAndStopTcMPlugins' 'TcMPluginHandling',"
+ , text "as that stops TcM plugins after typechecking."
+ ]
TcMPluginsRunning plugins -> plugins
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -790,9 +790,10 @@ withoutTcMPlugins thing_inside = do
tcg_env <- getGblEnv
writeTcRef (tcg_plugins tcg_env) $
TcMPluginsRunning emptyRunningTcMPlugins
- teardown = do
- tcg_env <- getGblEnv
- writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped
+ teardown =
+ -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only
+ -- be used when there were 'TcM' plugins to start with (#27273).
+ return ()
-- | Initialise 'TcM' plugins.
initTcMPlugins :: HscEnv -> TcM ()
@@ -946,32 +947,20 @@ shutdownTcMPlugins = \case
runPluginShutdowns (tcs ++ defs)
solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver]
-solverTcMPlugins = \case
- TcMPluginsUninitialised -> panic "solverTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "solverTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_solvers (tcMPluginsRunActions plugins)
+solverTcMPlugins =
+ tcmp_solvers . tcMPluginsRunActions . runningTcMPlugins
rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter]
-rewriterTcMPlugins = \case
- TcMPluginsUninitialised -> panic "rewriterTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "rewriterTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_rewriters (tcMPluginsRunActions plugins)
+rewriterTcMPlugins =
+ tcmp_rewriters . tcMPluginsRunActions . runningTcMPlugins
defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting]
-defaultingTcMPlugins = \case
- TcMPluginsUninitialised -> panic "defaultingTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "defaultingTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_defaulters (tcMPluginsRunActions plugins)
+defaultingTcMPlugins =
+ tcmp_defaulters . tcMPluginsRunActions . runningTcMPlugins
holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin]
-holeFitTcMPlugins = \case
- TcMPluginsUninitialised -> panic "holeFitTcMPlugins: TcM plugins not started"
- TcMPluginsStopped -> panic "holeFitTcMPlugins: TcM plugins already stopped"
- TcMPluginsRunning plugins ->
- tcmp_hole_fits (tcMPluginsRunActions plugins)
+holeFitTcMPlugins =
+ tcmp_hole_fits . tcMPluginsRunActions . runningTcMPlugins
{-
************************************************************************
=====================================
testsuite/tests/ghc-api/T27273.hs
=====================================
@@ -0,0 +1,56 @@
+module Main where
+
+-- base
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import System.Environment (getArgs)
+
+-- time
+import Data.Time (getCurrentTime)
+
+-- ghc
+import qualified GHC as GHC
+import qualified GHC.Core as GHC
+import qualified GHC.Data.StringBuffer as GHC
+import qualified GHC.Unit.Module.ModGuts as GHC
+import qualified GHC.Unit.Types as GHC
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+ let inputSource = unlines
+ [ "module NumLitDesugaring where"
+ , "f :: Num a => a" -- !!! Succeeds if type signature is f :: Int
+ , "f = 1"
+ ]
+
+ void $ compileToCore "NumLitDesugaring" inputSource
+
+compileToCore :: String -> String -> IO [GHC.CoreBind]
+compileToCore modName inputSource = do
+ [libdir] <- getArgs
+ GHC.runGhc (Just libdir) $ do
+ (_ms, tcMod) <- typecheckSourceCode modName inputSource
+ dsMod <- GHC.desugarModule tcMod
+ return $ GHC.mg_binds $ GHC.dm_core_module dsMod
+
+typecheckSourceCode
+ :: GHC.GhcMonad m => String -> String -> m (GHC.ModSummary, GHC.TypecheckedModule)
+typecheckSourceCode modName inputSource = do
+ now <- liftIO getCurrentTime
+ df1 <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }
+ let target = GHC.Target
+ { GHC.targetId = GHC.TargetFile (modName ++ ".hs") Nothing
+ , GHC.targetUnitId = GHC.homeUnitId_ df1
+ , GHC.targetAllowObjCode = False
+ , GHC.targetContents = Just (GHC.stringToStringBuffer inputSource, now)
+ }
+ GHC.setTargets [target]
+ void $ GHC.depanal [] False
+
+ ms <- GHC.getModSummary
+ (GHC.mkModule GHC.mainUnit (GHC.mkModuleName modName))
+ tm <- GHC.parseModule ms >>= GHC.typecheckModule GHC.NoTcMPlugins
+ return (ms, tm)
=====================================
testsuite/tests/ghc-api/all.T
=====================================
@@ -82,3 +82,6 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
test('T25121_status', normal, compile_and_run, ['-package ghc'])
test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc'])
+test('T27273', [extra_run_opts(f'"{config.libdir}"')],
+ compile_and_run,
+ ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ecc618466382588b9934c514f178e0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ecc618466382588b9934c514f178e0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Speed up 'closure' computation in `ghc-pkg`
by Marge Bot (＠marge-bot) 21 May '26
by Marge Bot (＠marge-bot) 21 May '26
21 May '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
50e999ca by fendor at 2026-05-21T15:26:18-04:00
Speed up 'closure' computation in `ghc-pkg`
Cache the set of already seen `UnitId`s and use `Set` operations to
speed up 'closure' computation.
Further simplify the implementation of 'closure' to account for the
actual usage.
As a consequence, we rename 'closure' to 'brokenPackages' to reflect its
purpose better after the simplification.
- - - - -
2 changed files:
- + changelog.d/ghc-pkg-faster-closure
- utils/ghc-pkg/Main.hs
Changes:
=====================================
changelog.d/ghc-pkg-faster-closure
=====================================
@@ -0,0 +1,10 @@
+section: ghc-pkg
+synopsis: Improve performance of `ghc-pkg list` command
+issues: #27275
+mrs: !16062
+
+description: {
+`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation.
+We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time
+for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`.
+}
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do
all_ps = map mungedId pkgs1
let not_broken_pkgs = filterOut broken_pkgs pkgs
- (_, trans_broken_pkgs) = closure [] not_broken_pkgs
+ trans_broken_pkgs = brokenPackages not_broken_pkgs
all_broken_pkgs :: [InstalledPackageInfo]
all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
@@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do
when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
-closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> ([InstalledPackageInfo], [InstalledPackageInfo])
-closure pkgs db_stack = go pkgs db_stack
- where
- go avail not_avail =
- case partition (depsAvailable avail) not_avail of
- ([], not_avail') -> (avail, not_avail')
- (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
+-- | Compute the set of transitive broken packages.
+--
+-- A package is assumed to be broken if any of its dependencies is not
+-- found in the 'db_stack' after a transitive reduction.
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages db_stack = go Set.empty db_stack
+ where
+ go avail_ids not_avail =
+ case partition (depsAvailable avail_ids) not_avail of
+ ([], not_avail') -> not_avail'
+ (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail'
- depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
- -> Bool
- depsAvailable pkgs_ok pkg = null dangling
- where dangling = filter (`notElem` pids) (depends pkg)
- pids = map installedUnitId pkgs_ok
+ add new_avail avail_ids =
+ foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
- -- we want mutually recursive groups of package to show up
- -- as broken. (#1750)
+ depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool
+ depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)
-brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
-brokenPackages pkgs = snd (closure [] pkgs)
+ -- we want mutually recursive groups of package to show up
+ -- as broken. (#1750)
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50e999cae0297be156d3cc6a683fc3c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50e999cae0297be156d3cc6a683fc3c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0