- ghc-commits - Haskell.org

[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) 06 Jul '26

06 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) 06 Jul '26

06 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) 06 Jul '26

06 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) 06 Jul '26

06 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) 06 Jul '26

06 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

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-5
by Alan Zimmerman (＠alanz) 05 Jul '26

05 Jul '26

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

1 0