[Git][ghc/ghc][wip/davide/ghc-internal-def] 24 commits: Use libffi-clib
by David Eichmann (@DavidEichmann) 21 May '26
by David Eichmann (@DavidEichmann) 21 May '26
21 May '26
David Eichmann pushed to branch wip/davide/ghc-internal-def at Glasgow Haskell Compiler / GHC
Commits:
d8dd0703 by Julian Ospald at 2025-11-21T14:06:02+08:00
Use libffi-clib
Previously, we would build libffi via hadrian
and bundle it manually with the GHC bindist.
This now moves all that logic out of hadrian
and allows us to have a clean Haskell package
to build and link against and ship it without
extra logic.
This patch still retains the ability to link
against a system libffi.
The main reason of bundling libffi was that on
some platforms (e.g. FreeBSD and Mac), system libffi
is not visible to the C toolchain by default,
so users would require settings in e.g. cabal
to be able to compile anything.
This adds the submodule libffi-clib to the repository.
- - - - -
8ba3e6ee by Matthew Pickering at 2025-11-21T14:06:18+08:00
hadrian: Use a response file to invoke GHC for dep gathering.
In some cases we construct an argument list too long for GHC to
handle directly on windows. This happens when we generate
the dependency file because the command line will contain
references to a large number of .hs files.
To avoid this we now invoke GHC using a response file when
generating dependencies to sidestep length limitations.
Note that we only pass the actual file names in the dependency
file. Why? Because this side-steps #26560
- - - - -
c4c5cc8d by Duncan Coutts at 2025-12-05T12:05:51+00:00
Make cmm 'import "package" name;' syntax use consistent label types
There is a little-used syntactic form in cmm imports:
import "package" foo;
Which means to import foo from the given package (unit id, specified as
a string). This syntax is somewhat reminiscent of GHC's package import
extension.
This syntax form is not used in the rts cmm code, nor any of the boot
libraries. It may not be used at all. Unclear.
Change the kind of CLabel this syntax generates to be consistent with
the others. The other cmm imports use ForeignLabel with
ForeignLabelInExternalPackage. For some reason this form was using
CmmLabel. Change that to also be ForeignLabel but with
ForeignLabelInPackage. This specifies a specific package, rather
than an unnamed external package.
- - - - -
089becd4 by Duncan Coutts at 2025-12-05T12:06:09+00:00
Change default cmm import statements to be internal
Previously a cmm statement like:
import foo;
meant to expect the symbol from a different shared library than the
current one.
Now it means to expect the symbol from the same shared library as the
current one. We'll add explicit syntax to indicate that it's a foreign
import. Most existing uses are in fact intenal (rts to rts), so few
imports will need to be annotated foreign. Examples would include cmm
code in libraries (other than the rts) that need to access RTS APIs.
In practice, this makes no difference whatsoever at the moment on any
platform other than windows (where building Haskell libs as shared libs
does not fully work yet), since the 'labelDynamic' treats all such
labels as foreign, irrespective of the foreign label source.
- - - - -
ebbfa6d3 by Duncan Coutts at 2025-12-05T12:06:16+00:00
Add cmm import syntax 'import DATA foo;' as better name for CLOSURE
The existing syntax is:
import CLOSURE foo;
The new syntax is
import DATA foo;
This means to interpret the symbol foo as refering to data (i.e. a
global constant or variable) rather than to code (a function). The
historical syntax for this uses CLOSURE, which is rather misleading.
Presumably this was done to avoid introducing new reserved words.
Be less squemish about new reserved words and add DATA and use that.
Keep the existing CLOSURE syntax as an alias for compatibility.
- - - - -
244b8b2b by Duncan Coutts at 2025-12-05T12:10:27+00:00
Add cmm 'import extern name;' syntax
Since the default for cmm imports is now for symbols within the same
shared object, we need a way to indicate we want a symbol from an
external shared object:
import extern foo; -- for a function
import extern DATA foo; -- for data
This adds a new reserved word 'extern'.
We don't expect to have to use this much. Most cmm imports are
intra-DSO.
This makes no difference currently on ELF and MachO platforms, but does
make a difference to the linking conventions on PE (Windows).
In future it's plausible we could take make distinctions on ELF or
MachO, so it's worth trying to get it right. Windows can be the guinea
pig.
- - - - -
06a95576 by Duncan Coutts at 2025-12-05T12:28:04+00:00
Add cmm syntax 'import "package" DATA foo;' for completeness
We already have:
import DATA foo; -- for data imports
import "package" foo; -- for imports from a given unitid
There's no reason not to have both at once:
import "package" DATA foo;
So add that.
- - - - -
2e4c159b by Duncan Coutts at 2025-12-05T12:28:04+00:00
Improve the commentary for the cmm import grammar.
AFAIK, this is the only place where GHC-style Cmm syntax is documented.
- - - - -
fd2954cd by Duncan Coutts at 2025-12-10T14:59:29+00:00
Add minimal dlltool support to ghc-toolchain
We will need dlltool to build ghc itself dynamically on windows, and
probably we will end up needing dlltool for ghc to build Haskell
packages dynamically as well.
The dlltool is a tool that can create dll import libraries from .def
files. These .def files list the exported symbols of dlls. Its somewhat
like gnu linker scripts, but more limited.
- - - - -
df3d4fab by Duncan Coutts at 2025-12-10T14:59:29+00:00
Add minimal dlltool support into ./configure
Find dlltool, and hopefully support finding it within the bundled llvm
toolchain on windows.
- - - - -
0855b657 by Duncan Coutts at 2025-12-10T14:59:29+00:00
Update the default host and target files for dlltool support
- - - - -
371dfa49 by Duncan Coutts at 2025-12-10T14:59:29+00:00
Add dlltool as a hadrian builder
Optional except on windows.
- - - - -
2818cd89 by Duncan Coutts at 2025-12-10T14:59:29+00:00
Update and generate libHSghc-internal.def from .def.in file
The only symbol that the rts imports from the ghc-internal package now
is init_ghc_hs_iface. So the rts only needs an import lib that defines
that one symbol.
Also, remove the libHSghc-prim.def because it is redundant. The rts no
longer imports anything from ghc-prim.
Keep libHSffi.def for now. We may yet need it once it is clear how
libffi is going to be built/used for ghc.
- - - - -
d22ed63b by Duncan Coutts at 2025-12-10T14:59:29+00:00
Add rule to build libHSghc-internal.dll.a and link into the rts
On windows only, with dynamic linking.
This is needed because on windows, all symbols in dlls must be resolved.
No dangling symbols allowed. References to external symbols must be
explicit. We resolve this with an import library. We create an import
library for ghc-internal, a .dll.a file. This is a static archive
containing .o files that define the symbols we need, and crucially have
".idata" sections that specifies the symbols the dll imports and from
where.
Note that we do not install this libHSghc-internal.dll.a, and it does
not need to list all the symbols exported by that package. We create a
special purpose import lib and only use it when linking the rts dll, so
it only has to list the symbols that the rts uses from ghc-internal
(which is exactly one symbol: init_ghc_hs_iface).
- - - - -
4131292d by Duncan Coutts at 2025-12-11T11:41:27+00:00
Merge branch 'wip/dcoutts/cmm-imports' into wip/dcoutts/windows-dlls
- - - - -
36d06c50 by Duncan Coutts at 2025-12-11T11:48:27+00:00
Merge branch 'wip/dcoutts/windows-rts-dll' into wip/dcoutts/windows-dlls
- - - - -
863db4f4 by Duncan Coutts at 2026-01-06T17:42:12+00:00
Enable dynamic lib support on Windows
This does not mean it works, it means the build system will now try to
build dynamic libs. We'll find out what breaks!
- - - - -
c4f9fe0c by Duncan Coutts at 2026-01-06T17:43:28+00:00
Hadrian: remove legacy rts .so symlinks
For compatibility with the old makefile based build system, hadrian had
rules to generate symlinks from unversioned to versioned names for the
rts .so/.dynlib file, like libHSrts-ghcx.y.so -> libHSrts-1.0.3-ghcx.y.so
We no longer need these symlinks since the makefile build system has
been retired some time ago. The need for these symlinks is awkward on
windows where we cannot (in practice) create symlinks. So rather than
make them conditional (non-windows), just remove them entirely.
- - - - -
ec1fa7ff by Duncan Coutts at 2026-01-06T17:59:07+00:00
Try enabling -dynamic-too on Windows
It ought to work, and otherwise we have to teach hadrian how to build
without using -dynamic-too.
- - - - -
8f9918c5 by Duncan Coutts at 2026-02-02T10:05:41+00:00
Try using response files for hadrian linking with ghc.
On windows, the link command line for ghc-internal is well over 32kb.
We did not encounter this before for static libs, since we already use
ar's @file feature (if available, which it is for the llvm toolchain).
We encounter this now on windows for linking dll files (which uses ghc
calling (l)ld rather than ar).
- - - - -
0d53e47b by Duncan Coutts at 2026-02-02T10:05:42+00:00
Use __attribute__(dllimport)) for external RTS symbol declarations
This is needed to be hygenic about DLL symbol imports and exports.
The attribute is ignored on platforms other than Windows.
Use of the attribute however means that external data symbols do not
have a compile-time constant address (they are loaded using an
indirection). This means we have to adjust the rtsSyms initial linker
table so that it is a local constant in a function, rather than a global
constant. We now define it within a function that pre-populates the
symbol table with the RTS symbols.
- - - - -
c07584ba by Duncan Coutts at 2026-02-02T10:05:42+00:00
Experiment with listing RTS symbols
- - - - -
48f4736b by Duncan Coutts at 2026-02-02T10:14:56+00:00
Experimental mingw .refptr mechanism support
- - - - -
b4011a99 by David Eichmann at 2026-05-21T16:14:16+01:00
Hadrian: create a ghc-internal .def file per ghc-internal dll
The .def file generated from rts/win32/libHSghc-internal.def.in contains
the name of the ghc-internal dll, but that differs based on if the dll
is inplace/final and what way it is. Previously, this was not accounted
for and inconsistent dlls names where used. That led to failure when
loading dlls are runtime in experiments with windows dynamic linking.
- - - - -
47 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitmodules
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Lexer.x
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Unit.hs
- compiler/GHC/StgToCmm/Lit.hs
- compiler/GHC/Unit/State.hs
- configure.ac
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- − hadrian/src/Rules/Libffi.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Rules/Rts.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- + libraries/libffi-clib
- m4/fp_setup_windows_toolchain.m4
- m4/ghc_toolchain.m4
- m4/prep_target_file.m4
- rts/Linker.c
- rts/RtsSymbols.c
- rts/RtsSymbols.h
- rts/configure.ac
- rts/include/rts/ghc_ffi.h
- rts/rts.buildinfo.in
- rts/rts.cabal
- − rts/win32/libHSghc-internal.def
- + rts/win32/libHSghc-internal.def.in
- − rts/win32/libHSghc-prim.def
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
- + utils/rts-syms/rts-syms.c
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5dcd268ddf0449496b789d1e8d5f3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5dcd268ddf0449496b789d1e8d5f3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/davide/windows-dlls-and-ghc-internal-def
by David Eichmann (@DavidEichmann) 21 May '26
by David Eichmann (@DavidEichmann) 21 May '26
21 May '26
David Eichmann pushed new branch wip/davide/windows-dlls-and-ghc-internal-def at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/davide/windows-dlls-and-ghc-i…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/semaphore-v2] 30 commits: Move the `Text.Read` implementation into `base`
by Zubin (@wz1000) 21 May '26
by Zubin (@wz1000) 21 May '26
21 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
44cf9cd7 by Wolfgang Jeltsch at 2026-05-12T09:48:18-04:00
Move the `Text.Read` implementation into `base`
- - - - -
4ac3f7d6 by Vladislav Zavialov at 2026-05-12T09:49:03-04:00
EPA: Use AnnParen for tuples and sums
Summary of changes
* Do not use AnnParen in XListTy, replace it with EpToken "[" and "]"
* Specialise AnnParen to tuple/sums by dropping the AnnParensSquare
and keeping only AnnParens and AnnParensHash
* Use AnnParen in XExplicitTuple
* Use AnnParen in XExplicitTupleTy
* Use AnnParen in XTuplePat
* Use AnnParen in XExplicitSum (via AnnExplicitSum)
* Use AnnParen in XSumPat (via EpAnnSumPat)
This is a refactoring with no user-facing changes.
- - - - -
1bdcddec by Duncan Coutts at 2026-05-12T09:49:48-04:00
Add minimal dlltool support to ghc-toolchain
The dlltool is a tool that can create dll import libraries from .def
files. These .def files list the exported symbols of dlls. Its somewhat
like gnu linker scripts, but more limited.
We will need dlltool to build the rts and ghc-internal libraries as DLLs
on Windows. The rts and ghc-internal libraries have a recursive
dependency on each other. Import libraries can be used to resolve
recursive dependencies between dlls. We will use an import library for
the rts when linking the ghc-internal library.
- - - - -
f7fc3770 by Duncan Coutts at 2026-05-12T09:49:48-04:00
Add minimal dlltool support into ./configure
Find dlltool, and hopefully support finding it within the bundled llvm
toolchain on windows.
- - - - -
e4e22bfb by Duncan Coutts at 2026-05-12T09:49:48-04:00
Update the default host and target files for dlltool support
- - - - -
5666c8f9 by Duncan Coutts at 2026-05-12T09:49:48-04:00
Add dlltool as a hadrian builder
Optional except on windows.
- - - - -
5e14fe3f by Duncan Coutts at 2026-05-12T09:49:48-04:00
Update and generate libHSghc-internal.def from .def.in file
The only symbol that the rts imports from the ghc-internal package now
is init_ghc_hs_iface. So the rts only needs an import lib that defines
that one symbol.
Also, remove the libHSghc-prim.def because it is redundant. The rts no
longer imports anything from ghc-prim.
Keep libHSffi.def for now. We may yet need it once it is clear how
libffi is going to be built/used for ghc.
- - - - -
3d91e4a6 by Duncan Coutts at 2026-05-12T09:49:48-04:00
Add rule to build libHSghc-internal.dll.a and link into the rts
On windows only, with dynamic linking.
This is needed because on windows, all symbols in dlls must be resolved.
No dangling symbols allowed. References to external symbols must be
explicit. We resolve this with an import library. We create an import
library for ghc-internal, a .dll.a file. This is a static archive
containing .o files that define the symbols we need, and crucially have
".idata" sections that specifies the symbols the dll imports and from
where.
Note that we do not install this libHSghc-internal.dll.a, and it does
not need to list all the symbols exported by that package. We create a
special purpose import lib and only use it when linking the rts dll, so
it only has to list the symbols that the rts uses from ghc-internal
(which is exactly one symbol: init_ghc_hs_iface).
- - - - -
c8dae539 by Alice Rixte at 2026-05-12T09:50:52-04:00
Script for downloading and copying `base-exports` file
- - - - -
5fab2238 by Wolfgang Jeltsch at 2026-05-12T21:24:27+03:00
Introduce a cache of home module name providers
This contribution introduces to the module graph a cache that maps home
module names to sets of units providing them and changes the finder to
use that cache. This is a performance optimization, especially for
multi-home-unit builds.
The particular changes are as follows:
* In `GHC.Unit.Module.Graph`, `ModuleGraph` is extended with a new
field `mg_home_module_name_providers_map`, exposed as
`mgHomeModuleNameProvidersMap`. This is a cache that assigns to each
home module name the set of IDs of home units that define it.
Operations that construct module graphs are updated such that this
cache stays synchronized.
* In `GHC.Unit.Finder`, `findImportedModule` is changed to pull
`mgHomeModuleNameProvidersMap` from `hsc_mod_graph` and pass it to
`findImportedModuleNoHsc`, which now does not search home units in
arbitrary order but prioritizes those units that the cache mentions
as potential providers of the requested module.
In addition, this contribution adds variants of the two multi-component
compiler performance tests that use 100 units instead of 20, because
with just 20 units the benefits from caching of home module name
providers are still negligible.
The following table shows the total time needed for running both
multi-component tests before and after this contribution and with
different numbers of units:
| # of units | Before | After |
|-----------:|-------:|------:|
| 20 | 0:12 | 0:12 |
| 100 | 0:47 | 0:42 |
| 200 | 3:05 | 2:08 |
Note that there seems to be a general overhead of 12 seconds that is not
attributable to the actual tests, so that the real running times should
be 12 seconds smaller than shown above.
Resolves #27055.
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
Co-authored-by: Matthew Pickering <matthewtpickering(a)gmail.com>
Co-authored-by: Fendor <fendor(a)posteo.de>
- - - - -
38b76b2f by Cheng Shao at 2026-05-13T17:48:48-04:00
testsuite: mark T22159 as fragile
This patch marks T22159 as fragile on Windows for issue described in #27248.
Before we get to the bottom of those failures, this unblocks newer
Windows runners.
- - - - -
50188615 by Ian Duncan at 2026-05-14T13:45:07+02:00
AArch64: use ASR not LSR for MO_U_Shr at W8/W16
The unsigned right shift (MO_U_Shr) for sub-word widths (W8, W16)
with a variable shift amount was emitting ASR (arithmetic/signed shift
right) after zero-extending with UXTB/UXTH. This should be LSR
(logical/unsigned shift right). After zero-extension the upper bits
happen to be 0 so ASR produces the same result, but it is semantically
wrong and would break if the zero-extension were ever optimized away.
Includes assembly output test (grep for lsr) and runtime test
verifying unsigned right shift of Word8 and Word16 values.
- - - - -
28666fbf by Vladislav Zavialov at 2026-05-19T12:44:05-04:00
Add type families: Tuple, Constraints, Tuple#, Sum# (#27179)
These type families map tuples of types to the corresponding Tuple<N>,
Tuple<N>#, CTuple<N>, and Sum<N># types. Some examples at N=2:
Tuple (Int, Bool) = Tuple2 Int Bool
Constraints (Show a, Eq a) = CTuple2 (Show a) (Eq a)
Tuple# (Int#, Float#) = Tuple2# Int# Float#
Sum# (Int#, Float#) = Sum2# Int# Float#
See GHC Proposal #145 "Non-punning list and tuple syntax".
To make the Sum# instance at N=64 possible, this patch also introduces
the Sum64# constructor declaration and bumps mAX_SUM_SIZE from 63 to 64.
Metric Increase:
ghc_experimental_dir
- - - - -
41c2448b by Wen Kokke at 2026-05-19T12:44:53-04:00
rts: Add IPE event class for -l
This commit adds a new IPE event class to the -l RTS flag.
Previously, IPE events were enabled unconditionally.
However, the IPE events can easily grow to hundreds or thousands of megabytes.
With the new event class you can pass, e.g., -l-I to disable IPE events.
- - - - -
62536551 by Wen Kokke at 2026-05-19T12:44:53-04:00
ghc-internal: Add TraceFlags.traceIPE
- - - - -
e45312d1 by Wen Kokke at 2026-05-19T12:44:53-04:00
testsuite: Add test for TraceFlags.traceIpe
- - - - -
4768d9aa by Wen Kokke at 2026-05-19T12:44:53-04:00
ghc-internal: Add DebugFlags.ipe
- - - - -
bc1b5c69 by Wen Kokke at 2026-05-19T12:44:53-04:00
testsuite: Add test for DebugFlags.ipe
- - - - -
0da1543f by Duncan Coutts at 2026-05-19T12:45:37-04:00
Document removal of the signal-based interval timer
Update mentions within the RTS section of the users guide.
Add a changelog entry.
- - - - -
b2911514 by Duncan Coutts at 2026-05-19T12:45:37-04:00
Fix section for an recent changelog entry
- - - - -
d6d76a7a by David Eichmann at 2026-05-19T12:46:19-04:00
ghc-toolchain: implement llvm program versioning logic
- - - - -
2dd36fa3 by Wolfgang Jeltsch at 2026-05-20T04:49:52-04:00
Turn `Trustworthy` into `Safe` in `base` where possible
- - - - -
f4399dd1 by Wolfgang Jeltsch at 2026-05-20T04:50:37-04:00
Make the current `base` buildable with GHC 10.0
- - - - -
1a7de232 by Duncan Coutts at 2026-05-20T12:26:25-04:00
Hadrian: remove legacy rts .so symlinks
For compatibility with the old makefile based build system, hadrian had
rules to generate symlinks from unversioned to versioned names for the
rts .so/.dynlib file, like libHSrts-ghcx.y.so -> libHSrts-1.0.3-ghcx.y.so
We no longer need these symlinks since the makefile build system has
been retired some time ago. The need for these symlinks is awkward on
windows where we cannot (in practice) create symlinks. So rather than
make them conditional (non-windows), just remove them entirely.
- - - - -
286f1adf by fendor at 2026-05-20T12:27:09-04:00
Fix regression T27202: `:load` and `:add` work in GHCi
To fix the regression there are conceptually two major things that we
fix:
* We don't remove the `importDirs` from `interactive-session`
* When `:add`ing a module, we don't try to find them via PackageImports
* The PackageImport is wrong as we can't know the package-name at
this stage in ghc/UI.hs
What does it mean to not remove the `importDirs` from
`interactive-session`?
It means that, given some initial `DynFlags`, we will use those
`importDirs` in `interactive-session`.
The initial `DynFlags`, however, depend on how you initialise the GHC
session.
For a simple session, initialised by
ghc -isrc -this-unit-id main
It is simple, just use the `DynFlags` given on the cli.
Thus, `main` and `interactive-session` will have the same `DynFlags`,
except for the `homeUnitId` and `interactive-session` depends on `main`
by construction of the GHCi session.
What about a multiple home unit session, though?
ghc -unit @unit1 -unit @unit2
What are the `DynFlags` in this cli invocation? It shouldn't be either
`@unti1` nor `@unit2`, as the order shouldn't matter or any other
implicit condition.
For consistency, we decide that the initial `DynFlags` are the top
`DynFlags` on the cli, ignoring `-unit` flags.
Thus, in this example, there are no `importsDirs` regardless of what we
might find in `@unit1` and `@unit2`.
But in this invocation:
ghc -isrc -unit @unit1 -unit @unit2
The `interactive-session` will have the `importsDirs` `src`.
Note, `-isrc` will be inherited in `@unit1` and `@unit2`, so you need to
explicitly use `-i` to clear the `importsDirs`, in order to avoid
accidentally adding `src` as an import directory to all other home
units.
This fix has been made possible by the improvements introduced in
!15888, which avoids ambiguity when a home unit shares the `importsDirs`
with the `interactive-session`, on top of being much faster for multiple
home units.
Adds regression tests for T27202 for `:load`ing and `:add`ing modules
that are located in import directories.
- - - - -
728662de by fendor at 2026-05-20T12:27:09-04:00
Use home unit package db stacks in GHCi prompt and session unit
In order to import modules from home unit dependencies (e.g., `Data.Map`),
the ghci prompt unit needs to populate its `UnitState`.
This is tricky to handle correctly, which `PackageDBFlag`s should we use
to populate the `UnitState`?
We decide, the most intuitive solution for users is to depend on all
`PackageDBFlag`s, so that any dependency can be imported in GHCi.
This assumes consistency in the `PackageDBFlag`s, so no two home units
specify `PackageDBFlag`s that are inconsistent with each other.
We could simply concat all the `PackageDBFlag`s of the existing home
units, but later `PackageDBFlag`s shadow earlier ones, leading to the
last processed home units' `PackageDBFlag`s to shadow the earlier ones.
This is hard to fix, we need to give users the capability to provide ghc
options for the ghci prompt home unit.
However, as this is considerably more work, we decided on an
approximation that should work out most of the time.
Package Db stacks in cabal and stack follow a certain structure:
-no-user-package-db > -package-db $cabal-store > -package-db $local-db
The first two arguments are always the same, namely the
`-no-user-package-db` and `-package-db`.
We compute the longest common prefix over all home units, and use that
as the start of the package db stack. Then, over the rest of the
`PackageDBFlag`s, we simply take the union and append them to our
initial stack.
We assume, that the rest of package dbs only defines very few, "local"
units that are usually not shadowing each other.
This allows us to get a relatively consistent package database stack for
the ghci prompt home unit.
Similar reasoning applies to the session unit in order to add modules to
the session and have dependencies available in the module.
We do something similar for `-package` flags, to make sure only the
correct units are actually visible in the ghci session.
This time, we simply take the union of all `PackageFlag`s, allowing us
to import modules from the home unit dependencies.
In the future, it would be beneficial to allow the user to provide the
exact ghc options to control the visibilities. For now, this will have
to do.
- - - - -
740d89a0 by Simon Peyton Jones at 2026-05-20T17:20:44-04:00
Do not use mkCast during typechecking
This commit fixes #27219. The problem was that the typechecker was using
`mkCast`, whose assertion checks legitimately fail when applied to types
that contain unification variables.
- - - - -
a50fdb06 by Simon Peyton Jones at 2026-05-20T17:20:45-04:00
Major refactor of the Simplifier
The main payload of this patch is to refactor the Simplifer to avoid
repeated simplification when using Plan (AFTER) for rule rewrites.
The need for this was shown up by #26989.
See Note [Avoid repeated simplification] in GHC.Core.Opt.Simplify.Iteration.
Related refactoring:
* Refactor the two fields `sc_dup` and `sc_env` in `ApplyToVal` into one, `sc_env`.
Reason: the envt is irrelevant in the "simplified" case, so the data type describes
the possiblitiies much more accurately now.
* Some refactoring in `knownCon` to split off `wrapDataConFloats`.
* Refactor `lookupRule` and its auxiliary functions to return `RuleMatch`,
a new data type. See Note [data RuleMatch] in GHC.Core. Ditto for BuiltinRule.
This RuleMatch returns fragments of the target in rm_args and rm_floats,
leaving `rm_rhs` to be the stuff from the RULE itself.
Doing this has routine consequences in GHC.Core.Opt.ConstantFold. Many changes
there but all routine.
* When doing occurrence analysis on RULEs, make the occ-info on the rule
binders relate just to the RHS, not the LHS. See (OUR1) in
Note Note [OccInfo in unfoldings and rules]
This means that Lint must not complain about the fact that the patterns
in the RULE mentions binders that are marked dead.
See Note [Dead occurrences] in GHC.Core.Lint.
I changed the Core pretty-printer so that it didn't suppress dead binders,
else I can't see those binders in RULEs. That led to quite a lot of testsuite wibbles.
* Refactor FloatBinds, so that it is used both by
`exprIsConApp_mabye` and by `lookupRule`
* Move the definition of FloatBinds out of GHc.Core.Make, into GHC.Core.
* Add FloatTick as an extra constructor.
* Refactor `lookupRule` to use `FloatBinds` instead of `BindWrapper`.
This refactor just shares more code.
(Rename GHC.Core.Opt.FloatOut.FloatBinds to FloatLets, to avoid gratuitious
name clash with GHC.Core.FloatBinds.)
Corecion optimisation
* In simpleOpt, when composing coercions, call new function `optTransCo`.
This is much lighter weight than full blown coercion optimisation.
* Make `GHC.Core.Opt.Arity.pushCoValArg` and `pushCoTyArg` return the
coercionLKind of the coercion. This saves recomputing that coercionLKind
at the key call sites in GHC.Core.Opt.Simplify.Iteration.pushCast.
* Rename `addCoerce` in GHC.Core.Simplify.Iteration to become `pushCast`.
* In the `ApplyToVal` case of `pushCast` we had a very unsavoury call to `simplArg`.
I eliminated it by adding a field `sc_cast` to `ApplyToVal` that records any
pending casts. Much nicer now. See Note [The sc_cast field of ApplyToVal].
* Don't optimise coercions if the type-substitution is empty.
See Note [Optimising coercions] in GHC.Core.Opt.Simplify.Iteration.
The fix for #26838 is dramatic. For the test in perf/compiler/T26839 we have
Compiler allocs: Before: 7,363M
After: 688M
Compile time goes down generally. Here are compiler-alloc changes
over 0.5%:
CoOpt_Read(normal) 729,184,920 -0.7%
CoOpt_Singletons(normal) 666,916,960 -4.6% GOOD
LargeRecord(normal) 1,227,056,876 +1.1%
T12227(normal) 256,827,604 -4.6% GOOD
T12425(optasm) 76,879,410 -0.8%
T12545(normal) 787,826,918 -10.8% GOOD
T12707(normal) 775,186,464 -0.9%
T13253(normal) 318,599,596 -0.8%
T14766(normal) 685,857,320 -1.0%
T15304(normal) 1,123,333,422 -2.2%
T15630(normal) 123,142,330 -2.6%
T15630a(normal) 123,092,100 -2.6%
T15703(normal) 299,751,682 -2.9% GOOD
T17516(normal) 964,072,280 +1.0%
T18223(normal) 367,016,820 -6.2% GOOD
T18730(optasm) 130,643,770 -3.3% GOOD
T20261(normal) 535,608,584 -0.7%
T21839c(normal) 340,340,436 -0.9%
T24984(normal) 85,568,392 -1.9%
T3064(normal) 174,631,992 -1.2%
T3294(normal) 1,215,886,432 -0.7%
T5030(normal) 141,449,704 -17.2% GOOD
T5321Fun(normal) 258,484,744 -1.9%
T8095(normal) 770,532,232 -2.7%
T9630(normal) 858,423,408 -14.5% GOOD
T9872c(normal) 1,591,709,448 +0.7%
info_table_map_perf(normal) 19,700,614,458 -1.3%
geo. mean -0.7%
minimum -17.2%
maximum +1.1%
However, strangely there seems to be a 5.0% increase in CoOpt_Read in
the x86_64-linux-fedora43-validate+debug_info+ubsan job, although
there generally a /decrease/ in this test in other builds. The baseline
value looks strange. Anyway I'll just accept it.
Metric Decrease:
CoOpt_Singletons
T12227
T12545
T12707
T15703
T18223
T18730
T21839c
T5030
T9630
Metric Increase:
CoOpt_Read
- - - - -
834623d4 by Mrjtjmn at 2026-05-20T17:21:41-04:00
users-guide: Fix weird notation in "Summary of stolen syntax"
- - - - -
5738f8b8 by Zubin Duggal at 2026-05-21T19:45:42+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
- - - - -
264 changed files:
- + changelog.d/T26979
- + changelog.d/T27202
- changelog.d/dynamic-trace-flags
- + changelog.d/ghc-api-epa-parens
- + changelog.d/ipe-event-class
- + changelog.d/jobserver-leak-fix
- + changelog.d/lib-add-tuple-tyfam-27179
- + changelog.d/more-efficient-home-unit-imports-finding
- + changelog.d/no-more-timer-signal
- + changelog.d/rts_symlinks.md
- + changelog.d/semaphore-v2
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/List/SetOps.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/MakeAction.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Settings/Constants.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- configure.ac
- distrib/configure.ac.in
- docs/users_guide/exts/stolen_syntax.rst
- docs/users_guide/exts/template_haskell.rst
- docs/users_guide/profiling.rst
- docs/users_guide/runtime_control.rst
- docs/users_guide/using-warnings.rst
- docs/users_guide/using.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/cabal.project
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Flavour.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Rules/Rts.hs
- hadrian/src/Settings/Packages.hs
- hadrian/stack.yaml
- libraries/base/src/Control/Exception.hs
- libraries/base/src/Control/Monad/IO/Class.hs
- libraries/base/src/Data/Data.hs
- libraries/base/src/Data/Fixed.hs
- libraries/base/src/Data/Functor/Classes.hs
- libraries/base/src/Data/Functor/Compose.hs
- libraries/base/src/Data/List/NonEmpty.hs
- libraries/base/src/Data/Version.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/ByteOrder.hs
- libraries/base/src/GHC/Exts.hs
- libraries/base/src/Numeric.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/System/Timeout.hs
- libraries/base/src/Text/Read.hs
- libraries/ghc-experimental/src/Data/Sum/Experimental.hs
- libraries/ghc-experimental/src/Data/Tuple/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- − libraries/ghc-internal/src/GHC/Internal/Text/Read.hs
- libraries/ghc-internal/src/GHC/Internal/Types.hs
- libraries/semaphore-compat
- m4/find_llvm_prog.m4
- m4/fp_setup_windows_toolchain.m4
- m4/ghc_toolchain.m4
- m4/prep_target_file.m4
- rts/.gitignore
- rts/IPE.c
- rts/RtsFlags.c
- rts/Trace.c
- rts/Trace.h
- rts/include/rts/EventLogWriter.h
- rts/include/rts/Flags.h
- + rts/win32/libHSghc-internal.def.in
- testsuite/tests/codeGen/should_compile/T25177.stderr
- + testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.asm
- + testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.hs
- + testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.asm
- + testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_run/aarch64-subword-ops.hs
- + testsuite/tests/codeGen/should_run/aarch64-subword-ops.stdout
- + testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.hs
- + testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/deSugar/should_compile/T13208.stdout
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/ffi/should_run/all.T
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/ghci/prog-mhu006/Makefile
- + testsuite/tests/ghci/prog-mhu006/a/A.hs
- + testsuite/tests/ghci/prog-mhu006/all.T
- + testsuite/tests/ghci/prog-mhu006/b/B.hs
- + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script
- + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout
- + testsuite/tests/ghci/prog-mhu006/unitA
- + testsuite/tests/ghci/prog-mhu006/unitB
- testsuite/tests/ghci/prog003/prog003.T
- testsuite/tests/ghci/prog018/prog018.stdout
- testsuite/tests/ghci/prog020/Makefile
- testsuite/tests/ghci/prog020/all.T
- testsuite/tests/ghci/prog020/ghci.prog020.script → testsuite/tests/ghci/prog020/ghci.prog020a.script
- testsuite/tests/ghci/prog020/ghci.prog020.stderr → testsuite/tests/ghci/prog020/ghci.prog020a.stderr
- testsuite/tests/ghci/prog020/ghci.prog020.stdout → testsuite/tests/ghci/prog020/ghci.prog020a.stdout
- + testsuite/tests/ghci/prog020/ghci.prog020b.script
- + testsuite/tests/ghci/prog020/ghci.prog020b.stderr
- + testsuite/tests/ghci/prog020/ghci.prog020b.stdout
- + testsuite/tests/ghci/prog023/Makefile
- + testsuite/tests/ghci/prog023/all.T
- + testsuite/tests/ghci/prog023/prog023a.script
- + testsuite/tests/ghci/prog023/prog023a.stdout
- + testsuite/tests/ghci/prog023/prog023b.script
- + testsuite/tests/ghci/prog023/prog023b.stdout
- + testsuite/tests/ghci/prog023/src/A.hs
- + testsuite/tests/ghci/prog024/Makefile
- + testsuite/tests/ghci/prog024/all.T
- + testsuite/tests/ghci/prog024/prog024a.script
- + testsuite/tests/ghci/prog024/prog024a.stdout
- + testsuite/tests/ghci/prog024/prog024b.script
- + testsuite/tests/ghci/prog024/prog024b.stdout
- + testsuite/tests/ghci/prog024/prog024c.script
- + testsuite/tests/ghci/prog024/prog024c.stderr
- + testsuite/tests/ghci/prog024/prog024c.stdout
- + testsuite/tests/ghci/prog024/prog024d.script
- + testsuite/tests/ghci/prog024/prog024d.stderr
- + testsuite/tests/ghci/prog024/prog024d.stdout
- + testsuite/tests/ghci/prog024/prog024e.script
- + testsuite/tests/ghci/prog024/prog024e.stdout
- + testsuite/tests/ghci/prog024/prog024f.script
- + testsuite/tests/ghci/prog024/prog024f.stdout
- + testsuite/tests/ghci/prog024/src/A.hs
- + testsuite/tests/ghci/prog024/src/B.hs
- + testsuite/tests/ghci/prog025/Makefile
- + testsuite/tests/ghci/prog025/a/A.hs
- + testsuite/tests/ghci/prog025/all.T
- + testsuite/tests/ghci/prog025/prog025a.script
- + testsuite/tests/ghci/prog025/prog025a.stdout
- + testsuite/tests/ghci/prog025/prog025b.script
- + testsuite/tests/ghci/prog025/prog025b.stdout
- + testsuite/tests/ghci/prog025/testpkg/Test.hs
- + testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg
- + testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg
- + testsuite/tests/ghci/prog025/unitA
- testsuite/tests/ghci/scripts/ListTuplePunsPprNoAbbrevTuple.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/should_run/T10920.stderr
- + testsuite/tests/interface-stability/.gitignore
- testsuite/tests/interface-stability/README.mkd
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- + testsuite/tests/interface-stability/download-base-exports.sh
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- testsuite/tests/linters/notes.stdout
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/numeric/should_compile/T20347.stderr
- testsuite/tests/numeric/should_compile/T20374.stderr
- testsuite/tests/numeric/should_compile/T20376.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/ListTuplePunsSuccess1.hs
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/parser/should_fail/ListTuplePunsFail6.hs
- + testsuite/tests/parser/should_fail/ListTuplePunsFail6.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/parser/should_run/ListTuplePunsConstraints.hs
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/T26989.hs
- + testsuite/tests/perf/compiler/T26989a.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/perf/compiler/genMultiComp.py
- testsuite/tests/printer/T18052a.stderr
- testsuite/tests/profiling/should_run/callstack001.stdout
- + testsuite/tests/rts/T25275/DebugIpe.hs
- + testsuite/tests/rts/T25275/T25275_A.stdout
- + testsuite/tests/rts/T25275/T25275_B.stdout
- + testsuite/tests/rts/T25275/T25275_C.stdout
- + testsuite/tests/rts/T25275/T25275_D.stdout
- + testsuite/tests/rts/T25275/TraceIpe.hs
- + testsuite/tests/rts/T25275/all.T
- testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
- testsuite/tests/simplCore/should_compile/RewriteHigherOrderPatterns.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T18668.stderr
- testsuite/tests/simplCore/should_compile/T19246.stderr
- testsuite/tests/simplCore/should_compile/T19599.stderr
- testsuite/tests/simplCore/should_compile/T19599a.stderr
- testsuite/tests/simplCore/should_compile/T21917.stderr
- testsuite/tests/simplCore/should_compile/T23074.stderr
- testsuite/tests/simplCore/should_compile/T24359a.stderr
- testsuite/tests/simplCore/should_compile/T25160.stderr
- testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32
- testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64
- testsuite/tests/simplCore/should_compile/T26051.stderr
- testsuite/tests/simplCore/should_compile/T26116.stderr
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/T8848a.stderr
- testsuite/tests/simplCore/should_compile/spec004.stderr
- testsuite/tests/th/T24111.stdout
- testsuite/tests/typecheck/should_compile/T13032.stderr
- + testsuite/tests/typecheck/should_compile/T23135.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T21130.stderr
- utils/check-exact/ExactPrint.hs
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e8ddc1b02eec710e3bf87db4068ac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e8ddc1b02eec710e3bf87db4068ac…
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) 21 May '26
by Zubin (@wz1000) 21 May '26
21 May '26
Zubin pushed to branch wip/semaphore-v2 at Glasgow Haskell Compiler / GHC
Commits:
8e8ddc1b by Zubin Duggal at 2026-05-21T18:50:52+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
- - - - -
21 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/cabal.project
- hadrian/hadrian.cabal
- hadrian/src/Flavour.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Packages.hs
- hadrian/stack.yaml
- 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
=====================================
@@ -2445,6 +2445,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
=====================================
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/cabal.project
=====================================
@@ -1,6 +1,7 @@
packages: ./
../utils/ghc-toolchain/
../libraries/ghc-platform/
+ ../libraries/semaphore-compat/
-- This essentially freezes the build plan for hadrian
-- It would be wise to keep this up to date with the state set in .gitlab/ci.sh.
=====================================
hadrian/hadrian.cabal
=====================================
@@ -172,6 +172,7 @@ executable hadrian
, base16-bytestring >= 0.1.1 && < 1.1.0.0
, ghc-platform
, ghc-toolchain
+ , semaphore-compat
ghc-options: -Wall
-Wincomplete-record-updates
-Wredundant-constraints
=====================================
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
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -25,6 +25,7 @@ import Utilities
import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp))
import GHC.Platform.ArchOS
import Settings.Program (ghcWithInterpreter)
+import System.Semaphore (semaphoreVersion, getSemaphoreProtocolVersion)
-- | Track this file to rebuild generated files whenever it changes.
trackGenerateHs :: Expr ()
@@ -488,6 +489,7 @@ generateSettings settingsFile = do
, ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays)
, ("Relative Global Package DB", pure rel_pkg_db)
, ("base unit-id", pure base_unit_id)
+ , ("Semaphore version", pure (show (getSemaphoreProtocolVersion semaphoreVersion)))
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -231,6 +231,10 @@ packageArgs = do
, package hpcBin
? builder (Cabal Flags) ? arg "-build-tool-depends"
+ ------------------------------ semaphore-compat ----------------------------
+ , package semaphoreCompat
+ ? builder (Cabal Flags) ? arg "-build-testing"
+
]
ghcInternalArgs :: Args
=====================================
hadrian/stack.yaml
=====================================
@@ -16,6 +16,7 @@ packages:
- '.'
- '../utils/ghc-toolchain'
- '../libraries/ghc-platform'
+- '../libraries/semaphore-compat'
nix:
enable: false
=====================================
libraries/semaphore-compat
=====================================
@@ -1 +1 @@
-Subproject commit 7929702401d49bc64d809c501ed5fe80aebc3cc1
+Subproject commit f7772b53fec5d411fee20727c79905d7939d137d
=====================================
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/8e8ddc1b02eec710e3bf87db4068ac7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e8ddc1b02eec710e3bf87db4068ac7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/module-graph-reuse-in-downsweep] Add preliminary version of `IncrementalDownsweep` test
by Wolfgang Jeltsch (@jeltsch) 21 May '26
by Wolfgang Jeltsch (@jeltsch) 21 May '26
21 May '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC
Commits:
eedd0f1f by Wolfgang Jeltsch at 2026-05-21T15:13:43+03:00
Add preliminary version of `IncrementalDownsweep` test
- - - - -
10 changed files:
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/A.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/B.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/C.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/D.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/X.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Y.hs
- + testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Z.hs
- testsuite/tests/ghc-api/downsweep/all.T
Changes:
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs
=====================================
@@ -0,0 +1,89 @@
+{-# LANGUAGE Haskell2010 #-}
+
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+import Control.Monad (unless)
+import Control.Monad.IO.Class (liftIO)
+import Control.Arrow ((>>>))
+import Data.List (sort)
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+import System.IO (stderr)
+import Language.Haskell.Syntax.Module.Name (moduleNameString)
+import GHC.Utils.Ppr (Mode (PageMode))
+import GHC.Utils.Outputable (vcat, defaultSDocContext, printSDocLn, ppr)
+import GHC.Utils.Logger (getLogger)
+import GHC.Types.SrcLoc (noLoc)
+import GHC.Types.Error (mkUnknownDiagnostic)
+import GHC.Unit.Types (moduleName)
+import GHC.Unit.Module.ModSummary (ms_mod)
+import GHC.Unit.Module.Graph (ModuleGraph, mgModSummaries)
+import GHC.Driver.DynFlags (defaultFatalMessager, defaultFlushOut)
+import GHC.Driver.Monad (Ghc, getSession, getSessionDynFlags)
+import GHC.Driver.Make (downsweep)
+import GHC.Driver.Errors.Types (DriverMessages)
+import GHC
+ (
+ defaultErrorHandler,
+ guessTarget,
+ setTargets,
+ parseDynamicFlags,
+ setSessionDynFlags,
+ runGhc
+ )
+
+sourceDirectory :: String
+sourceDirectory = "IncrementalDownsweep"
+
+withSimpleErrorHandler :: Ghc a -> Ghc a
+withSimpleErrorHandler = defaultErrorHandler defaultFatalMessager
+ defaultFlushOut
+
+handleDriverMessages :: [DriverMessages] -> IO ()
+handleDriverMessages driverMsgs
+ = unless (null driverMsgs) $
+ do
+ printSDocLn defaultSDocContext
+ (PageMode True)
+ stderr
+ (vcat (map ppr driverMsgs))
+ exitFailure
+
+performDownsweepTurn :: Maybe ModuleGraph -> String -> Ghc ModuleGraph
+performDownsweepTurn maybeGivenModuleGraph rootModuleName = do
+ target <- guessTarget rootModuleName Nothing Nothing
+ setTargets [target]
+ session <- getSession
+ (driverMsgs, resultingModuleGraph)
+ <- liftIO $ downsweep session
+ mkUnknownDiagnostic
+ Nothing
+ []
+ maybeGivenModuleGraph
+ []
+ False
+ liftIO $ handleDriverMessages driverMsgs
+ return resultingModuleGraph
+
+outputModuleNamesInGraph :: ModuleGraph -> IO ()
+outputModuleNamesInGraph = mgModSummaries >>>
+ map (ms_mod >>> moduleName >>> moduleNameString) >>>
+ sort >>>
+ print
+
+main :: IO ()
+main = do
+ libDir : otherArgs <- getArgs
+ runGhc (Just libDir) $ withSimpleErrorHandler $ do
+ logger <- getLogger
+ originalDynFlags <- getSessionDynFlags
+ (finalDynFlags, _, _)
+ <- parseDynamicFlags logger originalDynFlags $
+ map noLoc (["-i", "-i" ++ sourceDirectory] ++ otherArgs)
+ _ <- setSessionDynFlags finalDynFlags
+ intermediateModuleGraph
+ <- performDownsweepTurn Nothing "A"
+ liftIO $ outputModuleNamesInGraph intermediateModuleGraph
+ finalModuleGraph
+ <- performDownsweepTurn (Just intermediateModuleGraph) "X"
+ liftIO $ outputModuleNamesInGraph finalModuleGraph
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout
=====================================
@@ -0,0 +1,2 @@
+["A","B","C","D"]
+["A","B","C","D","X","Y","Z"]
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/A.hs
=====================================
@@ -0,0 +1,4 @@
+module A where
+
+import B
+import C
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/B.hs
=====================================
@@ -0,0 +1,3 @@
+module B where
+
+import D
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/C.hs
=====================================
@@ -0,0 +1,3 @@
+module C where
+
+import D
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/D.hs
=====================================
@@ -0,0 +1 @@
+module D where
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/X.hs
=====================================
@@ -0,0 +1,4 @@
+module X where
+
+import Y
+import Z
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Y.hs
=====================================
@@ -0,0 +1,3 @@
+module Y where
+
+import B
=====================================
testsuite/tests/ghc-api/downsweep/IncrementalDownsweep/Z.hs
=====================================
@@ -0,0 +1,3 @@
+module Z where
+
+import C
=====================================
testsuite/tests/ghc-api/downsweep/all.T
=====================================
@@ -14,3 +14,9 @@ test('OldModLocation',
],
compile_and_run,
['-package ghc'])
+
+test('IncrementalDownsweep',
+ [ extra_run_opts('"' + config.libdir + '"')
+ ],
+ compile_and_run,
+ ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eedd0f1ffa036c7552e68a3cff12ea4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eedd0f1ffa036c7552e68a3cff12ea4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 2 commits: Deal with 'noSpec' in 'coreExprToPmLit'
by Magnus (@MangoIV) 21 May '26
by Magnus (@MangoIV) 21 May '26
21 May '26
Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC
Commits:
258f3c10 by sheaf at 2026-05-21T12:36:28+02:00
Deal with 'noSpec' in 'coreExprToPmLit'
This commit makes two separate changes relating to
'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit':
1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical,
which led to the introduction of 'nospec' wrappers in the
generated Core. This reverts that accident by declaring deferred
errors as being canonical, avoiding spurious 'nospec' wrapping.
2. Look through magic identity-like Ids such as 'nospec', 'inline' and
'lazy' in 'coreExprAsPmLit', just like Core Prep does.
There might genuinely be incoherent evidence, but that shouldn't
obstruct the pattern match checker. See test T27124a.
Fixes #25926 #27124
-------------------------
Metric Decrease:
T3294
-------------------------
(cherry picked from commit e8a196c65cee32f06c3d99b74af33457511408c7)
- - - - -
7eb7f6ed by Luite Stegeman at 2026-05-21T13:17:47+02:00
CodeOutput: Fix finalizers on multiple platforms
- ELF platforms: emit .fini_array section
- wasm32/Darwin: emit initializer with __cxa_atexit call
- Windows: use -Wl,--whole-archive to prevent dropping finalizer symbols
- rts linker: fix crash/assertion failure unloading objects with finalizers
fixes #27072
(cherry picked from commit 014087e7a5753687161a24a1b2bc55c7bf7273fd)
- - - - -
30 changed files:
- + changelog.d/T27124.md
- + changelog.d/fix-finalizers-27072
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Types/ForeignStubs.hs
- rts/Linker.c
- rts/LinkerInternals.h
- + testsuite/tests/codeGen/should_run/T27072d.hs
- + testsuite/tests/codeGen/should_run/T27072d.stdout
- + testsuite/tests/codeGen/should_run/T27072d_c.c
- + testsuite/tests/codeGen/should_run/T27072d_check.c
- + testsuite/tests/codeGen/should_run/T27072w.hs
- + testsuite/tests/codeGen/should_run/T27072w.stdout
- + testsuite/tests/codeGen/should_run/T27072w_c.c
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/overloadedstrings/should_fail/T25926.hs
- + testsuite/tests/overloadedstrings/should_fail/T25926.stderr
- + testsuite/tests/overloadedstrings/should_fail/T27124.hs
- + testsuite/tests/overloadedstrings/should_fail/T27124.stderr
- + testsuite/tests/overloadedstrings/should_fail/all.T
- + testsuite/tests/overloadedstrings/should_run/T27124a.hs
- testsuite/tests/overloadedstrings/should_run/all.T
- + testsuite/tests/rts/linker/T27072/Lib.c
- + testsuite/tests/rts/linker/T27072/Makefile
- + testsuite/tests/rts/linker/T27072/T27072.stdout
- + testsuite/tests/rts/linker/T27072/all.T
- + testsuite/tests/rts/linker/T27072/main.c
Changes:
=====================================
changelog.d/T27124.md
=====================================
@@ -0,0 +1,10 @@
+section: compiler
+issues: #25926 #27124
+mrs: !15895
+synopsis:
+ Fix "failed to detect OverLit" panic in the pattern-match checker.
+description:
+ Fixed an issue in which overloaded literals (e.g. numeric literals, overloaded
+ strings with -XOverloadedStrings, overloaded lists, etc) could cause a GHC
+ crash when using -fdefer-type-errors, with an error message of the form
+ "failed to detect OverLit".
=====================================
changelog.d/fix-finalizers-27072
=====================================
@@ -0,0 +1,10 @@
+section: codegen
+synopsis: Fix module finalizers on multiple platforms
+description: {
+ GHC-generated module finalizers (e.g. ``hs_spt_remove`` for the Static
+ Pointer Table) now run correctly on ELF platforms, darwin, wasm32 and
+ Windows. Also fixes running finalizers when unloading objects with the
+ RTS linker.
+}
+issues: #27072
+mrs: !15762
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1125,6 +1125,9 @@ cpeApp top_env expr
|| f `hasKey` nospecIdKey -- Replace (nospec a) with a
-- See Note [nospecId magic] in GHC.Types.Id.Make
+ -- NB: keep this in sync with GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit,
+ -- as that also needs to see through these magic Ids.
+
-- Consider the code:
--
-- lazy (f x) y
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -124,6 +124,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
{ a <- linted_cmm_stream
; let stubs = genForeignStubs a
; emitInitializerDecls this_mod stubs
+ ; emitFinalizerDecls this_mod stubs
; return (stubs, a) }
; let dus1 = newTagDUniqSupply 'n' dus0
@@ -138,19 +139,23 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
}
-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
-emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup ()
-emitInitializerDecls this_mod (ForeignStubs _ cstub)
- | initializers <- getInitializers cstub
- , not $ null initializers =
- let init_array = CmmData sect statics
- lbl = mkInitializerArrayLabel this_mod
- sect = Section InitArray lbl
+emitInitializerDecls, emitFinalizerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup ()
+emitInitializerDecls = emitInitFiniArrayDecls InitArray mkInitializerArrayLabel getInitializers
+emitFinalizerDecls = emitInitFiniArrayDecls FiniArray mkFinalizerArrayLabel getFinalizers
+
+emitInitFiniArrayDecls :: SectionType -> (Module -> CLabel) -> (CStub -> [CLabel])
+ -> Module -> ForeignStubs -> CgStream RawCmmGroup ()
+emitInitFiniArrayDecls sect_type mk_lbl get_labels this_mod (ForeignStubs _ cstub)
+ | labels <- get_labels cstub
+ , not $ null labels =
+ let lbl = mk_lbl this_mod
+ sect = Section sect_type lbl
statics = CmmStaticsRaw lbl
[ CmmStaticLit $ CmmLabel fn_name
- | fn_name <- initializers
+ | fn_name <- labels
]
- in Stream.yield [init_array]
-emitInitializerDecls _ _ = return ()
+ in Stream.yield [CmmData sect statics]
+emitInitFiniArrayDecls _ _ _ _ _ = return ()
doOutput :: String -> (Handle -> IO a) -> IO a
doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
=====================================
compiler/GHC/HsToCore/Pmc/Solver/Types.hs
=====================================
@@ -626,6 +626,15 @@ coreExprAsPmLit :: CoreExpr -> Maybe PmLit
coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e
coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l
coreExprAsPmLit e = case collectArgs e of
+
+ -- Look through nospec, noinline and lazy, which are only eliminated by Core Prep.
+ -- See Note [coreExprAsPmLit and nospec]
+ (Var x, Type _ : inner : rest_args)
+ | x `hasKey` nospecIdKey
+ || x `hasKey` noinlineIdKey
+ || x `hasKey` lazyIdKey
+ -> coreExprAsPmLit (mkApps inner rest_args)
+
(Var x, [Lit l])
| Just dc <- isDataConWorkId_maybe x
, dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]
@@ -768,6 +777,34 @@ with large exponents case. This will return a `PmLitOverRat` literal.
Which is then passed to overloadPmLit which simply returns it as-is since
it's already overloaded.
+Note [coreExprAsPmLit and nospec]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For coverage checking, we need to analyse overloaded literal patterns to figure
+out which literals they correspond to; this is what 'coreExprAsPmLit' does.
+For example, the literal pattern "fromString" (with -XOverloadedStrings)
+will turn into an equality check against the **expression**
+
+ fromString @T $dFromString "hello"#
+
+and 'coreExprAsPmLit' recovers the string by taking apart this application.
+
+However, when $dFromString is non-canonical (e.g. when an INCOHERENT
+instance was discarded during resolution of the typeclass constraint, or when
+the dictionary comes from 'withDict'), the desugarer wraps 'fromString' in
+'nospec' (as per Note [nospecId magic] in GHC.Types.Id.Make and
+Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr):
+
+ nospec @(IsString a => String -> Maybe a) fromString @T $dFromString "hello"#
+
+(For a full example, see test case T27124a.)
+
+The 'nospec' mechanism only exists for the specialiser; it should be transparent
+to everything else. 'coreExprAsPmLit' must thus look through the 'nospec'
+application in order obtain the string "hello". If it doesn't, we can't do
+pattern match checking (in fact GHC.HsToCore.Pmc.Desugar.desugarPat is liable
+to crash!).
+
+The same reasoning applies to `noinline` and `lazy`.
-}
instance Outputable PmLitValue where
=====================================
compiler/GHC/Linker/Static.hs
=====================================
@@ -241,7 +241,20 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
then ["-Wl,--gc-sections"]
else [])
- ++ o_files
+ -- On Windows, module .o files may be archives (see
+ -- Note [Object merging] in GHC.Driver.Pipeline.Execute).
+ -- Use --whole-archive to ensure all archive members are
+ -- included, especially those containing .ctors/.dtors
+ -- initializer/finalizer sections. See Note [Initializers and
+ -- finalizers in Cmm] in GHC.Cmm.InitFini.
+ ++ (if platformOS platform == OSMinGW32
+ then ["-Wl,--whole-archive"]
+ else [])
+ ++ o_files
+ ++ (if platformOS platform == OSMinGW32
+ then ["-Wl,--no-whole-archive"]
+ else [])
+
++ lib_path_opts)
++ extra_ld_inputs
++ map GHC.SysTools.Option (
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1217,11 +1217,11 @@ addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty
; case dest of
EvVarDest evar
- -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvNonCanonical err_tm
+ -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvCanonical err_tm
HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes]
let co_var = coHoleCoVar hole
- ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm
+ ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvCanonical err_tm
; fillCoercionHole hole (mkCoVarCo co_var) } }
addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given
=====================================
compiler/GHC/Types/ForeignStubs.hs
=====================================
@@ -60,11 +60,85 @@ initializerCStub platform clbl declarations body =
-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer
-- function (e.g. an entry of the @.fini_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
+--
+-- See Note [Finalizers via __cxa_atexit]
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
-finalizerCStub platform clbl declarations body =
- functionCStub platform clbl declarations body
+finalizerCStub platform clbl declarations body
+ | ArchWasm32 <- platformArch platform
+ = -- See Note [Finalizers via __cxa_atexit]
+ cxaAtexitFinalizerCStub platform clbl declarations body
+finalizerCStub platform clbl declarations body
+ | OSDarwin <- platformOS platform
+ = -- See Note [Finalizers via __cxa_atexit]
+ cxaAtexitFinalizerCStub platform clbl declarations body
+finalizerCStub platform clbl declarations body
+ = functionCStub platform clbl declarations body
`mappend` CStub empty [] [clbl]
+-- | Generate a @__cxa_atexit@-based finalizer.
+-- See Note [Finalizers via __cxa_atexit]
+cxaAtexitFinalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
+cxaAtexitFinalizerCStub platform clbl declarations body =
+ let clbl_pretty = pprCLabel platform clbl
+ fini_name = hcat [clbl_pretty, text "$fini"]
+ wrapper_name = hcat [clbl_pretty, text "$fini_atexit"]
+ c_code = vcat
+ [ declarations
+ , text "int __cxa_atexit(void (*)(void *), void *, void *);"
+ , hcat [text "static void ", fini_name, text "(void)"]
+ , braces body
+ , hcat [text "static void ", wrapper_name, text "(void *arg __attribute__((unused)))"]
+ , braces (hcat [fini_name, text "();"])
+ , hsep [text "void", clbl_pretty, text "(void)"]
+ , braces (hcat [text "__cxa_atexit(", wrapper_name, text ", 0, 0);"])
+ ]
+ in CStub c_code [clbl] []
+
+{-
+Note [Finalizers via __cxa_atexit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On some platforms, placing a function pointer in the .fini_array /
+__mod_term_func section is not sufficient to have it called on exit.
+On these platforms we instead lower finalizers as initializers that register
+the actual finalizer function via __cxa_atexit.
+
+Affected platforms:
+
+ Wasm32: does not support .fini_array sections.
+
+ Darwin: modern macOS dyld no longer processes __DATA,__mod_term_func entries.
+ Clang now lowers __attribute__((destructor)) as an initializer that calls
+ __cxa_atexit, placing the initializer in __DATA,__mod_init_func (which the
+ linker converts to __TEXT,__init_offsets). GHC must follow the same pattern.
+
+For a finalizer with label `clbl` and body `body`, on these platforms we
+generate:
+
+ static void clbl$fini(void) {
+ <body>
+ }
+ static void clbl$fini_atexit(void *arg) {
+ clbl$fini();
+ }
+ void clbl(void) {
+ __cxa_atexit(clbl$fini_atexit, 0, 0);
+ }
+
+The function `clbl` is placed in the initializers list (getInitializers)
+instead of the finalizers list (getFinalizers). During code output,
+emitInitializerDecls places it in .init_array / __mod_init_func, so the
+registration runs at startup.
+
+The actual finalizer body is in the static helper `clbl$fini`. A separate
+wrapper `clbl$fini_atexit` with the void(*)(void*) signature expected by
+__cxa_atexit is needed because some platforms (e.g. wasm32) enforce exact
+function signature matching at call sites — a simple cast would trap at
+runtime.
+
+This matches what clang does when lowering __attribute__((destructor)) on
+these platforms.
+-}
+
newtype CHeader = CHeader { getCHeader :: SDoc }
instance Monoid CHeader where
=====================================
rts/Linker.c
=====================================
@@ -1107,6 +1107,27 @@ freePreloadObjectFile (ObjectCode *oc)
oc->fileSize = 0;
}
+/* Note [Object unloading and finalizers]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * An ObjectCode may contain .fini_array/.dtors sections with finalizers that
+ * should run when the object is unloaded. However, we must only run these
+ * finalizers if the corresponding initializers (.init_array/.ctors) have
+ * actually been executed.
+ *
+ * Archive members start in OBJECT_LOADED state and only progress to
+ * OBJECT_NEEDED -> OBJECT_RESOLVED -> OBJECT_READY when a symbol from
+ * them is actually required. An archive member that was never needed never
+ * has its relocations applied, so its .fini_array section data still
+ * contains zeros (unresolved relocation targets). Running those finalizers
+ * would dereference NULL function pointers.
+ *
+ * When unloadObj sets an object's status to OBJECT_UNLOADED, it does so
+ * regardless of the previous state, so we cannot rely on the status alone
+ * to decide whether finalizers should run. Instead, we track whether
+ * initializers were executed via the initializersRan flag, which is set in
+ * ocRunInit after successfully running the initializers.
+ */
+
/*
* freeObjectCode() releases all the pieces of an ObjectCode. It is called by
* the GC when a previously unloaded ObjectCode has been determined to be
@@ -1116,11 +1137,9 @@ void freeObjectCode (ObjectCode *oc)
{
IF_DEBUG(linker, ocDebugBelch(oc, "freeObjectCode: start\n"));
- // Run finalizers
- if (oc->type == STATIC_OBJECT &&
- (oc->status == OBJECT_READY || oc->status == OBJECT_UNLOADED)) {
- // Only run finalizers if the initializers have also been run, which
- // happens when we resolve the object.
+ // Run finalizers only if initializers have been run.
+ // See Note [Object unloading and finalizers].
+ if (oc->type == STATIC_OBJECT && oc->initializersRan) {
#if defined(OBJFORMAT_ELF)
ocRunFini_ELF(oc);
#elif defined(OBJFORMAT_PEi386)
@@ -1285,6 +1304,7 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
oc->imageMapped = mapped;
oc->misalignment = misalignment;
+ oc->initializersRan = false;
oc->cxa_finalize = NULL;
oc->extraInfos = NULL;
@@ -1681,6 +1701,7 @@ int ocRunInit(ObjectCode *oc)
foreignExportsFinishedLoadingObject();
if (!r) { return r; }
+ oc->initializersRan = true;
oc->status = OBJECT_READY;
return 1;
=====================================
rts/LinkerInternals.h
=====================================
@@ -268,6 +268,12 @@ struct _ObjectCode {
after allocation, so that we can use realloc */
int misalignment;
+ /* Set to true after initializers (.init_array, .ctors, etc.) have been
+ * executed. Used by freeObjectCode to decide whether finalizers should
+ * run: only objects whose initializers ran should have their finalizers
+ * executed. See Note [Object unloading and finalizers]. */
+ bool initializersRan;
+
/* The address of __cxa_finalize; set when at least one finalizer was
* register and therefore we must call __cxa_finalize before unloading.
* See Note [Resolving __dso_handle]. */
=====================================
testsuite/tests/codeGen/should_run/T27072d.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE StaticPointers #-}
+module T27072d where
+
+import GHC.StaticPtr
+
+f :: StaticPtr Int
+f = static 1
+
+g :: StaticPtr Int
+g = static 2
=====================================
testsuite/tests/codeGen/should_run/T27072d.stdout
=====================================
@@ -0,0 +1,2 @@
+SPT entries after init: 2
+SPT entries after finalizer: 0
=====================================
testsuite/tests/codeGen/should_run/T27072d_c.c
=====================================
@@ -0,0 +1,38 @@
+// Test that GHC-generated module initializers and finalizer registrations
+// work correctly on Darwin.
+//
+// On Darwin, GHC lowers finalizers as __cxa_atexit registrations from an
+// initializer placed in __DATA,__mod_init_func (see Note [Finalizers via
+// __cxa_atexit] in GHC.Types.ForeignStubs).
+//
+// This test verifies the mechanism by checking that:
+// 1. The SPT initializer runs at load time (entries are inserted).
+// 2. The SPT finalizer (registered via __cxa_atexit from __mod_init_func)
+// fires during exit() and removes the entries.
+//
+// We verify (2) by registering our own __cxa_atexit checker from a
+// constructor in a dylib that is loaded before the main executable's
+// initializers run. Since __cxa_atexit handlers fire in LIFO order,
+// a handler registered earlier runs later — so our checker runs after the
+// GHC-generated finalizer, and can observe that SPT entries were removed.
+//
+// The Apple linker does not support --wrap, so this is the Darwin
+// equivalent of T27072w's approach.
+
+#include "Rts.h"
+#include <stdio.h>
+
+extern int hs_spt_key_count(void);
+
+int main(int argc, char *argv[]) {
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+
+ printf("SPT entries after init: %d\n", hs_spt_key_count());
+ fflush(stdout);
+
+ // Do NOT call hs_exit(). Return normally so __cxa_atexit handlers fire,
+ // which includes the GHC-generated finalizer registered during init.
+ return 0;
+}
=====================================
testsuite/tests/codeGen/should_run/T27072d_check.c
=====================================
@@ -0,0 +1,29 @@
+// Checker dylib for T27072d.
+//
+// Compiled as a dylib and linked against the test executable. Because dylib
+// initializers run before the main executable's __mod_init_func entries,
+// our __cxa_atexit registration happens first. Since __cxa_atexit handlers
+// fire in LIFO order, our checker runs *after* the GHC-generated finalizer,
+// allowing us to observe that SPT entries were removed.
+
+#include <stdio.h>
+
+// Provided by the RTS.
+extern int hs_spt_key_count(void);
+
+static void check_spt_finalizer(void *arg __attribute__((unused))) {
+ int count = hs_spt_key_count();
+ printf("SPT entries after finalizer: %d\n", count);
+ fflush(stdout);
+}
+
+// Register the checker. This constructor runs during dylib initialization,
+// which happens before the main executable's initializers.
+__attribute__((constructor))
+static void register_spt_checker(void) {
+ // Use __cxa_atexit so we participate in the same LIFO chain as the
+ // GHC-generated finalizer.
+ extern int __cxa_atexit(void (*)(void *), void *, void *);
+ extern void *__dso_handle;
+ __cxa_atexit(check_spt_finalizer, (void *)0, &__dso_handle);
+}
=====================================
testsuite/tests/codeGen/should_run/T27072w.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE StaticPointers #-}
+module T27072w where
+
+import GHC.StaticPtr
+
+f :: StaticPtr Int
+f = static 1
+
+g :: StaticPtr Int
+g = static 2
=====================================
testsuite/tests/codeGen/should_run/T27072w.stdout
=====================================
@@ -0,0 +1,3 @@
+SPT entries after init: 2
+finalizer: hs_spt_remove called
+finalizer: hs_spt_remove called
=====================================
testsuite/tests/codeGen/should_run/T27072w_c.c
=====================================
@@ -0,0 +1,32 @@
+// Test that GHC-generated finalizers actually run on wasm32
+//
+// We use --wrap=hs_spt_remove to intercept calls from the GHC-generated
+// finalizer and verify they happen during exit().
+
+#include "Rts.h"
+#include <stdio.h>
+
+extern int hs_spt_key_count(void);
+
+// --wrap=hs_spt_remove: the linker redirects all calls to hs_spt_remove
+// through our wrapper, and provides __real_hs_spt_remove for the original.
+extern void __real_hs_spt_remove(StgWord64 key[2]);
+
+void __wrap_hs_spt_remove(StgWord64 key[2]) {
+ printf("finalizer: hs_spt_remove called\n");
+ fflush(stdout);
+ __real_hs_spt_remove(key);
+}
+
+int main(int argc, char *argv[]) {
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+
+ printf("SPT entries after init: %d\n", hs_spt_key_count());
+ fflush(stdout);
+
+ // Do NOT call hs_exit(). Return normally so exit() fires the
+ // __cxa_atexit registered handlers.
+ return 0;
+}
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -256,3 +256,22 @@ test('T24893', normal, compile_and_run, ['-O'])
test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c'])
test('T26061', normal, compile_and_run, [''])
test('T26537', js_broken(26558), compile_and_run, ['-O2 -fregs-graph'])
+
+# Check that GHC-generated finalizers run on Darwin. The Apple linker doesn't
+# support --wrap, so we can't intercept hs_spt_remove directly. Instead we
+# compile a small checker dylib (T27072d_check.c) whose constructor registers
+# a __cxa_atexit handler *before* the executable's __mod_init_func entries run.
+# LIFO ordering ensures the checker fires after the GHC-generated finalizer,
+# so it can observe that SPT entries were removed.
+# Requires dynamic way so the RTS is a dylib (avoids archive conflicts).
+test('T27072d', [req_c, only_ways(['dyn']), when(not opsys('darwin'), skip),
+ pre_cmd('{compiler} -shared -no-hs-main'
+ ' -optl -undefined -optl dynamic_lookup'
+ ' -o T27072d_check.dylib T27072d_check.c')],
+ compile_and_run,
+ ['T27072d_c.c -no-hs-main'
+ ' -optl -Wl,-needed_library,T27072d_check.dylib -optl -rpath -optl .'])
+# check that finalizers are being run, using --wrap to intercept hs_spt_remove.
+# Skipped on Darwin (Apple linker doesn't support --wrap).
+test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
+ compile_and_run, ['T27072w_c.c -no-hs-main -optl-Wl,--wrap=hs_spt_remove'])
=====================================
testsuite/tests/overloadedstrings/should_fail/T25926.hs
=====================================
@@ -0,0 +1,4 @@
+module T25926 where
+
+f () 0 = ()
+f 'a' _ = ()
=====================================
testsuite/tests/overloadedstrings/should_fail/T25926.stderr
=====================================
@@ -0,0 +1,5 @@
+T25926.hs:4:3: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘()’ with actual type ‘Char’
+ • In the pattern: 'a'
+ In an equation for ‘f’: f 'a' _ = ()
+
=====================================
testsuite/tests/overloadedstrings/should_fail/T27124.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module T27124 where
+
+foo :: [String] -> Bool
+foo "HI" = True
+foo _ = False
+
+main = pure ()
=====================================
testsuite/tests/overloadedstrings/should_fail/T27124.stderr
=====================================
@@ -0,0 +1,6 @@
+T27124.hs:6:5: warning: [GHC-18872] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘[Char]’ with ‘Char’
+ arising from the literal ‘"HI"’
+ • In the pattern: "HI"
+ In an equation for ‘foo’: foo "HI" = True
+
=====================================
testsuite/tests/overloadedstrings/should_fail/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T25926', normal, compile, ['-fdefer-type-errors'])
+test('T27124', normal, compile, ['-fdefer-type-errors'])
=====================================
testsuite/tests/overloadedstrings/should_run/T27124a.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module T27124a where
+
+import Data.String (IsString(..))
+
+newtype Wrap a = Wrap a deriving (Eq, Show)
+
+instance IsString a => IsString (Wrap a) where
+ fromString = Wrap . fromString
+
+instance {-# INCOHERENT #-} IsString (Wrap Bool) where
+ fromString _ = Wrap False
+
+f :: (Eq a, IsString a) => Wrap a -> Bool
+f "hello" = True
+f _ = False
+
+main :: IO ()
+main = do
+ print (f (Wrap ("hello" :: String)))
+ print (f (Wrap ("world" :: String)))
=====================================
testsuite/tests/overloadedstrings/should_run/all.T
=====================================
@@ -1 +1,2 @@
test('overloadedstringsrun01', normal, compile_and_run, [''])
+test('T27124a', normal, compile, ['-fno-specialise-incoherents'])
=====================================
testsuite/tests/rts/linker/T27072/Lib.c
=====================================
@@ -0,0 +1,18 @@
+// Minimal module with an initializer and finalizer.
+// The compiler places the function pointers in .init_array/.fini_array
+// (ELF) or __mod_init_func/__mod_term_func (Mach-O).
+//
+// The counter lives in the main binary so it survives after this
+// object is unloaded.
+
+extern int init_counter;
+
+__attribute__((constructor))
+static void lib_init(void) {
+ init_counter++;
+}
+
+__attribute__((destructor))
+static void lib_fini(void) {
+ init_counter--;
+}
=====================================
testsuite/tests/rts/linker/T27072/Makefile
=====================================
@@ -0,0 +1,21 @@
+.PHONY: clean_build_and_run build_and_run clean build
+
+clean_build_and_run:
+ $(MAKE) clean
+ $(MAKE) build_and_run
+
+build_and_run: build
+ ./main
+
+clean:
+ $(RM) Lib.o main.o main
+
+build: Lib.o main
+
+Lib.o: Lib.c
+ $(CC) -c -fPIC Lib.c -o Lib.o
+
+main: main.c
+ "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \
+ -no-hs-main -optc-Werror \
+ main.c -o main
=====================================
testsuite/tests/rts/linker/T27072/T27072.stdout
=====================================
@@ -0,0 +1,3 @@
+counter before load: 0
+counter after load: 1
+counter after unload: 0
=====================================
testsuite/tests/rts/linker/T27072/all.T
=====================================
@@ -0,0 +1,6 @@
+test('T27072',
+ [req_rts_linker,
+ js_skip,
+ extra_files(['Lib.c', 'main.c'])],
+ makefile_test,
+ ['clean_build_and_run'])
=====================================
testsuite/tests/rts/linker/T27072/main.c
=====================================
@@ -0,0 +1,57 @@
+// Test that the RTS linker executes .init_array entries on load and
+// .fini_array entries on unload. The loaded module increments a
+// counter in its initializer and decrements it in its finalizer.
+
+#include "Rts.h"
+#include <stdio.h>
+
+#if defined(mingw32_HOST_OS)
+#define PATH_STR(str) L##str
+#else
+#define PATH_STR(str) str
+#endif
+
+int init_counter = 0;
+
+int main(int argc, char *argv[]) {
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+
+ initLinker_(0);
+ insertSymbol(PATH_STR("main"), "init_counter", &init_counter);
+
+ printf("counter before load: %d\n", init_counter);
+ fflush(stdout);
+
+ int ok;
+ ok = loadObj(PATH_STR("Lib.o"));
+ if (!ok) {
+ errorBelch("loadObj(Lib.o) failed");
+ return 1;
+ }
+ ok = resolveObjs();
+ if (!ok) {
+ errorBelch("resolveObjs() failed");
+ return 1;
+ }
+
+ printf("counter after load: %d\n", init_counter);
+ fflush(stdout);
+
+ ok = unloadObj(PATH_STR("Lib.o"));
+ if (!ok) {
+ errorBelch("unloadObj(Lib.o) failed");
+ return 1;
+ }
+
+ // GC triggers actual unloading and finalizer execution.
+ performMajorGC();
+ performMajorGC();
+
+ printf("counter after unload: %d\n", init_counter);
+ fflush(stdout);
+
+ hs_exit();
+ return 0;
+}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52db07c24dff2bc047ece1ef13ca43…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52db07c24dff2bc047ece1ef13ca43…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] profiling: partial backport of 2dadf3b0 to fix #27121
by Magnus (@MangoIV) 21 May '26
by Magnus (@MangoIV) 21 May '26
21 May '26
Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC
Commits:
52db07c2 by mangoiv at 2026-05-21T12:21:26+02:00
profiling: partial backport of 2dadf3b0 to fix #27121
This backports fix and test for #27121 from 2dadf3b0 since the entirety
of the patch is not backportable without also backporting two larger
refactorings.
- - - - -
4 changed files:
- compiler/GHC/Core/Utils.hs
- + testsuite/tests/profiling/should_compile/T27121.hs
- + testsuite/tests/profiling/should_compile/T27121_aux.hs
- testsuite/tests/profiling/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -345,7 +345,7 @@ mkTick t orig_expr = mkTick' id orig_expr
-- unfoldings. We therefore make an effort to put everything into
-- the right place no matter what we start with.
Cast e co -> mkCast (mkTick' rest e) co
- Coercion co -> Tick t $ rest (Coercion co)
+ Coercion co -> Coercion co
Lam x e
-- Always float through type lambdas. Even for non-type lambdas,
=====================================
testsuite/tests/profiling/should_compile/T27121.hs
=====================================
@@ -0,0 +1,12 @@
+module T27121 where
+
+import T27121_aux
+
+updateFileDiagnostics
+ :: LanguageContextEnv ()
+ -> IO ()
+updateFileDiagnostics env = do
+ withTrace $ \ _tag ->
+ runLspT env $ do
+ sendNotification SMethod_TextDocumentPublishDiagnostics
+ PublishDiagnosticsParams
=====================================
testsuite/tests/profiling/should_compile/T27121_aux.hs
=====================================
@@ -0,0 +1,354 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T27121_aux
+ ( withTrace
+ , sendNotification
+ , LspT, runLspT
+ , SMethod(..)
+ , LanguageContextEnv
+ , PublishDiagnosticsParams(..)
+ )
+ where
+
+-- base
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Kind ( Type )
+import GHC.TypeLits ( Symbol )
+
+--------------------------------------------------------------------------------
+
+withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a
+withTrace act
+ | myUserTracingEnabled
+ = return undefined
+ | otherwise = act (\_ _ -> pure ())
+{-# NOINLINE withTrace #-}
+
+myUserTracingEnabled :: Bool
+myUserTracingEnabled = False
+{-# NOINLINE myUserTracingEnabled #-}
+
+type Text = String
+
+newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a}
+
+instance Functor (LspT config) where
+ fmap f (LspT g) = LspT (fmap f . g)
+
+instance Applicative (LspT config) where
+ pure = LspT . const . pure
+ LspT f <*> LspT a = LspT $ \ env -> f env <*> a env
+instance Monad (LspT config) where
+ LspT a >>= f = LspT $ \ env -> do
+ b <- a env
+ unLspT ( f b ) env
+instance MonadIO (LspT config) where
+ liftIO = LspT . const . liftIO
+
+type role LspT representational nominal
+
+runLspT :: LanguageContextEnv config -> LspT config a -> IO a
+runLspT env (LspT f) = f env
+{-# INLINE runLspT #-}
+
+data PublishDiagnosticsParams = PublishDiagnosticsParams
+
+data LanguageContextEnv config =
+ LanguageContextEnv
+ { resSendMessage :: FromServerMessage -> IO () }
+
+
+sendNotification ::
+ forall (m :: Method ServerToClient Notification) f config.
+ MonadLsp config f =>
+ SServerMethod m ->
+ MessageParams m ->
+ f ()
+sendNotification m params =
+ let msg = TNotificationMessage { _method = m, _params = params }
+ in case splitServerMethod m of
+ IsServerNot -> sendToClient $ fromServerNot msg
+
+type Method :: MessageDirection -> MessageKind -> Type
+data Method f t where
+ Method_TextDocumentImplementation :: Method ClientToServer Request
+ Method_TextDocumentTypeDefinition :: Method ClientToServer Request
+ Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request
+ Method_WorkspaceConfiguration :: Method ServerToClient Request
+ Method_TextDocumentDocumentColor :: Method ClientToServer Request
+ Method_TextDocumentColorPresentation :: Method ClientToServer Request
+ Method_TextDocumentFoldingRange :: Method ClientToServer Request
+ Method_TextDocumentDeclaration :: Method ClientToServer Request
+ Method_TextDocumentSelectionRange :: Method ClientToServer Request
+ Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request
+ Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request
+ Method_CallHierarchyIncomingCalls :: Method ClientToServer Request
+ Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request
+ Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request
+ Method_WindowShowDocument :: Method ServerToClient Request
+ Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request
+ Method_WorkspaceWillCreateFiles :: Method ClientToServer Request
+ Method_WorkspaceWillRenameFiles :: Method ClientToServer Request
+ Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request
+ Method_TextDocumentMoniker :: Method ClientToServer Request
+ Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request
+ Method_TypeHierarchySupertypes :: Method ClientToServer Request
+ Method_TypeHierarchySubtypes :: Method ClientToServer Request
+ Method_TextDocumentInlineValue :: Method ClientToServer Request
+ Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request
+ Method_TextDocumentInlayHint :: Method ClientToServer Request
+ Method_InlayHintResolve :: Method ClientToServer Request
+ Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request
+ Method_TextDocumentDiagnostic :: Method ClientToServer Request
+ Method_WorkspaceDiagnostic :: Method ClientToServer Request
+ Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request
+ Method_ClientRegisterCapability :: Method ServerToClient Request
+ Method_ClientUnregisterCapability :: Method ServerToClient Request
+ Method_Initialize :: Method ClientToServer Request
+ Method_Shutdown :: Method ClientToServer Request
+ Method_WindowShowMessageRequest :: Method ServerToClient Request
+ Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request
+ Method_TextDocumentCompletion :: Method ClientToServer Request
+ Method_CompletionItemResolve :: Method ClientToServer Request
+ Method_TextDocumentHover :: Method ClientToServer Request
+ Method_TextDocumentSignatureHelp :: Method ClientToServer Request
+ Method_TextDocumentDefinition :: Method ClientToServer Request
+ Method_TextDocumentReferences :: Method ClientToServer Request
+ Method_TextDocumentDocumentHighlight :: Method ClientToServer Request
+ Method_TextDocumentDocumentSymbol :: Method ClientToServer Request
+ Method_TextDocumentCodeAction :: Method ClientToServer Request
+ Method_CodeActionResolve :: Method ClientToServer Request
+ Method_WorkspaceSymbol :: Method ClientToServer Request
+ Method_WorkspaceSymbolResolve :: Method ClientToServer Request
+ Method_TextDocumentCodeLens :: Method ClientToServer Request
+ Method_CodeLensResolve :: Method ClientToServer Request
+ Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request
+ Method_TextDocumentDocumentLink :: Method ClientToServer Request
+ Method_DocumentLinkResolve :: Method ClientToServer Request
+ Method_TextDocumentFormatting :: Method ClientToServer Request
+ Method_TextDocumentRangeFormatting :: Method ClientToServer Request
+ Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request
+ Method_TextDocumentRename :: Method ClientToServer Request
+ Method_TextDocumentPrepareRename :: Method ClientToServer Request
+ Method_WorkspaceExecuteCommand :: Method ClientToServer Request
+ Method_WorkspaceApplyEdit :: Method ServerToClient Request
+ Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification
+ Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification
+ Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification
+ Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification
+ Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification
+ Method_NotebookDocumentDidOpen :: Method ClientToServer Notification
+ Method_NotebookDocumentDidChange :: Method ClientToServer Notification
+ Method_NotebookDocumentDidSave :: Method ClientToServer Notification
+ Method_NotebookDocumentDidClose :: Method ClientToServer Notification
+ Method_Initialized :: Method ClientToServer Notification
+ Method_Exit :: Method ClientToServer Notification
+ Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification
+ Method_WindowShowMessage :: Method ServerToClient Notification
+ Method_WindowLogMessage :: Method ServerToClient Notification
+ Method_TelemetryEvent :: Method ServerToClient Notification
+ Method_TextDocumentDidOpen :: Method ClientToServer Notification
+ Method_TextDocumentDidChange :: Method ClientToServer Notification
+ Method_TextDocumentDidClose :: Method ClientToServer Notification
+ Method_TextDocumentDidSave :: Method ClientToServer Notification
+ Method_TextDocumentWillSave :: Method ClientToServer Notification
+ Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification
+ Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification
+ Method_SetTrace :: Method ClientToServer Notification
+ Method_LogTrace :: Method ServerToClient Notification
+ Method_CancelRequest :: Method f Notification
+ Method_Progress :: Method f Notification
+ Method_CustomMethod :: Symbol -> Method f t
+
+type SMethod :: forall f t . Method f t -> Type
+data SMethod m where
+ SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation
+ SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition
+ SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders
+ SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration
+ SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor
+ SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation
+ SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange
+ SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration
+ SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange
+ SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate
+ SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy
+ SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls
+ SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls
+ SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull
+ SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta
+ SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange
+ SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh
+ SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument
+ SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange
+ SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles
+ SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles
+ SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles
+ SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker
+ SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy
+ SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes
+ SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes
+ SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue
+ SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh
+ SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint
+ SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve
+ SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh
+ SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic
+ SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic
+ SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh
+ SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability
+ SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability
+ SMethod_Initialize :: SMethod Method_Initialize
+ SMethod_Shutdown :: SMethod Method_Shutdown
+ SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest
+ SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil
+ SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion
+ SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve
+ SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover
+ SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp
+ SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition
+ SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences
+ SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight
+ SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol
+ SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction
+ SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve
+ SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol
+ SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve
+ SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens
+ SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve
+ SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh
+ SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink
+ SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve
+ SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting
+ SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting
+ SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting
+ SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename
+ SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename
+ SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand
+ SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit
+ SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders
+ SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel
+ SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles
+ SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles
+ SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles
+ SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen
+ SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange
+ SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave
+ SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose
+ SMethod_Initialized :: SMethod Method_Initialized
+ SMethod_Exit :: SMethod Method_Exit
+ SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration
+ SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage
+ SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage
+ SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent
+ SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen
+ SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange
+ SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose
+ SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave
+ SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave
+ SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles
+ SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics
+ SMethod_SetTrace :: SMethod Method_SetTrace
+ SMethod_LogTrace :: SMethod Method_LogTrace
+ SMethod_CancelRequest :: SMethod Method_CancelRequest
+ SMethod_Progress :: SMethod Method_Progress
+
+type SServerMethod (m :: Method ServerToClient t) = SMethod m
+
+data MessageDirection = ServerToClient | ClientToServer
+
+data MessageKind = Notification | Request
+
+
+type ServerNotOrReq :: forall t. Method ServerToClient t -> Type
+data ServerNotOrReq m where
+ IsServerNot ::
+ ( TMessage m ~ TNotificationMessage m
+ ) =>
+ ServerNotOrReq (m :: Method ServerToClient Notification)
+ IsServerReq ::
+ forall (m :: Method ServerToClient Request).
+ ( TMessage m ~ TRequestMessage m
+ ) =>
+ ServerNotOrReq m
+
+type TMessage :: forall f t. Method f t -> Type
+type family TMessage m where
+ TMessage (Method_CustomMethod s :: Method f t) = ()
+ TMessage (m :: Method f Request) = TRequestMessage m
+ TMessage (m :: Method f Notification) = TNotificationMessage m
+
+
+data TNotificationMessage (m :: Method f Notification) = TNotificationMessage
+ { _method :: SMethod m
+ , _params :: MessageParams m
+ }
+
+data TRequestMessage (m :: Method f Request) = TRequestMessage
+
+type MessageParams :: forall f t . Method f t -> Type
+type family MessageParams (m :: Method f t) where
+ MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams
+
+class MonadIO m => MonadLsp config m | m -> config where
+ getLspEnv :: m (LanguageContextEnv config)
+
+instance MonadLsp config (LspT config) where
+ {-# INLINE getLspEnv #-}
+ getLspEnv = LspT pure
+
+
+{-# INLINE splitServerMethod #-}
+splitServerMethod :: SServerMethod m -> ServerNotOrReq m
+splitServerMethod = \case
+ SMethod_TextDocumentPublishDiagnostics -> IsServerNot
+ SMethod_WindowShowMessage -> IsServerNot
+ SMethod_WindowShowMessageRequest -> IsServerReq
+ SMethod_WindowShowDocument -> IsServerReq
+ SMethod_WindowLogMessage -> IsServerNot
+ SMethod_WindowWorkDoneProgressCreate -> IsServerReq
+ SMethod_Progress -> IsServerNot
+ SMethod_TelemetryEvent -> IsServerNot
+ SMethod_ClientRegisterCapability -> IsServerReq
+ SMethod_ClientUnregisterCapability -> IsServerReq
+ SMethod_WorkspaceWorkspaceFolders -> IsServerReq
+ SMethod_WorkspaceConfiguration -> IsServerReq
+ SMethod_WorkspaceApplyEdit -> IsServerReq
+ SMethod_LogTrace -> IsServerNot
+ SMethod_CancelRequest -> IsServerNot
+ SMethod_WorkspaceCodeLensRefresh -> IsServerReq
+ SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq
+ SMethod_WorkspaceInlineValueRefresh -> IsServerReq
+ SMethod_WorkspaceInlayHintRefresh -> IsServerReq
+ SMethod_WorkspaceDiagnosticRefresh -> IsServerReq
+
+fromServerNot ::
+ forall (m :: Method ServerToClient Notification).
+ TMessage m ~ TNotificationMessage m =>
+ TNotificationMessage m ->
+ FromServerMessage
+fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m
+
+
+data FromServerMessage' a where
+ FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a
+ FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a
+
+type FromServerMessage = FromServerMessage' SMethod
+
+data TResponseMessage (m :: Method f Request) = TResponseMessage
+
+sendToClient :: MonadLsp config m => FromServerMessage -> m ()
+sendToClient msg = do
+ f <- resSendMessage <$> getLspEnv
+ liftIO $ f msg
+{-# INLINE sendToClient #-}
=====================================
testsuite/tests/profiling/should_compile/all.T
=====================================
@@ -20,3 +20,4 @@ test('T14931', [test_opts, unless(have_dynamic(), skip)],
test('T15108', [test_opts], compile, ['-O -prof -fprof-auto'])
test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894'])
test('T20938', [test_opts], compile, ['-O -prof'])
+test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-v0 -O -prof -fprof-auto'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52db07c24dff2bc047ece1ef13ca436…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52db07c24dff2bc047ece1ef13ca436…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Use "grimily" instead of "grimly"
by Marge Bot (@marge-bot) 21 May '26
by Marge Bot (@marge-bot) 21 May '26
21 May '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7f1247a7 by Markus Läll at 2026-05-21T06:21:32-04:00
Use "grimily" instead of "grimly"
Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221
- - - - -
5f61143a by sheaf at 2026-05-21T06:21:40-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.
- - - - -
13 changed files:
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/Supply.hs
- + testsuite/tests/ghc-api/T27273.hs
- testsuite/tests/ghc-api/all.T
Changes:
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -318,7 +318,7 @@ instance DSM.MonadGetUnique LlvmM where
tag <- getEnv envTag
liftUDSMT $! do
uq <- DSM.getUniqueM
- return (newTagUniqueGrimly uq tag)
+ return (newTagUniqueGrimily uq tag)
-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
liftIO :: IO a -> LlvmM a
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -175,11 +175,11 @@ instance MonadPlus CoreM
instance MonadUnique CoreM where
getUniqueSupplyM = do
tag <- read cr_uniq_tag
- liftIO $! mkSplitUniqSupplyGrimly tag
+ liftIO $! mkSplitUniqSupplyGrimily tag
getUniqueM = do
tag <- read cr_uniq_tag
- liftIO $! uniqFromTagGrimly tag
+ liftIO $! uniqFromTagGrimily tag
runCoreM :: HscEnv
-> RuleBase
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -144,7 +144,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
| otherwise = unpackHObj res_hty
header_bits = maybe mempty idTag maybe_target
- idTag i = let (tag, u) = unpkUniqueGrimly (getUnique i)
+ idTag i = let (tag, u) = unpkUniqueGrimily (getUnique i)
in CHeader (char tag <> word64 u)
normal_args = map (\(nm,_ty,_,_) -> nm) arg_info
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -707,7 +707,7 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isKnownKeyName name
- , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
+ , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
= -- assert (u < 2^(22 :: Int))
put_ bh (0x80000000
.|. (fromIntegral (ord c) `shiftL` 22)
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -66,9 +66,9 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { tag <- ask
- ; liftIO $! mkSplitUniqSupplyGrimly tag}
+ ; liftIO $! mkSplitUniqSupplyGrimily tag}
getUniqueM = StgM $ do { tag <- ask
- ; liftIO $! uniqFromTagGrimly tag}
+ ; liftIO $! uniqFromTagGrimily tag}
runStgM :: UniqueTag -> StgM a -> IO a
runStgM mask (StgM m) = runReaderT m (uniqueTag mask)
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -130,7 +130,7 @@ makeIdentForId i num id_type current_module = name ident
-- unique suffix for non-exported Ids
, if exported
then mempty
- else let (c,u) = unpkUniqueGrimly (getUnique i)
+ else let (c,u) = unpkUniqueGrimily (getUnique i)
in mconcat [BSC.pack ['_',c,'_'], word64BS u]
]
@@ -235,4 +235,3 @@ declVarsForId i = case typeSize (idType i) of
0 -> return mempty
1 -> decl <$> identForId i
s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s]
-
=====================================
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
{-
************************************************************************
@@ -1008,13 +997,13 @@ newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv
; let tag = env_ut env
- ; liftIO $! uniqFromTagGrimly tag }
+ ; liftIO $! uniqFromTagGrimily tag }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv
; let tag = env_ut env
- ; liftIO $! mkSplitUniqSupplyGrimly tag }
+ ; liftIO $! mkSplitUniqSupplyGrimily tag }
cloneLocalName :: Name -> TcM Name
-- Make a fresh Internal name with the same OccName and SrcSpan
=====================================
compiler/GHC/Types/Name/Cache.hs
=====================================
@@ -122,7 +122,7 @@ data NameCache = NameCache
type OrigNameCache = ModuleEnv (OccEnv Name)
takeUniqFromNameCache :: NameCache -> IO Unique
-takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimly c
+takeUniqFromNameCache (NameCache c _) = uniqFromTagGrimily c
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -38,12 +38,12 @@ module GHC.Types.Unique (
mkUniqueIntGrimily,
getKey,
mkUnique, unpkUnique,
- unpkUniqueGrimly,
+ unpkUniqueGrimily,
mkUniqueInt,
eqUnique, ltUnique,
incrUnique, stepUnique,
- newTagUnique, newTagUniqueGrimly,
+ newTagUnique, newTagUniqueGrimily,
nonDetCmpUnique,
isValidKnownKeyUnique,
@@ -99,7 +99,7 @@ Note [Performance implications of UniqueTag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The UniqueTag ADT is meant to be ephemeral and eliminated by the simplifier,
so for long term storage (i.e. in monadic environments or data structures) we
-want to store the raw 'Char's. Working with the raw tags is done via the *Grimly
+want to store the raw 'Char's. Working with the raw tags is done via the *Grimily
class of functions
For instance, if we are generating a unique for a concrete tag, we should use
@@ -116,7 +116,7 @@ newUnique
; liftIO $! uniqFromTag tag }
Prefer `env_ut :: Char` and
- ; liftIO $! uniqFromTagGrimly tag }
+ ; liftIO $! uniqFromTagGrimily tag }
-}
@@ -295,7 +295,7 @@ The stuff about unique *supplies* is handled further down this module.
-}
unpkUnique :: Unique -> (UniqueTag, Word64) -- The reverse
-unpkUniqueGrimly :: Unique -> (Char, Word64) -- The reverse
+unpkUniqueGrimily :: Unique -> (Char, Word64) -- The reverse
mkUniqueGrimily :: Word64 -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Word64 -- for Var
@@ -303,7 +303,7 @@ getKey :: Unique -> Word64 -- for Var
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Word64 -> Unique
newTagUnique :: Unique -> UniqueTag -> Unique
-newTagUniqueGrimly :: Unique -> Char -> Unique
+newTagUniqueGrimily :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
@@ -323,9 +323,9 @@ maxLocalUnique :: Unique
maxLocalUnique = mkLocalUnique uniqueMask
-- newTagUnique changes the "domain" of a unique to a different char
-newTagUnique u c = newTagUniqueGrimly u (uniqueTag c)
+newTagUnique u c = newTagUniqueGrimily u (uniqueTag c)
-newTagUniqueGrimly u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimly u
+newTagUniqueGrimily u c = mkUniqueGrimilyWithTag c i where (_,i) = unpkUniqueGrimily u
-- | Bitmask that has zeros for the tag bits and ones for the rest.
uniqueMask :: Word64
@@ -368,7 +368,7 @@ mkUniqueIntGrimily = MkUnique . intToWord64
{-# INLINE mkUniqueIntGrimily #-}
-unpkUniqueGrimly (MkUnique u)
+unpkUniqueGrimily (MkUnique u)
= let
-- The potentially truncating use of fromIntegral here is safe
-- because the argument is just the tag bits after shifting.
@@ -376,10 +376,10 @@ unpkUniqueGrimly (MkUnique u)
i = u .&. uniqueMask
in
(tag, i)
-{-# INLINE unpkUniqueGrimly #-}
+{-# INLINE unpkUniqueGrimily #-}
-unpkUnique u = case unpkUniqueGrimly u of
+unpkUnique u = case unpkUniqueGrimily u of
(c, i) -> ( charToUniqueTag c, i)
{-# INLINE unpkUnique #-}
@@ -389,7 +389,7 @@ unpkUnique u = case unpkUniqueGrimly u of
-- See Note [Symbol table representation of names] in "GHC.Iface.Binary" for details.
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
- case unpkUniqueGrimly u of
+ case unpkUniqueGrimily u of
(c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
{-
@@ -512,7 +512,7 @@ showUnique :: Unique -> String
showUnique uniq
= tagStr ++ w64ToBase62 u
where
- (tag, u) = unpkUniqueGrimly uniq
+ (tag, u) = unpkUniqueGrimily uniq
-- Avoid emitting non-printable characters in pretty uniques.
-- See #25989.
tagStr
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -16,10 +16,10 @@ module GHC.Types.Unique.Supply (
-- ** Operations on supplies
uniqFromSupply, uniqsFromSupply, -- basic ops
takeUniqFromSupply,
- uniqFromTag, uniqFromTagGrimly,
+ uniqFromTag, uniqFromTagGrimily,
UniqueTag(..),
- mkSplitUniqSupply, mkSplitUniqSupplyGrimly,
+ mkSplitUniqSupply, mkSplitUniqSupplyGrimily,
splitUniqSupply, listSplitUniqSupply,
-- * Unique supply monad and its abstraction
@@ -203,10 +203,10 @@ data UniqSupply
-- when split => these two supplies
mkSplitUniqSupply :: UniqueTag -> IO UniqSupply
-mkSplitUniqSupply ut = mkSplitUniqSupplyGrimly (uniqueTag ut)
+mkSplitUniqSupply ut = mkSplitUniqSupplyGrimily (uniqueTag ut)
{-# INLINE mkSplitUniqSupply #-}
-mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
+mkSplitUniqSupplyGrimily :: Char -> IO UniqSupply
-- ^ Create a unique supply out of thin air.
-- The "tag" (Char) supplied is mostly cosmetic, making it easier
-- to figure out where a Unique was born. See Note [Uniques and tags].
@@ -219,7 +219,7 @@ mkSplitUniqSupplyGrimly :: Char -> IO UniqSupply
-- See Note [How the unique supply works]
-- See Note [Optimising the unique supply]
-mkSplitUniqSupplyGrimly ut
+mkSplitUniqSupplyGrimily ut
= unsafeDupableInterleaveIO (IO mk_supply)
where
@@ -286,15 +286,15 @@ initUniqSupply counter inc = do
poke ghc_unique_inc inc
uniqFromTag :: UniqueTag -> IO Unique
-uniqFromTag !ut = uniqFromTagGrimly (uniqueTag ut)
+uniqFromTag !ut = uniqFromTagGrimily (uniqueTag ut)
{-# INLINE uniqFromTag #-}
-uniqFromTagGrimly :: Char -> IO Unique
-uniqFromTagGrimly !tag
+uniqFromTagGrimily :: Char -> IO Unique
+uniqFromTagGrimily !tag
= do { uqNum <- genSym
; return $! mkUniqueGrimilyWithTag tag uqNum }
-{-# NOINLINE uniqFromTagGrimly #-} -- We'll unbox everything, but we don't want to inline it
+{-# NOINLINE uniqFromTagGrimily #-} -- We'll unbox everything, but we don't want to inline it
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
-- ^ Build two 'UniqSupply' from a single one, each of which
=====================================
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/-/compare/aad2e50ffaab1e1831babcc7de1da0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aad2e50ffaab1e1831babcc7de1da0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghc-pkg-faster-closure] Speed up 'closure' computation in `ghc-pkg`
by Hannes Siebenhandl (@fendor) 21 May '26
by Hannes Siebenhandl (@fendor) 21 May '26
21 May '26
Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-faster-closure at Glasgow Haskell Compiler / GHC
Commits:
d320afe7 by fendor at 2026-05-21T10:26:33+02: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/d320afe76db0791b1b04b73d0a03462…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d320afe76db0791b1b04b73d0a03462…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghc-pkg-faster-closure] Simplify 'closure' implementation and rename to 'brokenPackages'
by Hannes Siebenhandl (@fendor) 21 May '26
by Hannes Siebenhandl (@fendor) 21 May '26
21 May '26
Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-faster-closure at Glasgow Haskell Compiler / GHC
Commits:
9ac39e74 by fendor at 2026-05-21T09:49:37+02:00
Simplify 'closure' implementation and rename to 'brokenPackages'
- - - - -
1 changed file:
- utils/ghc-pkg/Main.hs
Changes:
=====================================
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,34 +1845,30 @@ 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, pkg_ids) db_stack
+-- | 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
- pkg_ids = Set.fromList $ map installedUnitId pkgs
- go (avail, avail_ids) not_avail =
+ go avail_ids not_avail =
case partition (depsAvailable avail_ids) not_avail of
([], not_avail') ->
- (avail, not_avail')
+ not_avail'
(new_avail, not_avail') ->
let
all_pkg_ids =
foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
in
- go (new_avail ++ avail, all_pkg_ids) not_avail'
-
+ go all_pkg_ids not_avail'
- depsAvailable :: Set.Set UnitId -> InstalledPackageInfo
- -> Bool
- depsAvailable pids pkg = null dangling
- where dangling = filter (`Set.notMember` pids) (depends pkg)
+ depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool
+ depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)
-- we want mutually recursive groups of package to show up
-- as broken. (#1750)
-brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
-brokenPackages pkgs = snd (closure [] pkgs)
-
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ac39e747ffc6a8361135e1334caf97…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ac39e747ffc6a8361135e1334caf97…
You're receiving this email because of your account on gitlab.haskell.org.
1
0