July 2026 - ghc-commits

[Git][ghc/ghc][wip/fendor/no-code-output-constr] 13 commits: Adjust releaseCapability_ precondition to allow cap->running_task == NULL
by Hannes Siebenhandl (＠fendor) 06 Jul '26

06 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/no-code-output-constr at Glasgow Haskell Compiler / GHC Commits: 6e381626 by Duncan Coutts at 2026-07-01T22:29:55+01:00 Adjust releaseCapability_ precondition to allow cap->running_task == NULL There are two use cases for releaseCapability_: 1. The current Task (cap->running_task) releases the Capability. The Capability is marked free, and if there is any work to do, an appropriate Task is woken up. 2. There is no current task (cap->task == NULL), and thus the Capability is idle, and we want to wake up an idle Task to animate the Capability. This case uses always_wakeup. Currently, the precondition for releaseCapability_ is cap->running_task != NULL and so the 2nd use cases have to set cap->running_task (which is then immediately overwritten) just to satisfy the precondition. See the use cases in sendMessage and prodCapability. So we can relax the precondition to be: cap->running_task != NULL || always_wakeup so that in the always_wakeup case, we say it is ok for the cap->running_task to be NULL. This lets us simplify sendMessage and prodCapability. In particular it will allow prodCapability to not need a Task parameter. The ulterior motive for all this is that I want to be able to call prodCapability from an OS thread that is not itself a Task, in persuit of issue #27086: disentangle I/O managers from wakeUpRts. The most straightforward way to wake the RTS is using prodCapability, but the context in which we will need to do that are threads that are not Tasks. - - - - - 89404ebc by Duncan Coutts at 2026-07-01T22:29:55+01:00 prodCapability no longer needs to take a Task param Now that releaseCapability_ can accept cap->running_task == NULL then it is no longer necessary for prodCapability to require a Task. - - - - - 4e60c5f6 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Define prodOneCapability There was an existing declaration for this in the header file, but no definition. Similarly, there is a declaration for prodAllCapabilities but no definition, and we don't need it, so remove the declaration. - - - - - 2527026f by Duncan Coutts at 2026-07-01T22:29:56+01:00 Add a wakeUpRtsViaTicker feature to the posix ticker It proxies a call to wakeUpRts, but crucially, this can be called from a signal handler context. It will be used for ctl-c handling. - - - - - aa5a03a5 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Change how wakeUpRts works Previously it would call wakeupIOManager to get a capability to wake up and run. This works but it entangles the I/O managers with unrelated features: ctl-c handling and idle gc (the two features that use wakeUpRts). The reason it used wakeupIOManager is that this action is safe to use from a posix signal handler, since it just posts bytes to a pipe. Otherwise the more direct approach (used e.g. by sendMessage when the target capability is idle) is to use releaseCapability. But that uses condition variables and mutexes, which are not safe to use from within a signal handler. So instead of entangling the (multiple) I/O managers with this, we make wakeUpRts use the direct approach (using prodOneCapability). On win32 the ctl-c console handler can call wakeUpRts directly, since it is called in a proper thread. On posix, to deal with the signal handler problem, we make the signal handler ask the ticker thread to proxy the call to wakeUpRts, since the ticker thread is also a proper thread. This will allow the I/O managers to no longer be concerned with this. This is good because there are many I/O managers (and they're complicated), but there is (on posix) only one ticker implementation. So this is an overall reduction in coupling and complexity. Fixes issue #27086 - - - - - c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00 Test driver: normalise line numbers into libraries When comparing the stdout of tests that print out callstacks, we can't rely on the stability of exact line:column spans pointing into libraries (e.g. ghc-internal), as any change (such as adding a comment) can change them. This commit addresses this by normalising away line:column in callstacks, but only when those point into internal libraries. We don't do this in general, as the exact span might be important to the test (e.g. for a span within the test module itself). Fixes #27387 - - - - - 81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00 EPA: Remove LocatedLW from MatchGroup This is the last usage of LocatedLW / SrcSpanAnnLW - - - - - 925959db by Recursion Ninja at 2026-07-04T04:14:12-04:00 Decoupling 'L.H.S' from 'GHC.Hs.Doc' * Migrated 'GHC.Hs.Doc' and 'GHC.Hs.DocString' AST defintions from 'GHC.*' namespace, to new 'Language.Haskell.Syntax.Doc' module in the 'L.H.S' "namespace." * Updated 'HsDocString to be TTG-parameterised as 'HsDocString pass'. * Added 'GHC.Hs.Extension.Pass': splits 'GhcPass'/'Pass' and all 'HsDocString' TTG instances out of 'GHC.Hs.Extension', which re-exports it unchanged (this is backwards compatible and prevents the introduction of a boot file). * Deleted 'GHC.Hs.Doc.hs-boot'; removed all 'L.H.S.*' imports of 'GHC.Hs.Doc'. * Updated 'GHC.Hs.DocString' to be TTG pass-parameterised throughout; moved 'mkHsDocStringChunk'/'unpackHDSC' here (require 'GHC.Utils.Encoding'). * Split 'GHC.Rename.Doc.rnHsDoc' from 'rnHsDocIdentifiersOnly'. * Updated parser, renamer, typechecker, HIE, and exact-print for new types. * Added 'HsDocString' TTG instances for 'DocNameI' to 'Haddock.Types'. * Killed the last module loop between GHC.* and LHS.*. - Only edges from LHS.* to GHC.Data.FastString now! Resolves #26971 - - - - - b7e24044 by mangoiv at 2026-07-04T04:14:56-04:00 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable - - - - - 4180af3f by Zubin Duggal at 2026-07-04T04:15:38-04:00 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin - - - - - 242d4317 by sheaf at 2026-07-04T04:16:19-04:00 Remove outdated comment in GHC.Data.ShortText There was a long comment in GHC.Data.ShortText about a workaround that was necessary when bootstrapping with GHC 9.2 and below. The actual logic has since been dropped, but the comment remained. This commit removes the vestigial comment. - - - - - a295b42e by fendor at 2026-07-06T11:09:03+02:00 Add 'backendInfoTableMapValidity' backend predicate Check whether the backend supports the `-finfo-table-map` flag and ignore it otherwise. Improve by-design documentation of `backendCodeOutput`. `Backend` is **abstract by design**. Make this clearer in `backendCodeOutput` which is incorrectly being used as a proxy for `Backend`. Instead, define the desired property predicates in GHC.Driver.Backend In the process, make `backendCodeOutput` total. - - - - - 3fda3ecb by fendor at 2026-07-06T11:09:03+02:00 Add failing test for `-finfo-table-map` and bytecode backend If you compile a module using the bytecode backend, with -finfo-table-map, then the info table map doesn't get populated for the module. This is because the -finfo-table-map code path is implemented mostly in the StgToCmm phase which isn't run when creating bytecode. Ticket #27039 - - - - - 98 changed files: - .gitlab/test-metrics.sh - changelog.d/semaphore-v2 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - + compiler/GHC/Hs/Extension/Pass.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Doc.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Expr.hs-boot - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Type.hs - − compiler/Language/Haskell/Syntax/Type.hs-boot - compiler/ghc.cabal.in - hadrian/src/Settings/Warnings.hs - libraries/ghc-boot/GHC/Data/ShortText.hs - libraries/semaphore-compat - rts/Capability.c - rts/Capability.h - rts/Messages.c - rts/Schedule.c - rts/Ticker.h - rts/posix/Ticker.c - rts/sm/GC.c - testsuite/driver/testlib.py - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_fail/all.T - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/bytecodeIPE.hs - + testsuite/tests/ghci/scripts/bytecodeIPE.script - + testsuite/tests/ghci/scripts/bytecodeIPE.stdout - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/091472ba72ea86372e8f19486fd56e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/091472ba72ea86372e8f19486fd56e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/terrorjack/asan] 8 commits: rts: add ASAN instrumentation to mblock allocator
by Cheng Shao (＠TerrorJack) 06 Jul '26

06 Jul '26

