[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
[Git][ghc/ghc][wip/andreask/9.10.4-batch1] release: copy index.html from correct directory
by Andreas Klebinger (@AndreasK) 21 May '26
by Andreas Klebinger (@AndreasK) 21 May '26
21 May '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
1ce94e69 by Zubin Duggal at 2026-05-21T09:44:11+02:00
release: copy index.html from correct directory
(cherry picked from commit cbfd0829cd61928976c9eb17ba4af18272466063)
- - - - -
1 changed file:
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
Changes:
=====================================
.gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
=====================================
@@ -129,7 +129,7 @@ def fetch_artifacts(release: str, pipeline_id: int,
for f in doc_files:
subprocess.run(['tar', '-xf', f, '-C', dest])
logging.info(f'extracted docs {f} to {dest}')
- index_path = destdir / 'index.html'
+ index_path = destdir / 'docs' / 'index.html'
index_path.replace(dest / 'index.html')
pdfs = list(destdir.glob('*.pdf'))
for f in pdfs:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ce94e69f4f386c3e558f81874844ea…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ce94e69f4f386c3e558f81874844ea…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/9.10.4-batch1] Fix toException method for ExceptionWithContext
by Andreas Klebinger (@AndreasK) 21 May '26
by Andreas Klebinger (@AndreasK) 21 May '26
21 May '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
ffcaf0ff by Matthew Pickering at 2026-05-21T09:41:54+02:00
Fix toException method for ExceptionWithContext
Fixes #25235
(cherry picked from commit 9bfd9fd0730359b4e88e97b08d3654d966a9a11d)
- - - - -
1 changed file:
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
=====================================
@@ -224,8 +224,10 @@ instance Show a => Show (ExceptionWithContext a) where
instance Exception a => Exception (ExceptionWithContext a) where
toException (ExceptionWithContext ctxt e) =
- SomeException e
- where ?exceptionContext = ctxt
+ case toException e of
+ SomeException c ->
+ let ?exceptionContext = ctxt
+ in SomeException c
fromException se = do
e <- fromException se
return (ExceptionWithContext (someExceptionContext se) e)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ffcaf0ffd4226ddd68597fe1334fb9a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ffcaf0ffd4226ddd68597fe1334fb9a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][ghc-9.10] 5 commits: configure: Allow happy-2.0.2
by Andreas Klebinger (@AndreasK) 21 May '26
by Andreas Klebinger (@AndreasK) 21 May '26
21 May '26
Andreas Klebinger pushed to branch ghc-9.10 at Glasgow Haskell Compiler / GHC
Commits:
5cfea804 by Matthew Pickering at 2026-05-19T14:29:08+02:00
configure: Allow happy-2.0.2
happy-2.0.2 can be used to compile GHC.
happy-2.0 and 2.0.1 have bugs which make it unsuitable to use.
The version bound is now == 1.20.* || >= 2.0.2 && < 2.1
Fixes #25276
(cherry picked from commit 0029ca91c845dd4530eb2c4606ad5bd59775cec2)
- - - - -
25ba2eb8 by Ben Gamari at 2026-05-19T14:32:25+02:00
configure: Accept happy-2.1.2
happy-2.1 was released in late Oct 2024. I have confirmed that master
bootstraps with it. Here we teach configure to accept this tool.
Fixes #25438.
(cherry picked from commit 1fd83f865ffb620f4f7c4c59787710206dcadb90)
- - - - -
082efeed by Hai / @BestYeen at 2026-05-19T14:32:32+02:00
Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again.
(cherry picked from commit d59ef6b66e36e6b3ef7783c7ea8971ee05818932)
- - - - -
a4cf3122 by Brian J. Cardiff at 2026-05-19T14:32:42+02:00
configure: Accept happy-2.2
In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build
(cherry picked from commit 4f2840f2bb729ef1a6660f9f5c46906b7b838147)
- - - - -
9c726e17 by Andreas Klebinger at 2026-05-20T08:59:54+02:00
Update ci-images commit
- - - - -
3 changed files:
- .gitlab-ci.yml
- m4/fptools_alex.m4
- m4/fptools_happy.m4
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: a9297a370025101b479cfd4977f8f910814e03ab
+ DOCKER_REV: c33314758e1186208b9f7e926e05469a8cfc0e05
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
=====================================
m4/fptools_alex.m4
=====================================
@@ -23,10 +23,16 @@ changequote([, ])dnl
])
if test ! -f compiler/GHC/Parser/Lexer.hs || test ! -f compiler/GHC/Cmm/Lexer.hs
then
+ if test x"$fptools_cv_alex_version" != x; then
+ fptools_cv_alex_version_display="version $fptools_cv_alex_version";
+ else
+ fptools_cv_alex_version_display="none";
+ fi;
+ failure_msg="Alex version >= 3.2.6 && < 4 is required to compile GHC. (Found: $fptools_cv_alex_version_display)"
FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[3.2.6],
- [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[]
+ [AC_MSG_ERROR([$failure_msg])])[]
FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-ge],[4.0.0],
- [AC_MSG_ERROR([Alex >= 3.2.6 && < 4 is required to compile GHC.])])[]
+ [AC_MSG_ERROR([$failure_msg])])[]
fi
AlexVersion=$fptools_cv_alex_version;
AC_SUBST(AlexVersion)
=====================================
m4/fptools_happy.m4
=====================================
@@ -13,8 +13,7 @@ AC_DEFUN([FPTOOLS_HAPPY],
AC_SUBST(HappyCmd,$HAPPY)
AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version,
changequote(, )dnl
-[
-if test x"$HappyCmd" != x; then
+[if test x"$HappyCmd" != x; then
fptools_cv_happy_version=`"$HappyCmd" -v |
grep 'Happy Version' | sed -e 's/Happy Version \([^ ]*\).*/\1/g'` ;
else
@@ -24,10 +23,19 @@ changequote([, ])dnl
])
if test ! -f compiler/GHC/Parser.hs || test ! -f compiler/GHC/Cmm/Parser.hs
then
+ if test x"$fptools_cv_happy_version" != x; then
+ fptools_cv_happy_version_display="version $fptools_cv_happy_version";
+ else
+ fptools_cv_happy_version_display="none";
+ fi;
+ failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.3 is required to compile GHC. (Found: $fptools_cv_happy_version_display)"
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.20.0],
- [AC_MSG_ERROR([Happy version 1.20 or later is required to compile GHC.])])[]
+ [AC_MSG_ERROR([$failure_msg])])[]
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[1.21.0],
- [AC_MSG_ERROR([Happy version 1.20 or earlier is required to compile GHC.])])[]
+ FP_COMPARE_VERSIONS([$fptools_cv_happy_version], [-le], [2.0.1],
+ [AC_MSG_ERROR([$failure_msg])])[])[]
+ FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[2.3.0],
+ [AC_MSG_ERROR([$failure_msg])])[]
fi
HappyVersion=$fptools_cv_happy_version;
AC_SUBST(HappyVersion)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e37757cfa18c80143e32cbedf15a50…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e37757cfa18c80143e32cbedf15a50…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/int-index/error-codes
by Vladislav Zavialov (@int-index) 21 May '26
by Vladislav Zavialov (@int-index) 21 May '26
21 May '26
Vladislav Zavialov pushed new branch wip/int-index/error-codes at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/error-codes
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Do not use mkCast during typechecking
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:
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"
- - - - -
5eeb40d5 by Markus Läll at 2026-05-21T01:39:47-04:00
Use "grimily" instead of "grimly"
Fixes https://gitlab.haskell.org/ghc/ghc/-/issues/27221
- - - - -
aad2e50f by sheaf at 2026-05-21T01:39:55-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.
- - - - -
71 changed files:
- compiler/GHC/CmmToLlvm/Base.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/Monad.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/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/Supply.hs
- docs/users_guide/exts/stolen_syntax.rst
- docs/users_guide/exts/template_haskell.rst
- testsuite/tests/codeGen/should_compile/T25177.stderr
- testsuite/tests/deSugar/should_compile/T13208.stdout
- + testsuite/tests/ghc-api/T27273.hs
- testsuite/tests/ghc-api/all.T
- 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/perf/compiler/T26989.hs
- + testsuite/tests/perf/compiler/T26989a.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/printer/T18052a.stderr
- 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/typecheck/should_compile/T13032.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3df97ad6887a59598f29967581fcc5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3df97ad6887a59598f29967581fcc5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0