Cheng Shao pushed to branch wip/terrorjack/asan at Glasgow Haskell Compiler / GHC Commits: d80037c2 by Cheng Shao at 2026-07-06T08:10:12+00:00 rts: add ASAN instrumentation to mblock allocator - - - - - b7450c9d by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to mgroup allocator - - - - - 6cf654e3 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to block allocator - - - - - 709b95b5 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to cap->pinned_object_empty - - - - - 5ca629c5 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to gc_thread->free_blocks - - - - - 2ad71829 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to hash table free list - - - - - 73ce0ca8 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to per-Task InCall free list - - - - - a79ae1c7 by Cheng Shao at 2026-07-06T08:10:17+00:00 rts: add ASAN instrumentation to nonmoving allocator - - - - - 12 changed files: - rts/Hash.c - rts/Task.c - rts/include/Stg.h - + rts/include/rts/ASANUtils.h - rts/rts.cabal - rts/sm/BlockAlloc.c - rts/sm/GCUtils.c - rts/sm/MBlock.c - rts/sm/NonMoving.c - rts/sm/NonMovingAllocate.c - rts/sm/NonMovingSweep.c - rts/sm/Storage.c Changes: ===================================== rts/Hash.c ===================================== @@ -283,6 +283,7 @@ allocHashList (HashTable *table) if (table->freeList != NULL) { HashList *hl = table->freeList; table->freeList = hl->next; + __asan_unpoison_memory_region(hl, offsetof(HashList, next)); return hl; } else { /* We allocate one block of memory which contains: @@ -302,8 +303,11 @@ allocHashList (HashTable *table) table->freeList = hl + 1; HashList *p = table->freeList; - for (; p < hl + HCHUNK - 1; p++) + for (; p < hl + HCHUNK - 1; p++) { + __asan_poison_memory_region(p, offsetof(HashList, next)); p->next = p + 1; + } + __asan_poison_memory_region(p, offsetof(HashList, next)); p->next = NULL; return hl; } @@ -318,6 +322,7 @@ freeHashList (HashTable *table, HashList *hl) // HashListChunks. hl->next = table->freeList; table->freeList = hl; + __asan_poison_memory_region(hl, offsetof(HashList, next)); } STATIC_INLINE void @@ -388,9 +393,10 @@ removeHashTable_inlined(HashTable *table, StgWord key, const void *data, table->dir[segment][index] = hl->next; else prev->next = hl->next; + void *hl_data = (void*)hl->data; freeHashList(table,hl); table->kcount--; - return (void *) hl->data; + return hl_data; } prev = hl; } ===================================== rts/Task.c ===================================== @@ -183,6 +183,7 @@ freeTask (Task *task) stgFree(incall); } for (incall = task->spare_incalls; incall != NULL; incall = next) { + __asan_unpoison_memory_region(incall, sizeof(InCall)); next = incall->next; stgFree(incall); } @@ -252,6 +253,7 @@ newInCall (Task *task) if (task->spare_incalls != NULL) { incall = task->spare_incalls; + __asan_unpoison_memory_region(incall, sizeof(InCall)); task->spare_incalls = incall->next; task->n_spare_incalls--; } else { @@ -283,6 +285,7 @@ endInCall (Task *task) stgFree(incall); } else { incall->next = task->spare_incalls; + __asan_poison_memory_region(incall, sizeof(InCall)); task->spare_incalls = incall; task->n_spare_incalls++; } ===================================== rts/include/Stg.h ===================================== @@ -331,6 +331,7 @@ external prototype return neither of these types to workaround #11395. #include "stg/MachRegsForHost.h" #include "stg/Regs.h" #include "stg/Ticky.h" +#include "rts/ASANUtils.h" #include "rts/TSANUtils.h" #if IN_STG_CODE ===================================== rts/include/rts/ASANUtils.h ===================================== @@ -0,0 +1,27 @@ +#pragma once + +#if defined(__SANITIZE_ADDRESS__) +#define ASAN_ENABLED +#elif defined(__has_feature) +#if __has_feature(address_sanitizer) +#define ASAN_ENABLED +#endif +#endif + +#if defined(ASAN_ENABLED) +#include <sanitizer/asan_interface.h> +#else + +#include <stddef.h> + +static inline void __asan_poison_memory_region(void const volatile *addr + __attribute__((unused)), + size_t size + __attribute__((unused))) {} + +static inline void __asan_unpoison_memory_region(void const volatile *addr + __attribute__((unused)), + size_t size + __attribute__((unused))) {} + +#endif ===================================== rts/rts.cabal ===================================== @@ -292,6 +292,7 @@ library -- ^ generated rts/ghc_ffi.h rts/Adjustor.h + rts/ASANUtils.h rts/ExecPage.h rts/BlockSignals.h rts/Bytecodes.h ===================================== rts/sm/BlockAlloc.c ===================================== @@ -241,6 +241,9 @@ tail_of (bdescr *bd) STATIC_INLINE void initGroup(bdescr *head) { + __asan_unpoison_memory_region(head, + stg_min((W_)head->blocks, (W_)BLOCKS_PER_MBLOCK) * sizeof(bdescr)); + head->free = head->start; head->link = NULL; @@ -261,6 +264,8 @@ initGroup(bdescr *head) head[i].flags = 0; } #endif + + __asan_unpoison_memory_region(head->start, (W_)head->blocks * BLOCK_SIZE); } #if SIZEOF_VOID_P == SIZEOF_LONG @@ -308,6 +313,7 @@ setup_tail (bdescr *bd) bdescr *tail; tail = tail_of(bd); if (tail != bd) { + __asan_unpoison_memory_region(tail, sizeof(bdescr)); tail->blocks = 0; tail->free = 0; tail->link = bd; @@ -325,6 +331,7 @@ split_free_block (bdescr *bd, uint32_t node, W_ n, uint32_t ln /* log_2_ceil(n) ASSERT(bd->blocks > n); dbl_link_remove(bd, &free_list[node][ln]); fg = bd + bd->blocks - n; // take n blocks off the end + __asan_unpoison_memory_region(fg, sizeof(bdescr)); fg->blocks = n; bd->blocks -= n; setup_tail(bd); @@ -474,6 +481,8 @@ alloc_mega_group (uint32_t node, StgWord mblocks) bd = alloc_mega_group_from_free_list(&deferred_free_mblock_list[node], n, &best); if(bd) { + __asan_unpoison_memory_region(MBLOCK_ROUND_DOWN(bd), FIRST_BLOCK_OFF); + __asan_unpoison_memory_region(bd->start, (W_)bd->blocks * BLOCK_SIZE); return bd; } else if(!best) @@ -490,6 +499,8 @@ alloc_mega_group (uint32_t node, StgWord mblocks) if (bd) { + __asan_unpoison_memory_region(MBLOCK_ROUND_DOWN(bd), FIRST_BLOCK_OFF); + __asan_unpoison_memory_region(bd->start, (W_)bd->blocks * BLOCK_SIZE); return bd; } else if (best) @@ -500,6 +511,7 @@ alloc_mega_group (uint32_t node, StgWord mblocks) (best_mblocks-mblocks)*MBLOCK_SIZE); best->blocks = MBLOCK_GROUP_BLOCKS(best_mblocks - mblocks); + __asan_unpoison_memory_region(MBLOCK_ROUND_DOWN(bd), mblocks * MBLOCK_SIZE); initMBlock(MBLOCK_ROUND_DOWN(bd), node); } else @@ -880,6 +892,11 @@ free_mega_group (bdescr *mg) IF_DEBUG(sanity, checkFreeListSanity()); } + + __asan_poison_memory_region(mg->start, (W_)mg->blocks * BLOCK_SIZE); + // Only the head bdescr of a free mega group carries meaning; poison the + // rest of the first mblock's descriptor area. + __asan_poison_memory_region(mg + 1, ((W_)BLOCKS_PER_MBLOCK - 1) * sizeof(bdescr)); } static void @@ -927,6 +944,9 @@ free_deferred_mega_groups (uint32_t node) // coalesce forwards coalesce_mblocks(mg); + __asan_poison_memory_region(mg->start, (W_)mg->blocks * BLOCK_SIZE); + __asan_poison_memory_region(mg + 1, ((W_)BLOCKS_PER_MBLOCK - 1) * sizeof(bdescr)); + // initialize search for next round prev = mg; bd = prev->link; @@ -979,7 +999,9 @@ freeGroup(bdescr *p) RELAXED_STORE(&p->gen, NULL); RELAXED_STORE(&p->gen_no, 0); /* fill the block group with garbage if sanity checking is on */ - IF_DEBUG(zero_on_gc, memset(p->start, 0xaa, (W_)p->blocks * BLOCK_SIZE)); + IF_DEBUG(zero_on_gc, + __asan_unpoison_memory_region(p->start, (W_)p->blocks * BLOCK_SIZE); + memset(p->start, 0xaa, (W_)p->blocks * BLOCK_SIZE)); if (p->blocks == 0) barf("freeGroup: block size is zero"); @@ -1050,6 +1072,13 @@ freeGroup(bdescr *p) setup_tail(p); free_list_insert(node,p); + __asan_poison_memory_region(p->start, (W_)p->blocks * BLOCK_SIZE); + // Only the head and tail bdescrs of a free group carry meaning; poison the + // interior ones to catch stale Bdescr() lookups through dangling pointers. + if (p->blocks > 2) { + __asan_poison_memory_region(p + 1, ((W_)p->blocks - 2) * sizeof(bdescr)); + } + IF_DEBUG(sanity, checkFreeListSanity()); } @@ -1421,6 +1450,7 @@ reportUnmarkedBlocks (void) debugBelch("Unreachable blocks:\n"); for (mblock = getFirstMBlock(&state); mblock != NULL; mblock = getNextMBlock(&state, mblock)) { + __asan_unpoison_memory_region(mblock, FIRST_BLOCK_OFF); for (bd = FIRST_BDESCR(mblock); bd <= LAST_BDESCR(mblock); ) { if (!(bd->flags & BF_KNOWN) && bd->free != (P_)-1) { debugBelch(" %p\n",bd); ===================================== rts/sm/GCUtils.c ===================================== @@ -348,6 +348,7 @@ alloc_todo_block (gen_workspace *ws, uint32_t size) } else { if (gct->free_blocks) { bd = gct->free_blocks; + __asan_unpoison_memory_region(bd->start, (W_)bd->blocks * BLOCK_SIZE); gct->free_blocks = bd->link; } else { // We allocate in chunks of at most 16 blocks, use one @@ -357,6 +358,9 @@ alloc_todo_block (gen_workspace *ws, uint32_t size) StgWord n_blocks = stg_min(chunk_size, 1 << (MBLOCK_SHIFT - BLOCK_SHIFT - 1)); allocBlocks_sync(n_blocks, &bd); gct->free_blocks = bd->link; + for (bdescr *bd = gct->free_blocks; bd; bd = bd->link) { + __asan_poison_memory_region(bd->start, (W_)bd->blocks * BLOCK_SIZE); + } } } initBdescr(bd, ws->gen, ws->gen->to); ===================================== rts/sm/MBlock.c ===================================== @@ -641,6 +641,8 @@ getMBlocks(uint32_t n) ret = getCommittedMBlocks(n); + __asan_unpoison_memory_region(ret, (W_)n * MBLOCK_SIZE); + debugTrace(DEBUG_gc, "allocated %d megablock(s) at %p",n,ret); mblocks_allocated += n; @@ -673,6 +675,8 @@ freeMBlocks(void *addr, uint32_t n) mblocks_allocated -= n; + __asan_poison_memory_region(addr, (W_)n * MBLOCK_SIZE); + decommitMBlocks(addr, n); } ===================================== rts/sm/NonMoving.c ===================================== @@ -597,6 +597,8 @@ static void nonmovingExitConcurrentWorker(void); void nonmovingPushFreeSegment(struct NonmovingSegment *seg) { SET_SEGMENT_STATE(seg, FREE); + __asan_poison_memory_region(seg->bitmap, + (uintptr_t)seg + NONMOVING_SEGMENT_SIZE - (uintptr_t)seg->bitmap); while (true) { struct NonmovingSegment *old = nonmovingHeap.free; seg->link = old; ===================================== rts/sm/NonMovingAllocate.c ===================================== @@ -118,6 +118,8 @@ static void nonmovingClearBitmap(struct NonmovingSegment *seg) static void nonmovingInitSegment(struct NonmovingSegment *seg, uint16_t allocator_idx) { bdescr *bd = Bdescr((P_) seg); + __asan_unpoison_memory_region(seg->bitmap, + (uintptr_t)seg + NONMOVING_SEGMENT_SIZE - (uintptr_t)seg->bitmap); seg->link = NULL; seg->todo_link = NULL; seg->next_free = 0; @@ -126,6 +128,8 @@ static void nonmovingInitSegment(struct NonmovingSegment *seg, uint16_t allocato bd->nonmoving_segment.next_free_snap = 0; bd->u.scan = nonmovingSegmentGetBlock(seg, 0); nonmovingClearBitmap(seg); + __asan_poison_memory_region(bd->u.scan, + (uintptr_t)seg + NONMOVING_SEGMENT_SIZE - (uintptr_t)bd->u.scan); } /* Initialize a new capability. Must hold SM_LOCK. */ @@ -229,6 +233,7 @@ static void *nonmovingAllocate_(enum AllocLockMode mode, Capability *cap, StgWor unsigned int block_count = nonmovingSegmentBlockCount(current); void *ret = nonmovingSegmentGetBlock_(current, block_size, block_count, current->next_free); ASSERT(GET_CLOSURE_TAG(ret) == 0); // check alignment + __asan_unpoison_memory_region(ret, block_size); // Advance the current segment's next_free or allocate a new segment if full bool full = advance_next_free(current, block_count); ===================================== rts/sm/NonMovingSweep.c ===================================== @@ -33,6 +33,7 @@ nonmovingSweepSegment(struct NonmovingSegment *seg) { ASSERT_SEGMENT_STATE(seg, FILLED_SWEEPING); const nonmoving_block_idx blk_cnt = nonmovingSegmentBlockCount(seg); + const uint16_t blk_size = nonmovingSegmentBlockSize(seg); bool found_free = false; bool found_live = false; @@ -42,6 +43,8 @@ nonmovingSweepSegment(struct NonmovingSegment *seg) found_live = true; } else { seg->bitmap[i] = 0; + __asan_poison_memory_region( + nonmovingSegmentGetBlock_(seg, blk_size, blk_cnt, i), blk_size); if (!found_free) { // This is the first free block we've found; set next_free, // next_free_snap, and the scan pointer. @@ -57,6 +60,8 @@ nonmovingSweepSegment(struct NonmovingSegment *seg) for (; i < nonmovingSegmentBlockCount(seg); ++i) { if (seg->bitmap[i] != nonmovingMarkEpoch) { seg->bitmap[i] = 0; + __asan_poison_memory_region( + nonmovingSegmentGetBlock_(seg, blk_size, blk_cnt, i), blk_size); } } return SEGMENT_PARTIAL; @@ -113,7 +118,9 @@ void nonmovingClearSegment(struct NonmovingSegment* seg) { size_t end = ((size_t)seg) + NONMOVING_SEGMENT_SIZE; + __asan_unpoison_memory_region(&seg->bitmap, end - (size_t)&seg->bitmap); memset(&seg->bitmap, 0, end - (size_t)&seg->bitmap); + __asan_poison_memory_region(&seg->bitmap, end - (size_t)&seg->bitmap); } void @@ -124,7 +131,18 @@ nonmovingClearSegmentFreeBlocks(struct NonmovingSegment* seg) // N.B. nonmovingSweepSegment helpfully clears the bitmap entries of // dead blocks if (nonmovingGetMark(seg, p_idx) == 0) { - memset(nonmovingSegmentGetBlock(seg, p_idx), 0, block_size); + void *blk = nonmovingSegmentGetBlock(seg, p_idx); + if (p_idx >= seg->next_free) { + // Free block: it is poisoned, so unpoison for the memset and + // re-poison afterwards. Unmarked blocks below next_free were + // allocated since the last sweep and are live; leave those + // unpoisoned. + __asan_unpoison_memory_region(blk, block_size); + memset(blk, 0, block_size); + __asan_poison_memory_region(blk, block_size); + } else { + memset(blk, 0, block_size); + } } } } ===================================== rts/sm/Storage.c ===================================== @@ -1242,6 +1242,10 @@ start_new_pinned_block(Capability *cap) ACQUIRE_SM_LOCK; bd = allocNursery(cap->node, NULL, PINNED_EMPTY_SIZE); RELEASE_SM_LOCK; + + for (bdescr *pbd = bd; pbd; pbd = pbd->link) { + __asan_poison_memory_region(pbd->start, (W_)pbd->blocks * BLOCK_SIZE); + } } // Bump up the nursery pointer to avoid the pathological situation @@ -1267,6 +1271,7 @@ start_new_pinned_block(Capability *cap) } cap->pinned_object_empty = bd->link; + __asan_unpoison_memory_region(bd->start, (W_)bd->blocks * BLOCK_SIZE); newNurseryBlock(bd); if (bd->link != NULL) { bd->link->u.back = cap->pinned_object_empty; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ba98fc8e3ab1011f5984ace5a57fa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ba98fc8e3ab1011f5984ace5a57fa… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] EPA: Move the 'where' annotation for PatSynBind
by Marge Bot (＠marge-bot) 06 Jul '26

06 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f701cd6d by Alan Zimmerman at 2026-07-06T02:57:14-04:00 EPA: Move the 'where' annotation for PatSynBind This allows us to move it out of the MatchGroup exact print annotation too - - - - - 18 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -147,11 +147,12 @@ data AnnPSB = AnnPSB { ap_pattern :: EpToken "pattern", ap_larrow :: Maybe (EpUniToken "<-" "←"), - ap_equal :: Maybe (EpToken "=") + ap_equal :: Maybe (EpToken "="), + ap_where :: Maybe (EpToken "where") } deriving Data instance NoAnn AnnPSB where - noAnn = AnnPSB noAnn noAnn noAnn + noAnn = AnnPSB noAnn noAnn noAnn noAnn -- --------------------------------------------------------------------- ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -68,7 +68,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationGrhsAnn `extQ` annotationAnnList `extQ` annotationEpAnnListWhere - `extQ` annotationAnnListWhere + `extQ` annotationAnnListUnit `extQ` annotationAnnListCommas `extQ` annotationAnnListEpaLocation `extQ` annotationNoEpAnns @@ -377,9 +377,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") - annotationAnnListWhere :: AnnList (EpToken "where") -> SDoc - annotationAnnListWhere anns = case ba of - BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList (EpToken \"where\")") + annotationAnnListUnit :: AnnList () -> SDoc + annotationAnnListUnit anns = case ba of + BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList ()") NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) $$ vcat (gmapQ showAstData' anns) ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1654,7 +1654,7 @@ type instance XMG GhcRn b = (Origin, -- See Note [Generated code and pat MatchGroupAnn) type instance XMG GhcTc b = MatchGroupTc -type MatchGroupAnn = AnnList (EpToken "where") +type MatchGroupAnn = AnnList () data MatchGroupTc = MatchGroupTc ===================================== compiler/GHC/Parser.y ===================================== @@ -1760,19 +1760,19 @@ pattern_synonym_decl :: { LHsDecl GhcPs } {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 ImplicitBidirectional - (AnnPSB (epTok $1) Nothing (Just (epTok $3)))) } + (AnnPSB (epTok $1) Nothing (Just (epTok $3)) Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) } + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls {% do { let (name, args) = $2 ; mg <- mkPatSynMatchGroup name $5 ; amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 (ExplicitBidirectional mg) - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing (Just (sndOf3 $ unLoc $5)) )) }} pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs) } @@ -1789,11 +1789,13 @@ cvars1 :: { [RecordPatSynField GhcPs] } | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2) ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} -where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) } +where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) () [])) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) () [])) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -3535,7 +3537,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))) } +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) noAnn []))) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -723,9 +723,9 @@ tyConToDataCon (L loc tc) occ = rdrNameOcc tc mkPatSynMatchGroup :: LocatedN RdrName - -> LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) + -> LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, ann)) = +mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, _, ann)) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr (locA loc)) ; return $ mkMatchGroup FromSource ann (L ld matches) } @@ -1772,11 +1772,11 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -> PV (LocatedA b) -- | Disambiguate "case ... of ..." mkHsCasePV :: SrcSpan -> LHsExpr GhcPs - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnHsCase -> PV (LocatedA b) -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" mkHsLamPV :: SrcSpan -> HsLamVariant - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnLam -> PV (LocatedA b) -- | Function argument representation ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -86,7 +86,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2232,7 +2232,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -94,7 +94,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -218,7 +218,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -371,7 +371,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -34,7 +34,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -271,7 +271,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -578,7 +578,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -840,7 +840,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1056,7 +1056,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1162,7 +1162,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1270,7 +1270,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1786,7 +1786,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1914,7 +1914,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2040,7 +2040,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2153,7 +2153,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2281,7 +2281,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2402,7 +2402,7 @@ (EpaSpan { DumpSemis.hs:38:7 })) ,(EpTok (EpaSpan { DumpSemis.hs:38:8 }))] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -1018,7 +1018,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1753,7 +1753,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -108,7 +108,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -207,7 +207,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -330,7 +330,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -525,7 +525,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -646,7 +646,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -763,7 +763,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -555,7 +555,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1165,7 +1165,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2326,7 +2326,7 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (PSB{ psb_ext = AnnPSB ap al ae + exact (PSB{ psb_ext = AnnPSB ap al ae aw , psb_id = psyn, psb_args = details , psb_def = pat , psb_dir = dir }) = do @@ -2349,23 +2349,24 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where ac' <- markEpToken ac return (psyn', RecCon (ao',ac') vs') - (al', ae', pat', dir') <- + (al', ae', pat', dir', aw') <- case dir of Unidirectional -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat - return (al', ae, pat', dir) + return (al', ae, pat', dir, aw) ImplicitBidirectional -> do ae' <- mapM markEpToken ae pat' <- markAnnotated pat - return (al, ae', pat', dir) + return (al, ae', pat', dir, aw) ExplicitBidirectional mg -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat + aw' <- mapM markEpToken aw mg' <- markAnnotated mg - return (al', ae, pat', ExplicitBidirectional mg') + return (al', ae, pat', ExplicitBidirectional mg', aw') - return (PSB{ psb_ext = AnnPSB ap' al' ae' + return (PSB{ psb_ext = AnnPSB ap' al' ae' aw' , psb_id = psyn', psb_args = details' , psb_def = pat' , psb_dir = dir' }) @@ -3249,11 +3250,10 @@ instance (Typeable body, = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches) exact (MG (origin,an) (L l matches)) = do - an0 <- markLensFun an lal_rest markEpToken -- 'where', only for PatSynBind - (an1,matches') <- markAnnListA' an0 $ \a -> do + (an0,matches') <- markAnnListA' an $ \a -> do m' <- markAnnotated matches return (a,m') - return (MG (origin, an1) (L l matches')) + return (MG (origin, an0) (L l matches')) -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f701cd6d2d73348cb0afb1364891cec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f701cd6d2d73348cb0afb1364891cec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] EPA: Move the 'where' annotation for PatSynBind
by Marge Bot (＠marge-bot) 06 Jul '26

06 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: dccee6fe by Alan Zimmerman at 2026-07-06T00:25:49-04:00 EPA: Move the 'where' annotation for PatSynBind This allows us to move it out of the MatchGroup exact print annotation too - - - - - 18 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -147,11 +147,12 @@ data AnnPSB = AnnPSB { ap_pattern :: EpToken "pattern", ap_larrow :: Maybe (EpUniToken "<-" "←"), - ap_equal :: Maybe (EpToken "=") + ap_equal :: Maybe (EpToken "="), + ap_where :: Maybe (EpToken "where") } deriving Data instance NoAnn AnnPSB where - noAnn = AnnPSB noAnn noAnn noAnn + noAnn = AnnPSB noAnn noAnn noAnn noAnn -- --------------------------------------------------------------------- ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -68,7 +68,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationGrhsAnn `extQ` annotationAnnList `extQ` annotationEpAnnListWhere - `extQ` annotationAnnListWhere + `extQ` annotationAnnListUnit `extQ` annotationAnnListCommas `extQ` annotationAnnListEpaLocation `extQ` annotationNoEpAnns @@ -377,9 +377,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") - annotationAnnListWhere :: AnnList (EpToken "where") -> SDoc - annotationAnnListWhere anns = case ba of - BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList (EpToken \"where\")") + annotationAnnListUnit :: AnnList () -> SDoc + annotationAnnListUnit anns = case ba of + BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList ()") NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) $$ vcat (gmapQ showAstData' anns) ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1654,7 +1654,7 @@ type instance XMG GhcRn b = (Origin, -- See Note [Generated code and pat MatchGroupAnn) type instance XMG GhcTc b = MatchGroupTc -type MatchGroupAnn = AnnList (EpToken "where") +type MatchGroupAnn = AnnList () data MatchGroupTc = MatchGroupTc ===================================== compiler/GHC/Parser.y ===================================== @@ -1760,19 +1760,19 @@ pattern_synonym_decl :: { LHsDecl GhcPs } {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 ImplicitBidirectional - (AnnPSB (epTok $1) Nothing (Just (epTok $3)))) } + (AnnPSB (epTok $1) Nothing (Just (epTok $3)) Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat {% let (name, args) = $2 in amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) } + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing Nothing)) } | 'pattern' pattern_synonym_lhs '<-' pat_syn_pat where_decls {% do { let (name, args) = $2 ; mg <- mkPatSynMatchGroup name $5 ; amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 (ExplicitBidirectional mg) - (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing)) + (AnnPSB (epTok $1) (Just (epUniTok $3)) Nothing (Just (sndOf3 $ unLoc $5)) )) }} pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs) } @@ -1789,11 +1789,13 @@ cvars1 :: { [RecordPatSynField GhcPs] } | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2) ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} -where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) } +where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) () [])) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, - AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) (epTok $1) [])) } + epTok $1, + AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) () [])) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -3535,7 +3537,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where"))) } +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ())) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) noAnn []))) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -723,9 +723,9 @@ tyConToDataCon (L loc tc) occ = rdrNameOcc tc mkPatSynMatchGroup :: LocatedN RdrName - -> LocatedA (OrdList (LHsDecl GhcPs), AnnList (EpToken "where")) + -> LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList ()) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, ann)) = +mkPatSynMatchGroup (L loc patsyn_name) (L ld (decls, _, ann)) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr (locA loc)) ; return $ mkMatchGroup FromSource ann (L ld matches) } @@ -1772,11 +1772,11 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -> PV (LocatedA b) -- | Disambiguate "case ... of ..." mkHsCasePV :: SrcSpan -> LHsExpr GhcPs - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnHsCase -> PV (LocatedA b) -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" mkHsLamPV :: SrcSpan -> HsLamVariant - -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList (EpToken "where")) + -> LocatedA ([LMatch GhcPs (LocatedA b)], AnnList ()) -> EpAnnLam -> PV (LocatedA b) -- | Function argument representation ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -86,7 +86,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2232,7 +2232,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -94,7 +94,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -218,7 +218,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -371,7 +371,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -34,7 +34,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -271,7 +271,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -578,7 +578,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -840,7 +840,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1056,7 +1056,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1162,7 +1162,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1270,7 +1270,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1786,7 +1786,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1914,7 +1914,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2040,7 +2040,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2153,7 +2153,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2281,7 +2281,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -2402,7 +2402,7 @@ (EpaSpan { DumpSemis.hs:38:7 })) ,(EpTok (EpaSpan { DumpSemis.hs:38:8 }))] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -1018,7 +1018,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1753,7 +1753,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -108,7 +108,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -99,7 +99,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -74,7 +74,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -207,7 +207,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -330,7 +330,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -525,7 +525,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -646,7 +646,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -763,7 +763,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -555,7 +555,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn @@ -1165,7 +1165,7 @@ (Nothing) (ListNone) [] - (NoEpTok) + (()) [])) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2326,7 +2326,7 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (PSB{ psb_ext = AnnPSB ap al ae + exact (PSB{ psb_ext = AnnPSB ap al ae aw , psb_id = psyn, psb_args = details , psb_def = pat , psb_dir = dir }) = do @@ -2349,23 +2349,24 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where ac' <- markEpToken ac return (psyn', RecCon (ao',ac') vs') - (al', ae', pat', dir') <- + (al', ae', pat', dir', aw') <- case dir of Unidirectional -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat - return (al', ae, pat', dir) + return (al', ae, pat', dir, aw) ImplicitBidirectional -> do ae' <- mapM markEpToken ae pat' <- markAnnotated pat - return (al, ae', pat', dir) + return (al, ae', pat', dir, aw) ExplicitBidirectional mg -> do al' <- mapM markEpUniToken al pat' <- markAnnotated pat + aw' <- mapM markEpToken aw mg' <- markAnnotated mg - return (al', ae, pat', ExplicitBidirectional mg') + return (al', ae, pat', ExplicitBidirectional mg', aw') - return (PSB{ psb_ext = AnnPSB ap' al' ae' + return (PSB{ psb_ext = AnnPSB ap' al' ae' aw' , psb_id = psyn', psb_args = details' , psb_def = pat' , psb_dir = dir' }) @@ -3249,11 +3250,10 @@ instance (Typeable body, = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches) exact (MG (origin,an) (L l matches)) = do - an0 <- markLensFun an lal_rest markEpToken -- 'where', only for PatSynBind - (an1,matches') <- markAnnListA' an0 $ \a -> do + (an0,matches') <- markAnnListA' an $ \a -> do m' <- markAnnotated matches return (a,m') - return (MG (origin, an1) (L l matches')) + return (MG (origin, an0) (L l matches')) -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dccee6fe48a731016d6fb1660db5615… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dccee6fe48a731016d6fb1660db5615… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/udfm-placement] 3 commits: Add Word64Map.compareSize; use it in UniqDFM's sorting guards
by Simon Jakobi (＠sjakobi2) 05 Jul '26

05 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC Commits: e4fa09ab by Simon Jakobi at 2026-07-03T12:47:23+02:00 Add Word64Map.compareSize; use it in UniqDFM's sorting guards The guards in eltsUDFM/udfmToList need the map's size only to compare it against a small bound, but computed it with a full O(n) traversal. Add compareSize, a verbatim port of Data.IntMap.compareSize from containers (haskell/containers#1139), which stops traversing as soon as the outcome is decided, and use it for both guards: the singleton check becomes O(1) and the placement/mergesort dispatch O(min(n, i)). Assisted-by: Claude Fable 5 - - - - - 1fdedb00 by Simon Jakobi at 2026-07-03T12:53:57+02:00 Fill placementSort's array directly from the Word64Map eltsUDFM and udfmToList materialized an intermediate list (for udfmToList even one of freshly allocated TaggedVals) only for placementSort to consume it in a single strict fill pass. Instead pass placementSort the map itself plus a per-element projection, and fill the array with the new Word64Map.traverseWithKey_, which visits each entry with an applicative action without building any intermediate structure. Instantiated at ST, this compiles to a fill loop that allocates nothing beyond the array (verified in the Core dump). Assisted-by: Claude Fable 5 - - - - - b4022ce8 by Simon Jakobi at 2026-07-06T01:17:53+02:00 Fixes and wibbles - - - - - 5 changed files: - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Data/Word64Map/Strict.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -72,6 +72,7 @@ module GHC.Data.Word64Map.Internal ( -- * Query , null , size + , compareSize , member , notMember , lookup @@ -169,6 +170,7 @@ module GHC.Data.Word64Map.Internal ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey @@ -522,6 +524,8 @@ null _ = False -- > size empty == 0 -- > size (singleton 1 'a') == 1 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 +-- +-- See also: 'compareSize' size :: Word64Map a -> Int size = go 0 where @@ -529,6 +533,23 @@ size = go 0 go acc (Tip _ _) = 1 + acc go acc Nil = acc +-- | $O(\min(n,c))$. Compare the number of entries in the map to an @Int@. +-- +-- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is +-- more efficient when @c@ is smaller than the size of the map. +compareSize :: Word64Map a -> Int -> Ordering +compareSize Nil c0 = compare 0 c0 +compareSize _ c0 | c0 <= 0 = GT +compareSize t c0 = compare 0 (go t (c0 - 1)) + where + go (Bin _ _ _ _) 0 = -1 + go (Bin _ _ l r) c + | c' < 0 = c' + | otherwise = go r c' + where + c' = go l (c - 1) + go _ c = c -- Must be Tip (Nil is never a child of Bin) + -- | $O(\min(n,W))$. Is the key a member of the map? -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True @@ -2500,6 +2521,18 @@ traverseWithKey f = go | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} +-- | $O(n)$. Visit each key\/value pair in ascending key order, discarding +-- the results. +-- +-- Unlike @traverse_ . toList@, this builds no intermediate structure. +traverseWithKey_ :: Applicative t => (Key -> a -> t ()) -> Word64Map a -> t () +traverseWithKey_ f = go + where + go Nil = pure () + go (Tip k v) = f k v + go (Bin _ _ l r) = go l *> go r +{-# INLINE traverseWithKey_ #-} + -- | $O(n)$. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. -- ===================================== compiler/GHC/Data/Word64Map/Lazy.hs ===================================== @@ -113,6 +113,7 @@ module GHC.Data.Word64Map.Lazy ( -- ** Size , WM.null , size + , compareSize -- * Combine @@ -148,6 +149,7 @@ module GHC.Data.Word64Map.Lazy ( , WM.map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey ===================================== compiler/GHC/Data/Word64Map/Strict.hs ===================================== @@ -130,6 +130,7 @@ module GHC.Data.Word64Map.Strict ( -- ** Size , null , size + , compareSize -- * Combine @@ -165,6 +166,7 @@ module GHC.Data.Word64Map.Strict ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -132,6 +132,7 @@ module GHC.Data.Word64Map.Strict.Internal ( -- ** Size , null , size + , compareSize -- * Combine @@ -167,6 +168,7 @@ module GHC.Data.Word64Map.Strict.Internal ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey @@ -322,12 +324,14 @@ import GHC.Data.Word64Map.Internal , spanAntitone , restrictKeys , size + , compareSize , split , splitLookup , splitRoot , toAscList , toDescList , toList + , traverseWithKey_ , union , unions , withoutKeys ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -97,9 +97,9 @@ import qualified GHC.Data.Word64Set as W -- If the client of the map performs operations on the map in deterministic -- order then `udfmToList` returns them in deterministic order. -- --- There is an implementation cost: each element is given a serial number +-- There is an implementation cost: each element is given an insertion tag -- as it is added, and functions like `udfmToList` or `eltsUDFM` order their --- results by this serial number (see +-- results by this tag (see -- Note [Cost of deterministic iteration]). So you should only use `UniqDFM` -- if you need the deterministic property. -- @@ -114,7 +114,7 @@ import qualified GHC.Data.Word64Set as W -- -- -- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the +-- every value with its insertion tag that can later be used to sort the -- values when asked to convert to a list. -- -- An alternative would be to have @@ -133,11 +133,11 @@ import qualified GHC.Data.Word64Set as W -- -- may also be worth considering. Compare Dhall.Map in the dhall package. --- | A type of values tagged with insertion time +-- | A type of values carrying an insertion tag data TaggedVal val = TaggedVal !val - {-# UNPACK #-} !Int -- ^ insertion time + {-# UNPACK #-} !Int -- ^ insertion tag deriving stock (Data, Functor, Foldable, Traversable) taggedFst :: TaggedVal val -> val @@ -159,13 +159,25 @@ instance Eq val => Eq (TaggedVal val) where data UniqDFM key ele = UDFM !(M.Word64Map (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map + -- values carry an insertion tag. {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] + -- tags. See Note [Overflow on plusUDFM] + -- See Note [UDFM invariants] deriving (Data, Functor) +{- Note [UDFM invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In a map (UDFM m ub): + + (a) The insertion tags of the elements of m are distinct. + (b) Every tag lies in [0, ub). + +Consequently ub >= size m. + +The tags determine the order of deterministic iteration (eltsUDFM, +udfmToList); see Note [Sorting a UDFM]. +-} + -- | Deterministic. -- -- See Note [Cost of deterministic iteration]. @@ -266,8 +278,8 @@ plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j) -- Note [Overflow on plusUDFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. +-- The main problem that needs to be solved is overlap on insertion +-- tags between different keys in two maps. -- Consider: -- -- A = fromList [(a, (x, 1))] @@ -355,84 +367,108 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m where k' acc (TaggedVal v _) = k v acc --- Note [Cost of deterministic iteration] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Deterministic iteration orders elements by insertion tag, and any such --- ordering must inspect every element's tag before it can emit the first --- element. So even the head of the result costs a full traversal of the map --- plus -- on the main path -- the allocation of an O(n)-sized array (see --- Note [Sorting a UDFM]). Laziness in the result list only avoids allocating --- for elements that are never demanded; it does not make the iteration --- incremental. #27459 shows this cost biting in consumers that demanded only --- the head. --- --- So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM; --- for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and --- if you don't need the deterministic order at all, use the nonDet functions. +{- Note [Cost of deterministic iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deterministic iteration -- eltsUDFM, udfmToList, and everything built on +them, such as foldUDFM and UniqDFM's Foldable instance -- orders elements +by insertion tag, and any such ordering must inspect every element's tag +before it can emit the first element. So even the head of the result costs +a full traversal of the map plus -- on the main path -- the allocation of +an O(n)-sized array (see Note [Sorting a UDFM]). Laziness in the result +list only avoids allocating for elements that are never demanded; it does +not make the iteration incremental. #27459 shows this cost biting in +consumers that demanded only the head. + +So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM; +for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and +if you don't need the deterministic order at all, use the nonDet functions. +-} -- | Deterministic, in order of insertion. -- -- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration]. eltsUDFM :: UniqDFM key elt -> [elt] -eltsUDFM (UDFM m i) - | n <= 1 = map taggedFst (M.elems m) - | usePlacement n i = placementSort i (M.elems m) - | otherwise = map taggedFst (sort_it m) - where n = M.size m +eltsUDFM (UDFM m ub) + | M.compareSize m 1 /= GT = map taggedFst (M.elems m) + | usePlacement m ub = placementSort ub (\_ tv -> tv) m + | otherwise = map taggedFst (sort_it m) sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt] sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) --- Note [Sorting a UDFM] --- ~~~~~~~~~~~~~~~~~~~~~ --- Deterministic iteration must order elements by insertion tag. Instead of a --- comparison sort -- the list mergesort behind sortBy allocates ~n*log n cons --- cells -- we exploit the invariant that in (UDFM m i) all tags are distinct --- Ints in [0, i): allocate an array of size i, write each element at --- @index = tag@, freeze, and read out in index order. That's O(i) work (which --- subsumes the O(n) fill, since distinct tags force n <= i), no comparisons, --- and the readout is lazy, so consumers that demand only a prefix pay almost --- nothing beyond the fill (but the fill itself is unavoidable; see --- Note [Cost of deterministic iteration]). --- --- Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal --- with tag -1. Real tags are non-negative, so the readout skips on tag < 0; --- the sentinel's value field is never touched (it is unsafeCoerced ()). --- --- This sorting method loses when i is much larger than n: i never shrinks --- (overwrites keep bumping it, delete/filter shrink n but not i). We compute --- n = M.size m (O(n), cheap next to either sort) and fall back to the --- mergesort when i > 4 * n. Maps built by plain insertion -- the common --- case -- have i == n. The guard also caps the fast path's O(i) at O(n). - -usePlacement :: Int -> Int -> Bool -usePlacement n i = i <= 4 * n - --- | Order a list of 'TaggedVal's by tag, by placing each at array index = --- its tag. --- --- The tags must be distinct and in @[0, i)@. --- See Note [Sorting a UDFM]. -placementSort :: forall r. Int -> [TaggedVal r] -> [r] -placementSort i tvs = runST (ST (\s0 -> - case newSmallArray i hole s0 of - (# s1, marr #) -> case fill marr tvs s1 of - s2 -> case unsafeFreezeSmallArray marr s2 of +{- Note [Sorting a UDFM] +~~~~~~~~~~~~~~~~~~~~~~~~ +Deterministic iteration must order elements by insertion tag. A comparison +sort is needlessly expensive: the list mergesort behind sortBy allocates +~n*log n cons cells, and in #27459 those allocations made up a large share +of the compiler's total allocation on the InstanceMatching perf tests. + +Instead we exploit the UDFM invariants (all tags in (UDFM m ub) are distinct +Ints in [0, ub); see Note [UDFM invariants]): allocate an array of size ub, +write each element at +@index = tag@, freeze, and read out in index order. The fill is O(n) work, +where n = size m; the readout is O(ub); and since ub >= n, the whole sort is +O(ub) -- with no comparisons. The readout is lazy, so consumers that demand +only a prefix pay almost nothing beyond the fill (but the fill itself is +unavoidable; see Note [Cost of deterministic iteration]). + +Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal +with tag -1. Real tags are non-negative, so the readout skips on tag < 0. +The sentinel's value field is never read, but something must fill it: not a +panic thunk -- TaggedVal's strict value field would force it as soon as the +readout inspects a hole's tag -- so we borrow the value of an arbitrary map +element. (Safe: the callers' guards send maps of size < 2 down a different +path, so the map is never empty here.) + +This sorting method loses when ub is much larger than n = M.size m: ub never +shrinks (overwrites keep bumping it, delete/filter shrink n but not ub). We +fall back to the mergesort when ub > 4 * n; the decision about which sort to +use is made by usePlacement. It checks the threshold with M.compareSize, +which stops traversing the map as soon as the outcome is decided (so the +guard costs O(min(n, ub)), not a full O(n) size computation). Maps built by +plain insertion -- the common case -- have ub == n. The guard also caps the +fast path's O(ub) at O(n). +-} + +-- | @ub <= 4 * size m@, computed without a full 'M.size' traversal. +usePlacement :: M.Word64Map a -> Int -> Bool +usePlacement m ub = M.compareSize m ceil_ub_div_4 /= LT + where + ceil_ub_div_4 = (ub + 3) `div` 4 -- ceil(ub/4): ub <= 4*n iff n >= ceil(ub/4) + +-- | Order the map's elements by tag, by placing @mk key elt@ at array index = +-- the tag of @elt@. +-- +-- The map must be non-empty, its tags distinct and in @[0, ub)@; @mk@ must +-- preserve the tag. See Note [Sorting a UDFM]. +placementSort :: forall e r. Int + -> (M.Key -> TaggedVal e -> TaggedVal r) + -> M.Word64Map (TaggedVal e) + -> [r] +{-# INLINE placementSort #-} -- specializes mk into the fill loop +placementSort ub mk m = runST (ST (\s0 -> + case newSmallArray ub hole s0 of + (# s1, marr #) -> case fill marr s1 of + (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of (# s3, arr #) -> (# s3, readout arr 0 #))) where + -- The tag -1 marks unfilled slots; the value field is never read, but + -- it is strict, so it needs a real value of type r -- borrow one from + -- the map. See Note [Sorting a UDFM]. hole :: TaggedVal r - hole = TaggedVal (unsafeCoerce ()) (-1) + hole = case M.findMin m of + (k, tv) -> TaggedVal (taggedFst (mk k tv)) (-1) - fill :: SmallMutableArray s (TaggedVal r) -> [TaggedVal r] -> State# s -> State# s - fill _ [] s = s - fill marr (tv : tvs') s = - case writeSmallArray marr (taggedSnd tv) tv s of - s' -> fill marr tvs' s' + fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #) + fill marr s = case M.traverseWithKey_ write m of ST st -> st s + where + write k tv = ST (\s' -> + (# writeSmallArray marr (taggedSnd tv) (mk k tv) s', () #)) readout :: SmallArray (TaggedVal r) -> Int -> [r] readout arr j - | j >= i = [] + | j >= ub = [] | t < 0 = readout arr (j + 1) | otherwise = v : readout arr (j + 1) where TaggedVal v t = indexSmallArray arr j @@ -461,19 +497,17 @@ udfmRestrictKeysSet (UDFM val_set i) set = -- as this already incurs most of the cost of returning the full list. -- See Note [Cost of deterministic iteration]. udfmToList :: UniqDFM key elt -> [(Unique, elt)] -udfmToList (UDFM m i) - | n <= 1 = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ] +udfmToList (UDFM m ub) + | M.compareSize m 1 /= GT = + [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ] -- Unlike eltsUDFM, this allocates a fresh TaggedVal + pair per element - -- before the sort. If it ever matters, a parallel Word64 array of - -- keys filled in the same pass would avoid the eager boxes. - | usePlacement n i = placementSort i - (M.foldrWithKey (\k tv rest -> - TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv) : rest) [] m) + -- (they make up the result). + | usePlacement m ub = placementSort ub + (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m | otherwise = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] - where n = M.size m -- Determines whether two 'UniqDFM's contain the same keys. equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c645b9c8d5318d36dd37c23c4abb6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c645b9c8d5318d36dd37c23c4abb6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Decoupling 'L.H.S' from 'GHC.Hs.Doc'
by Marge Bot (＠marge-bot) 05 Jul '26

05 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 925959db by Recursion Ninja at 2026-07-04T04:14:12-04:00 Decoupling 'L.H.S' from 'GHC.Hs.Doc' * Migrated 'GHC.Hs.Doc' and 'GHC.Hs.DocString' AST defintions from 'GHC.*' namespace, to new 'Language.Haskell.Syntax.Doc' module in the 'L.H.S' "namespace." * Updated 'HsDocString to be TTG-parameterised as 'HsDocString pass'. * Added 'GHC.Hs.Extension.Pass': splits 'GhcPass'/'Pass' and all 'HsDocString' TTG instances out of 'GHC.Hs.Extension', which re-exports it unchanged (this is backwards compatible and prevents the introduction of a boot file). * Deleted 'GHC.Hs.Doc.hs-boot'; removed all 'L.H.S.*' imports of 'GHC.Hs.Doc'. * Updated 'GHC.Hs.DocString' to be TTG pass-parameterised throughout; moved 'mkHsDocStringChunk'/'unpackHDSC' here (require 'GHC.Utils.Encoding'). * Split 'GHC.Rename.Doc.rnHsDoc' from 'rnHsDocIdentifiersOnly'. * Updated parser, renamer, typechecker, HIE, and exact-print for new types. * Added 'HsDocString' TTG instances for 'DocNameI' to 'Haddock.Types'. * Killed the last module loop between GHC.* and LHS.*. - Only edges from LHS.* to GHC.Data.FastString now! Resolves #26971 - - - - - b7e24044 by mangoiv at 2026-07-04T04:14:56-04:00 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable - - - - - 4180af3f by Zubin Duggal at 2026-07-04T04:15:38-04:00 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin - - - - - 242d4317 by sheaf at 2026-07-04T04:16:19-04:00 Remove outdated comment in GHC.Data.ShortText There was a long comment in GHC.Data.ShortText about a workaround that was necessary when bootstrapping with GHC 9.2 and below. The actual logic has since been dropped, but the comment remained. This commit removes the vestigial comment. - - - - - 9b714c4c by Zubin Duggal at 2026-07-05T09:40:36+05:30 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 - - - - - 4a59b3ee by Zubin Duggal at 2026-07-05T09:40:36+05:30 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf - - - - - b47e4111 by Alan Zimmerman at 2026-07-05T18:02:07-04:00 EPA: Move the 'where' annotation for PatSynBind This allows us to move it out of the MatchGroup exact print annotation too - - - - - 83 changed files: - .gitlab/test-metrics.sh - + changelog.d/fix-absent-dict-projection - changelog.d/semaphore-v2 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - + compiler/GHC/Hs/Extension/Pass.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Doc.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Literal.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Expr.hs-boot - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Type.hs - − compiler/Language/Haskell/Syntax/Type.hs-boot - compiler/ghc.cabal.in - hadrian/src/Settings/Warnings.hs - libraries/ghc-boot/GHC/Data/ShortText.hs - libraries/semaphore-compat - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/dmdanal/should_compile/T18982.stderr - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/simplCore/should_compile/T26615.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6fd263280f8db452416bf873f0367… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6fd263280f8db452416bf873f0367… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 5 commits: EPA: Remove LocatedE completely, last usage for pats
by Alan Zimmerman (＠alanz) 05 Jul '26

05 Jul '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 236950e1 by Alan Zimmerman at 2026-07-05T12:48:23+01:00 EPA: Remove LocatedE completely, last usage for pats - - - - - 77fd15ee by Alan Zimmerman at 2026-07-05T15:17:14+01:00 EPA: Remove AnnList (EpToken "where") usages This is moving toward removing the parameter from AnnList completely - - - - - 12f5b438 by Alan Zimmerman at 2026-07-05T16:37:44+01:00 EPA remove AnnList (EpToken "rec") usages - - - - - 81455814 by Alan Zimmerman at 2026-07-05T18:57:01+01:00 EPA: Remove last parameterised AnnList usage (EpaLocation) Also remove the parameter - - - - - 0d13d46c by Alan Zimmerman at 2026-07-05T21:18:28+01:00 TTG: Add extension points to BooleanFormula They are currently unused, but will be used for exact print annotations next - - - - - 39 changed files: - compiler/GHC/Core/Class.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/Language/Haskell/Syntax/BooleanFormula.hs - compiler/Language/Haskell/Syntax/Extension.hs - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/982953c9be962a6b309312a7b0cfc4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/982953c9be962a6b309312a7b0cfc4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/cbe2
by Simon Jakobi (＠sjakobi2) 05 Jul '26

05 Jul '26

Simon Jakobi pushed new branch wip/sjakobi/cbe2 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/cbe2 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27456] base: Display ExceptionContext in WhileHandling's textual description
by Ben Gamari (＠bgamari) 05 Jul '26

05 Jul '26

Ben Gamari pushed to branch wip/T27456 at Glasgow Haskell Compiler / GHC Commits: d3680f06 by Ben Gamari at 2026-07-05T12:03:34-04:00 base: Display ExceptionContext in WhileHandling's textual description As originally-implemented the implementation for `WhileHandling(displayExceptionAnnotation)` would display the `ExceptionContext` of the exception which it carries (as this was the behavior of `displayException`, in terms of which `displayExceptionAnnotation` was implemented). However, in 284ffab3 the definition of `SomeException(displayException)` was changed to exclude the `ExceptionContext`. This means that `WhileHandling(displayExceptionAnnotation)` fails to describe the provenance of the exception which it captures, greatly limiting its utility. Return the implementation to its originally-specified behavior by implementing `WhileHandling(displayExceptionAnnotation)` in terms of `displayExceptionWithInfo`. Fixes #27456. - - - - - 10 changed files: - + changelog.d/T27456 - libraries/base/changelog.md - libraries/base/tests/T15349.stderr - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/tests/backtraces/T14532b.stdout - testsuite/tests/codeGen/should_run/cgrun025.stderr - testsuite/tests/exceptions/T26759.stderr - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/runghc/T7859.stderr-mingw32 Changes: ===================================== changelog.d/T27456 ===================================== @@ -0,0 +1,8 @@ +section: base +issues: #27456 +mrs: !16275 +synopsis: + Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` +description: + In the past ``displayException`` (in terms of which ``WhileHandling``\'s ``displayExceptionAnnotation` is implemented) was changed to hide ``ExceptionContext``. This regressed the behavior of ``displayExceptionAnnotation`` from that which was originally specified. Restore the intended behavior of showing the ``ExceptionContext`` of the carried exception. + ===================================== libraries/base/changelog.md ===================================== @@ -31,6 +31,7 @@ * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) * Add a new module `System.IO.OS` with operations for obtaining operating-system handles (file descriptors, Windows handles). ([CLC proposal #369](https://github.com/haskell/core-libraries-committee/issues/369)) * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) + * Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) ===================================== libraries/base/tests/T15349.stderr ===================================== @@ -1,9 +1,11 @@ -T15349: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination: +T15349.exe: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.NonTermination: <<loop>> -While handling thread blocked indefinitely in an MVar operation +While handling ghc-internal:GHC.Internal.IO.Exception.BlockedIndefinitelyOnMVar: + | + | thread blocked indefinitely in an MVar operation HasCallStack backtrace: - throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Imp.hs:58:37 in ghc-internal:GHC.Internal.Control.Monad.ST.Imp + throwIO, called at libraries\ghc-internal\src\GHC\Internal\Control\Monad\ST\Imp.hs:59:37 in ghc-internal:GHC.Internal.Control.Monad.ST.Imp ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs ===================================== @@ -84,7 +84,7 @@ data WhileHandling = WhileHandling SomeException deriving Show instance ExceptionAnnotation WhileHandling where displayExceptionAnnotation (WhileHandling e) = - "While handling " ++ case lines $ displayException e of + "While handling " ++ case lines $ displayExceptionWithInfo e of [] -> "" (l1:ls) -> -- Indent lines forward. ===================================== libraries/ghc-internal/tests/backtraces/T14532b.stdout ===================================== @@ -2,7 +2,14 @@ ghc-internal:GHC.Internal.Exception.ErrorCall: Error in Exception Handler -While handling Main Error +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | Main Error + | + | My custom Backtraces: + | HasCallStack backtrace: + | throwIO, called at T14532b.hs:32:6 in main:Main + | My custom Backtraces: HasCallStack backtrace: @@ -13,7 +20,14 @@ ghc-internal:GHC.Internal.Exception.ErrorCall: Error in Exception Handler -While handling Main Error +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | Main Error + | + | My custom Backtraces: + | HasCallStack backtrace: + | error, called at T14532b.hs:41:6 in main:Main + | My custom Backtraces: HasCallStack backtrace: ===================================== testsuite/tests/codeGen/should_run/cgrun025.stderr ===================================== @@ -1,4 +1,4 @@ -"cgrun025" +"cgrun025.exe" ["cgrun025.hs"] GOT PATH {-# LANGUAGE ScopedTypeVariables #-} @@ -27,11 +27,16 @@ main = do trace "hello, trace" $ catch (getEnv "__WURBLE__" >> return ()) (\ (e :: SomeException) -> error "hello, error") hello, trace -cgrun025: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: +cgrun025.exe: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: hello, error -While handling __WURBLE__: getEnv: does not exist (no environment variable) +While handling ghc-internal:GHC.Internal.IO.Exception.IOException: + | + | __WURBLE__: getEnv: does not exist (no environment variable) + | + | HasCallStack backtrace: + | ioException, called at libraries\ghc-internal\src\GHC\Internal\System\Environment.hs:204:26 in ghc-internal:GHC.Internal.System.Environment HasCallStack backtrace: error, called at cgrun025.hs:25:75 in main:Main ===================================== testsuite/tests/exceptions/T26759.stderr ===================================== @@ -1,8 +1,13 @@ -T26759: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: +T26759.exe: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: cleanup failure -While handling outer failure +While handling ghc-internal:GHC.Internal.Exception.ErrorCall: + | + | outer failure + | + | HasCallStack backtrace: + | throwIO, called at T26759.hs:6:21 in main:Main HasCallStack backtrace: throwIO, called at T26759.hs:7:22 in main:Main ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -1,10 +1,12 @@ -<interactive>: Uncaught exception ghc-9.13-inplace:GHC.Utils.Panic.GhcException: +<interactive>: Uncaught exception ghc-10.1-inplace:GHC.Utils.Panic.GhcException: IO error: "Abcde" does not exist -While handling IO error: "Abcde" does not exist +While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: + | + | IO error: "Abcde" does not exist HasCallStack backtrace: - throwIO, called at compiler/GHC/Utils/Error.hs:512:19 in ghc-9.13-inplace:GHC.Utils.Error + throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error 1 ===================================== testsuite/tests/mdo/should_fail/mdofail006.stderr ===================================== @@ -1,9 +1,11 @@ -mdofail006: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.FixIOException: +mdofail006.exe: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.FixIOException: cyclic evaluation in fixIO -While handling thread blocked indefinitely in an MVar operation +While handling ghc-internal:GHC.Internal.IO.Exception.BlockedIndefinitelyOnMVar: + | + | thread blocked indefinitely in an MVar operation HasCallStack backtrace: - throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs:167:37 in ghc-internal:GHC.Internal.Control.Monad.Fix + throwIO, called at libraries\ghc-internal\src\GHC\Internal\Control\Monad\Fix.hs:169:37 in ghc-internal:GHC.Internal.Control.Monad.Fix ===================================== testsuite/tests/runghc/T7859.stderr-mingw32 ===================================== @@ -2,7 +2,12 @@ runghc-9.13.20241015.exe: Uncaught exception ghc-internal:GHC.Internal.IO.Except defer-type-errors: rawSystem: does not exist (No such file or directory) -While handling rawSystem: does not exist (No such file or directory) +While handling ghc-internal:GHC.Internal.IO.Exception.IOException: + | + | rawSystem: does not exist (No such file or directory) + | + | HasCallStack backtrace: + | ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:<line>:<column> in <package-id>:GHC.Internal.Foreign.C.Error HasCallStack backtrace: ioError, called at libraries\process\System\Process\Common.hs:239:16 in process-1.6.25.0-inplace:System.Process.Common View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3680f06085ccc0cb055abca84085e0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3680f06085ccc0cb055abca84085e0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T21394
by Simon Jakobi (＠sjakobi2) 05 Jul '26

05 Jul '26

Simon Jakobi pushed new branch wip/sjakobi/T21394 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T21394 You're receiving this email because of your account on gitlab.haskell.org.

1 0