- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/rts-fix-missing-untag
by Cheng Shao (＠TerrorJack) 12 Jul '26

12 Jul '26

Cheng Shao pushed new branch wip/rts-fix-missing-untag at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/rts-fix-missing-untag You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/mr16259] Accept remaining compile-time metric increases from enter-taggable enforcement
by Simon Jakobi (＠sjakobi2) 12 Jul '26

12 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC Commits: 02b4fef7 by Simon Jakobi at 2026-07-12T12:53:47+02:00 Accept remaining compile-time metric increases from enter-taggable enforcement Second CI run of !16329 flagged three more compile-time allocation increases beyond T13960: T20049 (+2.0%, right at the window edge, on x86_64 validate jobs) and, on the wasm cross job only, T6048 (+2.2%) and T16577 (+5.7%). These are the emitEnter tag-test cost of the invariant enforcement (#23173); the wasm numbers suggest the cost is higher without TablesNextToCode. The perf driver reads the Metric Increase block from the HEAD commit only, hence this empty commit at the branch tip; it supersedes the earlier one for T13960. ------------------------- Metric Increase: T13960 T16577 T20049 T6048 ------------------------- Assisted-by: Claude Fable 5 - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02b4fef78b45efdf7f1ab7aed62a9ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02b4fef78b45efdf7f1ab7aed62a9ee… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/mr16259] Deleted 1 commit: Accept remaining compile-time metric increases from enter-taggable enforcement
by Simon Jakobi (＠sjakobi2) 12 Jul '26

12 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: 02b4fef7 by Simon Jakobi at 2026-07-12T12:53:47+02:00 Accept remaining compile-time metric increases from enter-taggable enforcement Second CI run of !16329 flagged three more compile-time allocation increases beyond T13960: T20049 (+2.0%, right at the window edge, on x86_64 validate jobs) and, on the wasm cross job only, T6048 (+2.2%) and T16577 (+5.7%). These are the emitEnter tag-test cost of the invariant enforcement (#23173); the wasm numbers suggest the cost is higher without TablesNextToCode. The perf driver reads the Metric Increase block from the HEAD commit only, hence this empty commit at the branch tip; it supersedes the earlier one for T13960. ------------------------- Metric Increase: T13960 T16577 T20049 T6048 ------------------------- Assisted-by: Claude Fable 5 - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02b4fef78b45efdf7f1ab7aed62a9ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02b4fef78b45efdf7f1ab7aed62a9ee… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/mr16259] 2 commits: rts: sanity-check pointer tags at rest (#23173)
by Simon Jakobi (＠sjakobi2) 12 Jul '26

12 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC Commits: 5d8d132f by Simon Jakobi at 2026-07-12T12:53:47+02:00 rts: sanity-check pointer tags at rest (#23173) The enter-taggable invariant is otherwise enforced only by crashing entry code, so a GC path that strips a tag goes unnoticed until something happens to enter the stripped pointer. Add checkPtrTag to the sanity checker (+RTS -DS): every traversed user-level pointer field must carry the tag implied by its target's info table, catching tag-stripping pointer-rewriting paths mechanically on every sanity-checked GC. See Note [Sanity-checking pointer tags] in rts/sm/Sanity.c for the rules and the exemptions. A full-testsuite sweep under the sanity ways flushed out the legitimate untagged producers the exemptions cover: - Stack slots and PAP/AP payloads get relaxed rules (tag 0 accepted): bitmap-walked frames such as the stg_gc_prim_p* heap-check-retry frames save primop pointer arguments that codegen untags at the Cmm call boundary, and hand-written Cmm keeps untagged working pointers live. - C-finalizer nodes are linked untagged into StgWeak.cfinalizers and walked raw by the RTS (exempted via C_FINALIZER_LIST). - ghc-heap's Box wraps pointer words captured verbatim by heap/stack introspection, so its field may hold an untagged constructor pointer; it is recognized via a new Box_con_info entry in the RTS/ghc-internal interface. Verified against the array/compact/nonmoving/MVar/weak/cloneStack tests in the sanity, threaded2_sanity and nonmoving_thr_sanity ways, and negatively by disabling the unthread() tag preservation in rts/sm/Compact.c, which the new check catches on the first compacting collection. Assisted-by: Claude Fable 5 - - - - - 02b4fef7 by Simon Jakobi at 2026-07-12T12:53:47+02:00 Accept remaining compile-time metric increases from enter-taggable enforcement Second CI run of !16329 flagged three more compile-time allocation increases beyond T13960: T20049 (+2.0%, right at the window edge, on x86_64 validate jobs) and, on the wasm cross job only, T6048 (+2.2%) and T16577 (+5.7%). These are the emitEnter tag-test cost of the invariant enforcement (#23173); the wasm numbers suggest the cost is higher without TablesNextToCode. The perf driver reads the Metric Increase block from the HEAD commit only, hence this empty commit at the branch tip; it supersedes the earlier one for T13960. ------------------------- Metric Increase: T13960 T16577 T20049 T6048 ------------------------- Assisted-by: Claude Fable 5 - - - - - 4 changed files: - libraries/ghc-internal/include/RtsIfaceSymbols.h - rts/Prelude.h - rts/include/rts/RtsToHsIface.h - rts/sm/Sanity.c Changes: ===================================== libraries/ghc-internal/include/RtsIfaceSymbols.h ===================================== @@ -59,6 +59,7 @@ CLOSURE(GHCziInternalziExceptionziType, underflowException_closure) CLOSURE(GHCziInternalziExceptionziType, overflowException_closure) INFO_TBL(GHCziInternalziCString, unpackCStringzh_info) INFO_TBL(GHCziInternalziCString, unpackCStringUtf8zh_info) +INFO_TBL(GHCziInternalziHeapziClosures, Box_con_info) #if defined(wasm32_HOST_ARCH) && defined(__PIC__) CLOSURE(GHCziInternalziWasmziPrimziImports, raiseJSException_closure) INFO_TBL(GHCziInternalziWasmziPrimziTypes, JSVal_con_info) ===================================== rts/Prelude.h ===================================== @@ -84,3 +84,4 @@ extern StgClosure ZCMain_main_closure; #define FunPtr_con_info ghc_hs_iface->FunPtr_con_info #define StablePtr_static_info ghc_hs_iface->StablePtr_static_info #define StablePtr_con_info ghc_hs_iface->StablePtr_con_info +#define Box_con_info ghc_hs_iface->Box_con_info ===================================== rts/include/rts/RtsToHsIface.h ===================================== @@ -60,6 +60,7 @@ typedef struct { StgClosure *overflowException_closure; // GHC.Internal.Exception.Type.overflowException_closure const StgInfoTable *unpackCStringzh_info; // GHC.Internal.CString.unpackCStringzh_info const StgInfoTable *unpackCStringUtf8zh_info; // GHC.Internal.CString.unpackCStringUtf8zh_info + const StgInfoTable *Box_con_info; // GHC.Internal.Heap.Closures.Box_con_info #if defined(wasm32_HOST_ARCH) StgClosure *raiseJSException_closure; // GHC.Internal.Wasm.Prim.Imports.raiseJSException_closure const StgInfoTable *JSVal_con_info; // GHC.Internal.Wasm.Prim.Types.JSVal_con_info ===================================== rts/sm/Sanity.c ===================================== @@ -25,6 +25,7 @@ #include "Sanity.h" #include "Schedule.h" #include "Apply.h" +#include "Prelude.h" #include "Printer.h" #include "Arena.h" #include "RetainerProfile.h" @@ -42,6 +43,7 @@ int isHeapAlloced ( StgPtr p); static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t ); static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t ); static void checkClosureShallow ( const StgClosure * ); +static void checkPtrTag ( const StgClosure *, bool ); static void checkCompactObjects (bdescr *bd); @@ -72,6 +74,7 @@ checkSmallBitmap( StgPtr payload, StgWord bitmap, uint32_t size ) for(i = 0; i < size; i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); + checkPtrTag((StgClosure *)payload[i], false); } } } @@ -89,11 +92,126 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size ) for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); + checkPtrTag((StgClosure *)payload[i], false); } } } } +/* Note [Sanity-checking pointer tags] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * checkPtrTag asserts the pointer-tagging invariant (#23173) at rest: a + * pointer to a constructor carries its constructor tag (see tagConstr in + * ClosureMacros.h and get_iptr_tag in sm/Compact.c), and a pointer to a boxed + * unlifted primitive (MVar#, MutVar#, the arrays, ...) carries tag 1 (see + * Note [Pointer tagging of unlifted boxed primitives] in GHC.StgToCmm.Prim). + * The invariant is otherwise enforced only by crashing entry code, which + * catches a stripped tag only if the pointer is subsequently entered; this + * check catches tag-stripping pointer-rewriting paths (Evac, Compact, + * NonMovingShortcut, ...) mechanically on every sanity-checked GC. + * + * It is called only on user-level fields (stack bitmap slots, PAP/AP + * payloads, constructor/fun/thunk payloads, array elements, MutVar/TVar/MVar + * values, IND indirectees), because the RTS also holds internal untagged + * links. The rules exempt: + * + * - static constructors: RTS sentinels (stg_END_TSO_QUEUE_closure, ...) are + * CONSTR_NOCAFs that C code stores untagged, e.g. as an empty MVar's + * value, so only heap-allocated constructors are checked; + * + * - large-family constructors (con_tag >= TAG_MASK): tag is capped at + * TAG_MASK, so no exact requirement is asserted; + * + * - WEAK, TSO, STACK, BLOCKING_QUEUE, PRIM, MUT_PRIM: user-level references + * (Weak#, ThreadId#, ...) to these are tagged, but legitimate untagged + * RTS-internal links (weak_ptr_list, run queues, tso->_link, STM + * structures) reach the same traversals; + * + * - C_FINALIZER_LIST nodes: although their info table is a CONSTR, they + * are RTS-internal. All references to them — StgWeak.cfinalizers and the + * nodes' link fields — are untagged links built by stg_addCFinalizerToWeakzh + * (PrimOps.cmm) and walked raw by runCFinalizers (Weak.c); user code never + * holds a reference to one. (The compacting GC preserves untaggedness: + * unthread re-applies get_iptr_tag only to originally-tagged references.) + * + * - fields of ghc-heap's Box (GHC.Internal.Heap.Closures): `data Box = Box + * Any` wraps a pointer word captured verbatim by heap/stack introspection + * (unpackClosure#, ghc-heap's stack decoding), so it carries whatever tag + * the source bits had — possibly none. Box is recognized via + * ghc_hs_iface->Box_con_info, NULL-guarded since sanity checks can run + * before ghc-internal registers the interface; + * + * - BLACKHOLE indirectees (no call site on that field): tag 0 there means + * "not yet updated". Plain IND indirectees are checked; + * + * - bitmap-walked slots (stack frames, PAP/AP payloads; heap_field = + * false): hand-written Cmm legitimately stores untagged pointers there. + * Codegen untags unlifted boxed primop arguments at the Cmm call + * boundary, and generic RTS frames save those already-untagged arguments + * on the stack (the stg_block_{take,read,put}mvar frames and the + * stg_gc_prim_* heap-check-retry frames in HeapStackCheck.cmm); Cmm code + * also keeps deliberately untagged working pointers live across calls + * (e.g. stg_compactAddWorkerzh's "p"), landing them in return-frame + * slots. Such slots hence get no constructor rule, and the unlifted- + * primitive rule is relaxed to tag 0-or-1 (still catching corrupt tags). + * The strict rules apply to heap fields, where all the tag-stripping GC + * bugs lived. + */ +static void +checkPtrTag( const StgClosure *q, bool heap_field ) +{ + const StgClosure *p = UNTAG_CONST_CLOSURE(q); + const StgInfoTable *raw_info = ACQUIRE_LOAD(&p->header.info); + if (IS_FORWARDING_PTR(raw_info)) return; + const StgInfoTable *info = INFO_PTR_TO_STRUCT(raw_info); + + switch (info->type) { + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_NOCAF: + { + // RTS-internal untagged links; see the C_FINALIZER_LIST bullet in + // Note [Sanity-checking pointer tags]. + if (raw_info == &stg_C_FINALIZER_LIST_info) { + break; + } + StgWord con_tag = (StgWord)info->srt + 1; + if (heap_field && con_tag <= TAG_MASK && HEAP_ALLOCED((StgPtr)p)) { + ASSERT(GET_CLOSURE_TAG(q) == con_tag); + } + break; + } + + case ARR_WORDS: + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN_CLEAN: + case MUT_ARR_PTRS_FROZEN_DIRTY: + case SMALL_MUT_ARR_PTRS_CLEAN: + case SMALL_MUT_ARR_PTRS_DIRTY: + case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: + case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY: + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: + case MVAR_CLEAN: + case MVAR_DIRTY: + case TVAR: + if (heap_field) { + ASSERT(GET_CLOSURE_TAG(q) == 1); + } else { + ASSERT(GET_CLOSURE_TAG(q) <= 1); + } + break; + + default: + break; + } +} + /* * check that it looks like a valid closure - without checking its payload * used to avoid recursion between checking PAPs and checking stack @@ -102,6 +220,8 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size ) static void checkClosureShallow( const StgClosure* p ) { + // No checkPtrTag here: checkCompactObjects calls this on raw + // (necessarily untagged) object addresses, not on stored pointers. ASSERT(LOOKS_LIKE_CLOSURE_PTR(UNTAG_CONST_CLOSURE(p))); } @@ -129,10 +249,12 @@ checkStackFrame( StgPtr c ) case STOP_FRAME: case RET_SMALL: case ANN_FRAME: + { size = BITMAP_SIZE(info->i.layout.bitmap); checkSmallBitmap((StgPtr)c + 1, BITMAP_BITS(info->i.layout.bitmap), size); return 1 + size; + } case RET_BCO: { StgBCO *bco; @@ -377,6 +499,8 @@ checkClosure( const StgClosure* p ) ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value)); + // head/tail are RTS-internal TSO queue links; only value is user-level + checkPtrTag(mvar->value, true); return sizeofW(StgMVar); } @@ -390,6 +514,7 @@ checkClosure( const StgClosure* p ) uint32_t i; for (i = 0; i < info->layout.payload.ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i])); + checkPtrTag(((StgThunk *)p)->payload[i], true); } return thunk_sizeW_fromITBL(info); } @@ -407,14 +532,33 @@ checkClosure( const StgClosure* p ) case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0: - case BLACKHOLE: - case PRIM: - case MUT_PRIM: case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: case TVAR: case THUNK_STATIC: case FUN_STATIC: + { + // ghc-heap's Box holds a raw captured pointer word; see the Box + // bullet in Note [Sanity-checking pointer tags]. + bool box = ghc_hs_iface != NULL + && ACQUIRE_LOAD(&p->header.info) == Box_con_info; + uint32_t i; + for (i = 0; i < info->layout.payload.ptrs; i++) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i])); + if (!box) { + checkPtrTag(p->payload[i], true); + } + } + return sizeW_fromITBL(info); + } + + // As above, but without checkPtrTag: a BLACKHOLE indirectee legitimately + // carries tag 0 ("not yet updated"), and PRIM/MUT_PRIM/COMPACT_NFDATA + // payloads are RTS-internal links. + // See Note [Sanity-checking pointer tags]. + case BLACKHOLE: + case PRIM: + case MUT_PRIM: case COMPACT_NFDATA: { uint32_t i; @@ -480,6 +624,7 @@ checkClosure( const StgClosure* p ) */ StgInd *ind = (StgInd *)p; ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee)); + checkPtrTag(ind->indirectee, true); return sizeofW(StgInd); } @@ -529,6 +674,7 @@ checkClosure( const StgClosure* p ) uint32_t i; for (i = 0; i < a->ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i])); + checkPtrTag(a->payload[i], true); } return mut_arr_ptrs_sizeW(a); } @@ -541,6 +687,7 @@ checkClosure( const StgClosure* p ) StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs *)p; for (uint32_t i = 0; i < a->ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i])); + checkPtrTag(a->payload[i], true); } return small_mut_arr_ptrs_sizeW(a); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5f7e9c08831e92b43e258e81fe79a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5f7e9c08831e92b43e258e81fe79a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/mr16259] rts: sanity-check pointer tags at rest (#23173)
by Simon Jakobi (＠sjakobi2) 12 Jul '26

12 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC Commits: a5f7e9c0 by Simon Jakobi at 2026-07-12T12:40:05+02:00 rts: sanity-check pointer tags at rest (#23173) The enter-taggable invariant is otherwise enforced only by crashing entry code, so a GC path that strips a tag goes unnoticed until something happens to enter the stripped pointer. Add checkPtrTag to the sanity checker (+RTS -DS): every traversed user-level pointer field must carry the tag implied by its target's info table, catching tag-stripping pointer-rewriting paths mechanically on every sanity-checked GC. See Note [Sanity-checking pointer tags] in rts/sm/Sanity.c for the rules and the exemptions. A full-testsuite sweep under the sanity ways flushed out the legitimate untagged producers the exemptions cover: - Stack slots and PAP/AP payloads get relaxed rules (tag 0 accepted): bitmap-walked frames such as the stg_gc_prim_p* heap-check-retry frames save primop pointer arguments that codegen untags at the Cmm call boundary, and hand-written Cmm keeps untagged working pointers live. - C-finalizer nodes are linked untagged into StgWeak.cfinalizers and walked raw by the RTS (exempted via C_FINALIZER_LIST). - ghc-heap's Box wraps pointer words captured verbatim by heap/stack introspection, so its field may hold an untagged constructor pointer; it is recognized via a new Box_con_info entry in the RTS/ghc-internal interface. Verified against the array/compact/nonmoving/MVar/weak/cloneStack tests in the sanity, threaded2_sanity and nonmoving_thr_sanity ways, and negatively by disabling the unthread() tag preservation in rts/sm/Compact.c, which the new check catches on the first compacting collection. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - libraries/ghc-internal/include/RtsIfaceSymbols.h - rts/Prelude.h - rts/include/rts/RtsToHsIface.h - rts/sm/Sanity.c Changes: ===================================== libraries/ghc-internal/include/RtsIfaceSymbols.h ===================================== @@ -59,6 +59,7 @@ CLOSURE(GHCziInternalziExceptionziType, underflowException_closure) CLOSURE(GHCziInternalziExceptionziType, overflowException_closure) INFO_TBL(GHCziInternalziCString, unpackCStringzh_info) INFO_TBL(GHCziInternalziCString, unpackCStringUtf8zh_info) +INFO_TBL(GHCziInternalziHeapziClosures, Box_con_info) #if defined(wasm32_HOST_ARCH) && defined(__PIC__) CLOSURE(GHCziInternalziWasmziPrimziImports, raiseJSException_closure) INFO_TBL(GHCziInternalziWasmziPrimziTypes, JSVal_con_info) ===================================== rts/Prelude.h ===================================== @@ -84,3 +84,4 @@ extern StgClosure ZCMain_main_closure; #define FunPtr_con_info ghc_hs_iface->FunPtr_con_info #define StablePtr_static_info ghc_hs_iface->StablePtr_static_info #define StablePtr_con_info ghc_hs_iface->StablePtr_con_info +#define Box_con_info ghc_hs_iface->Box_con_info ===================================== rts/include/rts/RtsToHsIface.h ===================================== @@ -60,6 +60,7 @@ typedef struct { StgClosure *overflowException_closure; // GHC.Internal.Exception.Type.overflowException_closure const StgInfoTable *unpackCStringzh_info; // GHC.Internal.CString.unpackCStringzh_info const StgInfoTable *unpackCStringUtf8zh_info; // GHC.Internal.CString.unpackCStringUtf8zh_info + const StgInfoTable *Box_con_info; // GHC.Internal.Heap.Closures.Box_con_info #if defined(wasm32_HOST_ARCH) StgClosure *raiseJSException_closure; // GHC.Internal.Wasm.Prim.Imports.raiseJSException_closure const StgInfoTable *JSVal_con_info; // GHC.Internal.Wasm.Prim.Types.JSVal_con_info ===================================== rts/sm/Sanity.c ===================================== @@ -25,6 +25,7 @@ #include "Sanity.h" #include "Schedule.h" #include "Apply.h" +#include "Prelude.h" #include "Printer.h" #include "Arena.h" #include "RetainerProfile.h" @@ -42,6 +43,7 @@ int isHeapAlloced ( StgPtr p); static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t ); static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t ); static void checkClosureShallow ( const StgClosure * ); +static void checkPtrTag ( const StgClosure *, bool ); static void checkCompactObjects (bdescr *bd); @@ -72,6 +74,7 @@ checkSmallBitmap( StgPtr payload, StgWord bitmap, uint32_t size ) for(i = 0; i < size; i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); + checkPtrTag((StgClosure *)payload[i], false); } } } @@ -89,11 +92,126 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size ) for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); + checkPtrTag((StgClosure *)payload[i], false); } } } } +/* Note [Sanity-checking pointer tags] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * checkPtrTag asserts the pointer-tagging invariant (#23173) at rest: a + * pointer to a constructor carries its constructor tag (see tagConstr in + * ClosureMacros.h and get_iptr_tag in sm/Compact.c), and a pointer to a boxed + * unlifted primitive (MVar#, MutVar#, the arrays, ...) carries tag 1 (see + * Note [Pointer tagging of unlifted boxed primitives] in GHC.StgToCmm.Prim). + * The invariant is otherwise enforced only by crashing entry code, which + * catches a stripped tag only if the pointer is subsequently entered; this + * check catches tag-stripping pointer-rewriting paths (Evac, Compact, + * NonMovingShortcut, ...) mechanically on every sanity-checked GC. + * + * It is called only on user-level fields (stack bitmap slots, PAP/AP + * payloads, constructor/fun/thunk payloads, array elements, MutVar/TVar/MVar + * values, IND indirectees), because the RTS also holds internal untagged + * links. The rules exempt: + * + * - static constructors: RTS sentinels (stg_END_TSO_QUEUE_closure, ...) are + * CONSTR_NOCAFs that C code stores untagged, e.g. as an empty MVar's + * value, so only heap-allocated constructors are checked; + * + * - large-family constructors (con_tag >= TAG_MASK): tag is capped at + * TAG_MASK, so no exact requirement is asserted; + * + * - WEAK, TSO, STACK, BLOCKING_QUEUE, PRIM, MUT_PRIM: user-level references + * (Weak#, ThreadId#, ...) to these are tagged, but legitimate untagged + * RTS-internal links (weak_ptr_list, run queues, tso->_link, STM + * structures) reach the same traversals; + * + * - C_FINALIZER_LIST nodes: although their info table is a CONSTR, they + * are RTS-internal. All references to them — StgWeak.cfinalizers and the + * nodes' link fields — are untagged links built by stg_addCFinalizerToWeakzh + * (PrimOps.cmm) and walked raw by runCFinalizers (Weak.c); user code never + * holds a reference to one. (The compacting GC preserves untaggedness: + * unthread re-applies get_iptr_tag only to originally-tagged references.) + * + * - fields of ghc-heap's Box (GHC.Internal.Heap.Closures): `data Box = Box + * Any` wraps a pointer word captured verbatim by heap/stack introspection + * (unpackClosure#, ghc-heap's stack decoding), so it carries whatever tag + * the source bits had — possibly none. Box is recognized via + * ghc_hs_iface->Box_con_info, NULL-guarded since sanity checks can run + * before ghc-internal registers the interface; + * + * - BLACKHOLE indirectees (no call site on that field): tag 0 there means + * "not yet updated". Plain IND indirectees are checked; + * + * - bitmap-walked slots (stack frames, PAP/AP payloads; heap_field = + * false): hand-written Cmm legitimately stores untagged pointers there. + * Codegen untags unlifted boxed primop arguments at the Cmm call + * boundary, and generic RTS frames save those already-untagged arguments + * on the stack (the stg_block_{take,read,put}mvar frames and the + * stg_gc_prim_* heap-check-retry frames in HeapStackCheck.cmm); Cmm code + * also keeps deliberately untagged working pointers live across calls + * (e.g. stg_compactAddWorkerzh's "p"), landing them in return-frame + * slots. Such slots hence get no constructor rule, and the unlifted- + * primitive rule is relaxed to tag 0-or-1 (still catching corrupt tags). + * The strict rules apply to heap fields, where all the tag-stripping GC + * bugs lived. + */ +static void +checkPtrTag( const StgClosure *q, bool heap_field ) +{ + const StgClosure *p = UNTAG_CONST_CLOSURE(q); + const StgInfoTable *raw_info = ACQUIRE_LOAD(&p->header.info); + if (IS_FORWARDING_PTR(raw_info)) return; + const StgInfoTable *info = INFO_PTR_TO_STRUCT(raw_info); + + switch (info->type) { + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_NOCAF: + { + // RTS-internal untagged links; see the C_FINALIZER_LIST bullet in + // Note [Sanity-checking pointer tags]. + if (raw_info == &stg_C_FINALIZER_LIST_info) { + break; + } + StgWord con_tag = (StgWord)info->srt + 1; + if (heap_field && con_tag <= TAG_MASK && HEAP_ALLOCED((StgPtr)p)) { + ASSERT(GET_CLOSURE_TAG(q) == con_tag); + } + break; + } + + case ARR_WORDS: + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN_CLEAN: + case MUT_ARR_PTRS_FROZEN_DIRTY: + case SMALL_MUT_ARR_PTRS_CLEAN: + case SMALL_MUT_ARR_PTRS_DIRTY: + case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: + case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY: + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: + case MVAR_CLEAN: + case MVAR_DIRTY: + case TVAR: + if (heap_field) { + ASSERT(GET_CLOSURE_TAG(q) == 1); + } else { + ASSERT(GET_CLOSURE_TAG(q) <= 1); + } + break; + + default: + break; + } +} + /* * check that it looks like a valid closure - without checking its payload * used to avoid recursion between checking PAPs and checking stack @@ -102,6 +220,8 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size ) static void checkClosureShallow( const StgClosure* p ) { + // No checkPtrTag here: checkCompactObjects calls this on raw + // (necessarily untagged) object addresses, not on stored pointers. ASSERT(LOOKS_LIKE_CLOSURE_PTR(UNTAG_CONST_CLOSURE(p))); } @@ -129,10 +249,12 @@ checkStackFrame( StgPtr c ) case STOP_FRAME: case RET_SMALL: case ANN_FRAME: + { size = BITMAP_SIZE(info->i.layout.bitmap); checkSmallBitmap((StgPtr)c + 1, BITMAP_BITS(info->i.layout.bitmap), size); return 1 + size; + } case RET_BCO: { StgBCO *bco; @@ -377,6 +499,8 @@ checkClosure( const StgClosure* p ) ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value)); + // head/tail are RTS-internal TSO queue links; only value is user-level + checkPtrTag(mvar->value, true); return sizeofW(StgMVar); } @@ -390,6 +514,7 @@ checkClosure( const StgClosure* p ) uint32_t i; for (i = 0; i < info->layout.payload.ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i])); + checkPtrTag(((StgThunk *)p)->payload[i], true); } return thunk_sizeW_fromITBL(info); } @@ -407,14 +532,33 @@ checkClosure( const StgClosure* p ) case CONSTR_1_1: case CONSTR_0_2: case CONSTR_2_0: - case BLACKHOLE: - case PRIM: - case MUT_PRIM: case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: case TVAR: case THUNK_STATIC: case FUN_STATIC: + { + // ghc-heap's Box holds a raw captured pointer word; see the Box + // bullet in Note [Sanity-checking pointer tags]. + bool box = ghc_hs_iface != NULL + && ACQUIRE_LOAD(&p->header.info) == Box_con_info; + uint32_t i; + for (i = 0; i < info->layout.payload.ptrs; i++) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i])); + if (!box) { + checkPtrTag(p->payload[i], true); + } + } + return sizeW_fromITBL(info); + } + + // As above, but without checkPtrTag: a BLACKHOLE indirectee legitimately + // carries tag 0 ("not yet updated"), and PRIM/MUT_PRIM/COMPACT_NFDATA + // payloads are RTS-internal links. + // See Note [Sanity-checking pointer tags]. + case BLACKHOLE: + case PRIM: + case MUT_PRIM: case COMPACT_NFDATA: { uint32_t i; @@ -480,6 +624,7 @@ checkClosure( const StgClosure* p ) */ StgInd *ind = (StgInd *)p; ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee)); + checkPtrTag(ind->indirectee, true); return sizeofW(StgInd); } @@ -529,6 +674,7 @@ checkClosure( const StgClosure* p ) uint32_t i; for (i = 0; i < a->ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i])); + checkPtrTag(a->payload[i], true); } return mut_arr_ptrs_sizeW(a); } @@ -541,6 +687,7 @@ checkClosure( const StgClosure* p ) StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs *)p; for (uint32_t i = 0; i < a->ptrs; i++) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i])); + checkPtrTag(a->payload[i], true); } return small_mut_arr_ptrs_sizeW(a); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a5f7e9c08831e92b43e258e81fe79a6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a5f7e9c08831e92b43e258e81fe79a6… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: driver: enable -finter-module-far-jumps by default
by Marge Bot (＠marge-bot) 12 Jul '26

12 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 57c0f32c by mangoiv at 2026-07-10T11:08:38-04:00 driver: enable -finter-module-far-jumps by default this fixes a compatibility bug with certain binutils/gcc versions where we were seeing jump offset overflow errors. This commit can probably reverted if we stop supporting the problematic binutils/gcc verions (2.44 and 14.2, respectively) Reolves #26994 - - - - - 4396a6f2 by Andrea Vezzosi at 2026-07-10T11:09:25-04:00 [Fix #27287] preserve ModBreaks in ModIface - - - - - cd00cfa6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - df14fb58 by Andreas Klebinger at 2026-07-12T05:40:46-04:00 Bump nofib submodule to account for MonoLocalBinds. New versions of GHC enable MonoLocalBinds by default. This breaks some of the benchmarks. I've fixed this and this bump pulls in that fix. - - - - - 50 changed files: - + changelog.d/inter-module-far-jumps-aarch64-default - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Breakpoints.hs - + compiler/GHC/HsToCore/Breakpoints/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Platform/Ways.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - compiler/GHC/Utils/Binary.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - docs/users_guide/using-optimisation.rst - ghc/GHCi/UI.hs - nofib - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/ghci/should_run/Makefile - + testsuite/tests/ghci/should_run/T27287.hs - + testsuite/tests/ghci/should_run/T27287.stdout - testsuite/tests/ghci/should_run/all.T - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa3783c626266f566efda8fe6d3bdd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa3783c626266f566efda8fe6d3bdd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/az/epa-tidy-locatedxxx-7] EPA: Keep binds and sigs together in HsValBindsLR
by Alan Zimmerman (＠alanz) 12 Jul '26

12 Jul '26

Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-7 at Glasgow Haskell Compiler / GHC Commits: cd00cfa6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 25 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -78,7 +78,7 @@ type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen -- --------------------------------------------------------------------- -type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL @@ -154,6 +154,10 @@ data AnnPSB instance NoAnn AnnPSB where noAnn = AnnPSB noAnn noAnn noAnn noAnn +instance HasLoc (ValBind (GhcPass p) (GhcPass p)) where + getHasLoc (VbBind b) = getHasLoc b + getHasLoc (VbSig s) = getHasLoc s + -- --------------------------------------------------------------------- -- | Typechecked, generalised bindings, used in the output to the type checker. @@ -442,8 +446,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr) instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where - ppr (ValBinds _ binds sigs) - = pprDeclList (pprLHsBindsForUser binds sigs) + ppr (ValBinds _ binds) + = pprDeclList (pprLHsBindsForUser' binds) ppr (XValBindsLR (HsVBG bs sigs)) = getPprDebug $ \case @@ -487,6 +491,21 @@ pprLHsBindsForUser binds sigs sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls +pprLHsBindsForUser' :: (OutputableBndrId idL, OutputableBndrId idR) + => [ValBind (GhcPass idL) (GhcPass idR)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser' binds + = map ppr_bind binds + where + ppr_bind (VbBind b) = ppr b + ppr_bind (VbSig s) = ppr s + + pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations -- One could choose { d1; d2; ... }, using 'sep' @@ -507,11 +526,11 @@ eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBinds _ binds) = null binds isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds NoAnnSortKey [] [] +emptyValBindsIn = ValBinds noExtField [] emptyValBindsRn :: HsValBindsLR GhcRn GhcRn emptyValBindsRn = XValBindsLR (HsVBG [] []) @@ -532,8 +551,8 @@ hsValBindGroupsBinds binds ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBinds _ ds1) (ValBinds _ ds2) + = ValBinds noExtField (ds1 ++ ds2) plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2)) = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2)) plusHsValBinds _ _ ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -73,6 +73,11 @@ deriving instance Data (HsValBindsLR GhcPs GhcRn) deriving instance Data (HsValBindsLR GhcRn GhcRn) deriving instance Data (HsValBindsLR GhcTc GhcTc) +deriving instance Data (ValBind GhcPs GhcPs) +deriving instance Data (ValBind GhcPs GhcRn) +deriving instance Data (ValBind GhcRn GhcRn) +deriving instance Data (ValBind GhcTc GhcTc) + -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) deriving instance Data (HsValBindGroups 'Parsed) deriving instance Data (HsValBindGroups 'Renamed) ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -84,8 +84,8 @@ module GHC.Hs.Utils( -- * Collecting binders isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind, - collectLocalBinders, collectHsValBinders, collectHsBindListBinders, - collectHsIdBinders, + collectLocalBinders, collectHsValBinders, collectHsValBinders', collectHsBindListBinders, + collectHsIdBinders, collectHsIdBinders', collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, @@ -885,8 +885,11 @@ spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) = get_bind_spans bs [] -spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = get_bind_spans bs sigs +spanHsLocaLBinds (HsValBinds _ (ValBinds _ binds)) + = get_bind_spans bs ss + where + bs :: [LHsBindLR (GhcPass p) (GhcPass p)] + (bs,ss) = val_binds_and_sigs binds spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss))) = get_bind_spans (hsValBindGroupsBinds @p bs) ss @@ -1085,12 +1088,25 @@ collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL)) -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders flag = collect_hs_val_binders True flag +collectHsIdBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively +collectHsIdBinders' flag = collect_hs_val_binders' True flag + collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collectHsValBinders flag = collect_hs_val_binders False flag +collectHsValBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collectHsValBinders' flag = collect_hs_val_binders' False flag + collectHsBindBinders :: CollectPass p => CollectFlag p -> HsBindLR p idR @@ -1117,9 +1133,17 @@ collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case - ValBinds _ binds _ -> collect_binds ps flag binds [] + ValBinds _ binds -> collect_binds ps flag (val_binds binds) [] XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) [] +collect_hs_val_binders' :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL)) + => Bool + -> CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collect_hs_val_binders' ps flag binds = collect_binds ps flag binds [] + + collect_binds :: forall p idR. CollectPass p => Bool -> CollectFlag p @@ -1528,7 +1552,7 @@ hsForeignDeclsBinders foreign_decls hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBinds _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (HsVBG grps _)) = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps @@ -1814,8 +1838,8 @@ hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (HsVBG grps _)) = lhsBindsImplicits (hsValBindGroupsBinds grps) -hsValBindsImplicits (ValBinds _ binds _) - = lhsBindsImplicits binds +hsValBindsImplicits (ValBinds _ binds) + = lhsBindsImplicits (val_binds binds) lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] lhsBindsImplicits = concatMap (lhs_bind . unLoc) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -338,8 +338,8 @@ hsScopedTvBinders binds = concatMap get_scoped_tvs sigs where sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (HsVBG _ sigs) -> sigs + ValBinds _ bs -> val_sigs bs + XValBindsLR (HsVBG _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] get_scoped_tvs (L _ signature) @@ -2004,7 +2004,7 @@ rep_val_binds (XValBindsLR (HsVBG binds sigs)) = do { core1 <- rep_binds (concatMap snd binds) ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) +rep_val_binds (ValBinds _ _) = panic "rep_val_binds: ValBinds" rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1438,7 +1438,7 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where collectFldBinds HsIPBinds{} = emptyVarEnv collectFldBinds EmptyLocalBinds{} = emptyVarEnv instance CollectFldBinders (HsValBinds GhcTc) where - collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (ValBinds _ bnds) = collectFldBinds (val_binds bnds) collectFldBinds (XValBindsLR (HsVBG grps _)) = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps) instance CollectFldBinders (HsBind GhcTc) where ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1462,13 +1462,11 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where ] scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope -scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = foldr combineScopes NoScope (bsScope ++ sigsScope) +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs)) + = foldr combineScopes NoScope bsScope where bsScope :: [Scope] - bsScope = map (mkScope . getLoc) bs - sigsScope :: [Scope] - sigsScope = map (mkScope . getLocA) sigs + bsScope = map (mkScope . getHasLoc) bs scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs))) = foldr combineScopes NoScope (bsScope ++ sigsScope) where @@ -1491,7 +1489,9 @@ instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> + ValBinds _ binds_and_sigs -> + let (binds, sigs) = val_binds_and_sigs binds_and_sigs + in [ toHie $ fmap (BC RegularBind sc) binds , toHie $ fmap (SC (SI BindSig Nothing)) sigs ] ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -41,7 +41,7 @@ module GHC.Parser.Annotation ( NameAnn(..), NameAdornment(..), NoEpAnns(..), - AnnSortKey(..), DeclTag(..), BindTag(..), + AnnSortKey(..), DeclTag(..), -- ** Trailing annotations in lists TrailingAnn(..), ta_location, @@ -652,13 +652,6 @@ data AnnSortKey tag | AnnSortKey [tag] deriving (Data, Eq) --- | Used to track of interleaving of binds and signatures for ValBind -data BindTag - -- See Note [AnnSortKey] below - = BindTag - | SigDTag - deriving (Eq,Data,Ord,Show) - -- | Used to track interleaving of class methods, class signatures, -- associated types and associate type defaults in `ClassDecl` and -- `ClsInstDecl`. @@ -1179,9 +1172,6 @@ instance Outputable EpAnnComments where instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where getName (L l a) = getName (L (locA l) a) -instance Outputable BindTag where - ppr tag = text $ show tag - instance Outputable DeclTag where ppr tag = text $ show tag ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Parser.PostProcess ( addModifiersToDecl, cvBindGroup, + cvBindsAndSigsOnly, wrapValBind, cvBindsAndSigs, cvTopDecls, placeHolderPunRhs, @@ -521,10 +522,28 @@ cvTopDecls decls = getMonoBindAll (fromOL decls) -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts - , dfam_insts, _) <- cvBindsAndSigs binding - ; massert (null fam_ds && null tfam_insts && null dfam_insts) - ; return $ ValBinds NoAnnSortKey mbs sigs } + = do { binds <- cvBindsAndSigsOnly binding + ; return $ ValBinds noExtField binds } + +cvBindsAndSigsOnly :: OrdList (LHsDecl GhcPs) + -> P [ValBind GhcPs GhcPs] +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigsOnly fb = do + fb' <- drop_bad_decls (fromOL fb) + return (fmap wrapValBind (getMonoBindAll fb')) + where + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +wrapValBind :: LHsDecl (GhcPass p) -> ValBind (GhcPass p) (GhcPass p) +wrapValBind (L l (ValD _ b)) = VbBind (L l b) +wrapValBind (L l (SigD _ s)) = VbSig (L l s) +wrapValBind _ = panic "wrapValBind: got unexpected decl" cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -195,21 +195,18 @@ it expects the global environment to contain bindings for the binders -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -- Ensure that a hs-boot file has no top-level bindings. rnTopBindsLHSBoot :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHSBoot fix_env binds - = do { topBinds <- rnTopBindsLHS fix_env binds - ; case topBinds of - ValBinds x mbinds sigs -> - do { rejectBootDecls HsBoot BootBindsPs mbinds - ; pure (ValBinds x [] sigs) } - _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } + = do { (mbinds, sigs) <- rnTopBindsLHS fix_env binds + ; rejectBootDecls HsBoot BootBindsPs mbinds + ; pure ([], sigs) } rejectBootDecls :: HsBootOrSig -> (NonEmpty (LocatedA decl) -> BadBootDecls) @@ -225,8 +222,8 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ _ sigs) - = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs +rnTopBindsBoot bound_names (ValBinds _ val_binds) + = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) (val_sigs val_binds) ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -278,9 +275,9 @@ rnIPBind (IPBind _ n expr) = do -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM ([Name], HsValBindsLR GhcRn GhcPs) + -> RnM ([Name], ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])) rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + = do { (binds',sigs) <- rnValBindsLHS (localRecNameMaker fix_env) binds -- Check for duplicates and shadowing -- Must do this *after* renaming the patterns @@ -300,26 +297,27 @@ rnLocalValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; let bound_names = collectHsValBinders CollNoDictBinders binds' + ; let bound_names = collectHsValBinders' CollNoDictBinders binds' -- There should be only Ids, but if there are any bogus -- pattern synonyms, we'll collect them anyway, so that -- we don't generate subsequent out-of-scope messages ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names - ; return (bound_names, binds') } + ; return (bound_names, (binds', sigs)) } -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHS :: NameMaker -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) +rnValBindsLHS topP (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds + ; return (mbinds', sigs) } where - bndrs = collectHsBindsBinders CollNoDictBinders mbinds + bndrs = collectHsBindsBinders CollNoDictBinders (val_binds vbinds) doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -332,8 +330,9 @@ rnValBindsRHS :: HsSigCtxt -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs +rnValBindsRHS ctxt (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; (sigs', sig_fvs) <- renameSigs ctxt sigs -- Update the TcGblEnv with renamed COMPLETE pragmas from the current -- module, for pattern irrefutability checking in do notation. @@ -383,20 +382,22 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeNames -> RnM (result, FreeNames)) -> RnM (result, FreeNames) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [ L loc sig +rnLocalValBindsAndThen binds@(ValBinds _ vbinds) thing_inside + = do { let sigs = val_sigs vbinds + -- (A) Create the local fixity environment + ; new_fixities <- makeMiniFixityEnv [ L loc sig | L loc (FixSig _ sig) <- sigs] -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + ; (bound_names, (binds',sigs')) <- rnLocalValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + let new_lhs :: HsValBindsLR GhcRn GhcPs = ValBinds noExtField (map VbBind binds' ++ map VbSig sigs') + ; (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' (allUses dus) -- Report unused bindings based on the (accurate) ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -1546,10 +1546,10 @@ rnRecStmtsAndThen ctxt rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ bs)))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc - _ -> acc) acc sigs + _ -> acc) acc (val_sigs bs) _ -> acc) [] l -- left-hand sides @@ -1578,8 +1578,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noAnn (HsValBinds x binds')), + = do (_bound_names, (bs',sigs')) <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noAnn (HsValBinds x (makeRnValBinds noExtField bs' sigs'))), -- Warning: this is bogus; see function invariant emptyFNs )] ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -32,7 +32,8 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNames, bindLocalNamesFV , warnUnusedTypePatterns , noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars ) + , addNoNestedForallsContextsErr, checkInferredVars + , makeRnValBinds) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names @@ -148,12 +149,12 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- We need to throw an error on such value bindings when in a boot file. is_boot <- tcIsHsBootOrSig ; - new_lhs <- if is_boot + (binds', sigs') <- if is_boot then rnTopBindsLHSBoot local_fix_env val_decls else rnTopBindsLHS local_fix_env val_decls ; -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + let { id_bndrs = collectHsIdBinders' CollNoDictBinders binds' } ; -- Excludes pattern-synonym binders -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; @@ -178,6 +179,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn "Start rnmono" empty ; let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + let { new_lhs = makeRnValBinds noExtField binds' sigs' } ; (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot -- For an hs-boot, use tc_bndrs (which collects how we're renamed -- signatures), since val_bndr_set is empty (there are no x = ... @@ -2723,7 +2725,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { where new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps (ValBinds _ binds) = foldrM new_ps' [] (val_binds binds) new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2921,9 +2923,9 @@ add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) = tycls { group_kisigs = d : kisigs } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs +add_bind b (ValBinds x bs) = ValBinds x (bs ++ [VbBind b]) add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig s (ValBinds x bs) = ValBinds x (VbSig s:bs) add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -819,11 +819,11 @@ getLocalNonValBinders fixity_env ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = case binds of - ValBinds _ _val_binds val_sigs -> + ValBinds _ val_binds -> -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ _ ns _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig _ _ ns _) <- (val_sigs val_binds), n <- ns] _ -> panic "Non-ValBinds in hs-boot group" | otherwise = for_hs_bndrs ; val_gres <- mapM new_simple val_bndrs ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -35,7 +35,9 @@ module GHC.Rename.Utils ( addNameClashErrRn, mkNameClashErr, checkInferredVars, - noNestedForallsContextsErr, addNoNestedForallsContextsErr + noNestedForallsContextsErr, addNoNestedForallsContextsErr, + + makeRnValBinds ) where @@ -868,3 +870,9 @@ mkExpandedTc -> LHsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc' mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e)) + +makeRnValBinds :: XValBinds idL idR + -> [XRec idL (HsBindLR idL idR)] + -> [XRec idR (Sig idR)] + -> HsValBindsLR idL idR +makeRnValBinds x binds sigs = ValBinds x (map VbBind binds ++ map VbSig sigs) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1261,8 +1261,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do loc' = locA loc expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc' let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $ - ValBinds NoAnnSortKey - [mkHsVarBind loc' (getRdrName expr_name) expr] [] + ValBinds noExtField + [VbBind $ mkHsVarBind loc' (getRdrName expr_name) expr] pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt let (hvals_io, fix_env) = case pstmt of ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -296,13 +296,13 @@ renameDeriv inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; let (aux_binds, aux_sigs) = unzipBag bagBinds - aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs) + aux_val_binds = ValBinds noExtField (map VbBind (bagToList aux_binds) ++ map VbSig (bagToList aux_sigs)) -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename -- auxiliary bindings as if they were defined locally. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. - ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds + ; (bndrs, (binds', sigs')) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds ; bindLocalNames bndrs $ - do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) (makeRnValBinds noExtField binds' sigs') ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos ; return (listToBag rn_inst_infos, rn_aux, dus_aux `plusDU` usesOnly (plusFNs fvs_insts)) } } ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1052,17 +1052,21 @@ cvtLocalDecs declDescr ds ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds - let (binds, prob_sigs) = partitionWith is_bind ds' - let (sigs, bads) = partitionWith is_sig prob_sigs + let (binds, bads) = partitionWith is_valbind ds' for_ (nonEmpty bads) $ \ bad_decls -> failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) - return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs)) + return (HsValBinds noAnn (ValBinds noExtField binds)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> failWith ImplicitParamsWithOtherBinds +is_valbind :: LHsDecl (GhcPass p) -> Either (ValBind (GhcPass p) (GhcPass p)) (LHsDecl (GhcPass p)) +is_valbind (L l (Hs.ValD _ b)) = Left (VbBind (L l b)) +is_valbind (L l (Hs.SigD _ s)) = Left (VbSig (L l s)) +is_valbind d = Right d + cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -31,6 +31,7 @@ import Language.Haskell.Syntax.ImpExp (NamespaceSpecifier) import Data.Bool import Data.Maybe +import Data.List {- ************************************************************************ @@ -96,7 +97,7 @@ data HsValBindsLR idL idR -- Recursive by default ValBinds (XValBinds idL idR) - (LHsBindsLR idL idR) [LSig idR] + [ValBind idL idR] -- | Value Bindings Out -- @@ -105,6 +106,10 @@ data HsValBindsLR idL idR | XValBindsLR !(XXValBindsLR idL idR) +data ValBind idL idR + = VbBind (LHsBindLR idL idR) + | VbSig (LSig idR) + -- --------------------------------------------------------------------- -- | Located Haskell Binding @@ -243,6 +248,26 @@ data PatSynBind idL idR } | XPatSynBind !(XXPatSynBind idL idR) + +val_binds :: [ValBind idL idR] -> [LHsBindLR idL idR] +val_binds binds = concatMap get_bind binds + where + get_bind (VbBind b) = [b] + get_bind (VbSig _) = [] + +val_sigs :: [ValBind idL idR] -> [LSig idR] +val_sigs binds = concatMap get_sig binds + where + get_sig (VbBind _) = [] + get_sig (VbSig s) = [s] + +val_binds_and_sigs :: [ValBind idL idR] -> ([LHsBindLR idL idR], [LSig idR]) +val_binds_and_sigs binds = go binds [] [] + where + go [] bs ss = (reverse bs, reverse ss) + go ((VbBind b):ds) bs ss = go ds (b:bs) ss + go ((VbSig s):ds) bs ss = go ds bs (s:ss) + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -205,6 +205,7 @@ type family XXHsLocalBindsLR x x' -- HsValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' +type family XXValBinds x x' -- HsBindLR type families type family XFunBind x x' ===================================== ghc/GHCi/UI.hs ===================================== @@ -1633,7 +1633,7 @@ runStmt input step = do let la = L (noAnnSrcSpan loc) la' = L (noAnnSrcSpan loc) - in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey [la' bind] []))) + in la (LetStmt noAnn (HsValBinds noAnn (ValBinds noExtField [VbBind $ la' bind]))) setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1915,220 +1915,221 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:22 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:23 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:22 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:23 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: y})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:20-21 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: y})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:20-21 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:20 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:21 }) - [] + (EpaSpan { DumpSemis.hs:34:20-21 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:20 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:21 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 2) - (False) - (2)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))])))) - ,(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:27 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:28 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:29 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:30 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 2) + (False) + (2)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))]))))) + ,(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:27 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:28 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:29 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:30 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: z})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:25-26 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: z})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:25-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:25 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:26 }) - [] + (EpaSpan { DumpSemis.hs:34:25-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:25 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:26 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 3) - (False) - (3)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 3) + (False) + (3)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])) (L (EpAnn (EpaSpan { DumpSemis.hs:34:35 }) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -166,8 +166,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -295,142 +294,142 @@ "-- comment2") { Test20297.hs:10:3-7 }))])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.hs:11:17-26 }) - (NoEpAnns) + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.hs:11:17-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.hs:11:17 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.hs:11:19-26 }) - [] + (EpaSpan { Test20297.hs:11:17-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.hs:11:17 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.hs:11:19-26 }) [] - (EpaSpan { Test20297.hs:11:19-20 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.hs:11:19-20 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) @@ -595,8 +594,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -712,141 +710,141 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (NoEpAnns) + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.ppr.hs:9:15 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.ppr.hs:9:17-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:15-24 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.ppr.hs:9:15 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:17-24 }) [] - (EpaSpan { Test20297.ppr.hs:9:17-18 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.ppr.hs:9:17-18 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2523,15 +2523,18 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (ValBinds sortKey binds sigs) = do - decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) - let - binds' = concatMap decl2Bind decls - sigs' = concatMap decl2Sig decls - sortKey' = captureOrderBinds decls - return (ValBinds sortKey' binds' sigs') + exact (ValBinds sortKey bs) = do + bs' <- mapM markAnnotated bs + return (ValBinds sortKey bs') exact (XValBindsLR _) = panic "XValBindsLR" +instance ExactPrint (ValBind GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (VbBind b) = VbBind <$> markAnnotated b + exact (VbSig s) = VbSig <$> markAnnotated s + undynamic :: Typeable a => [Dynamic] -> [a] undynamic ds = mapMaybe fromDynamic ds ===================================== utils/check-exact/Main.hs ===================================== @@ -11,9 +11,11 @@ import Data.Data import Data.List (intercalate) +-- import Language.Haskell.Syntax.Binds import GHC hiding (moduleName) import GHC.Driver.Ppr import GHC.Hs.Dump +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Utils.Error @@ -447,15 +449,15 @@ changeLetIn1 _libdir parsed replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (tkLet, _) localDecls expr) = - let (HsValBinds x (ValBinds xv decls sigs)) = localDecls - [l2,_l1] = map wrapDecl decls - decls' = concatMap decl2Bind [l2] + let (HsValBinds x (ValBinds xv bs)) = localDecls + [l2,_l1] = bs + decls' = [l2] (L _ e) = expr a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments expr' = L a e tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) []) in (HsLet (tkLet, tkIn') - (HsValBinds x (ValBinds xv decls' sigs)) expr') + (HsValBinds x (ValBinds xv decls')) expr') replace x = x @@ -508,27 +510,24 @@ changeAddDecl3 libdir top = do -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls libdir (L l p) = do - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 0) let (p',_,_w) = runTransform doAddLocal doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) - replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do - let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs - let decls = s:d:oldDecls + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ bs))))) = do + let (oldDecls) = map unWrapValBind bs + -- let decls = s:d:oldDecls let oldDecls' = captureLineSpacing oldDecls - let oldBinds = concatMap decl2Bind oldDecls' - (os:oldSigs) = concatMap decl2Sig oldDecls' - os' = setEntryDP os (DifferentLine 2 0) - let sortKey = captureOrderBinds decls + let (VbSig o:oldBinds) = map wrapValBind oldDecls' + o' = setEntryDP o (DifferentLine 2 0) let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs) let binds' = (HsValBinds van' - (ValBinds sortKey (decl':oldBinds) - (sig':os':oldSigs))) + (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) `debug` ("oldDecls=" ++ showAst oldDecls) replaceLocalBinds x = return x @@ -540,8 +539,8 @@ changeLocalDecls libdir (L l p) = do -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer changeLocalDecls2 libdir (L l p) = do - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 2) let (p',_,_w) = runTransform doAddLocal @@ -557,10 +556,8 @@ changeLocalDecls2 libdir (L l p) = do (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) []) emptyComments - let decls = [s,d] - let sortKey = captureOrderBinds decls - let binds = (HsValBinds an (ValBinds sortKey [decl'] - [sig'])) + let decls = [VbSig sig', VbBind decl'] + let binds = (HsValBinds an (ValBinds noExtField decls)) return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x return (L l p') ===================================== utils/check-exact/Transform.hs ===================================== @@ -68,7 +68,6 @@ module Transform , addModuleCommentOrigDeltas -- ** Managing lists, pure functions - , captureOrderBinds , captureLineSpacing , captureMatchLineSpacing , captureTypeSigSpacing @@ -92,6 +91,7 @@ import Control.Monad.RWS import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString import GHC.Types.SrcLoc @@ -507,7 +507,7 @@ pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) vb = case replaceDeclsValbinds w lb (reverse decls') of (HsValBinds _ vb') -> vb' - _ -> ValBinds NoAnnSortKey [] [] + _ -> ValBinds noExtField [] balanceCommentsListA :: [LocatedA a] -> [LocatedA a] @@ -1084,18 +1084,11 @@ replaceDeclsValbinds w b@(HsValBinds a _) new = let oldSpan = spanHsLocaLBinds b an = oldWhereAnnotation a w (realSrcSpan oldSpan) - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" replaceDeclsValbinds w (EmptyLocalBinds _) new - = let - an = newWhereAnnotation w - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + = let an = newWhereAnnotation w + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) ===================================== utils/check-exact/Utils.hs ===================================== @@ -65,15 +65,6 @@ warn c _ = c -- --------------------------------------------------------------------- -captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag -captureOrderBinds ls = AnnSortKey $ map go ls - where - go (L _ (ValD _ _)) = BindTag - go (L _ (SigD _ _)) = SigDTag - go d = error $ "captureOrderBinds:" ++ showGhc d - --- --------------------------------------------------------------------- - notDocDecl :: LHsDecl GhcPs -> Bool notDocDecl (L _ DocD{}) = False notDocDecl _ = True @@ -655,45 +646,27 @@ partitionWithSortKey = go -- --------------------------------------------------------------------- -orderedDeclsBinds - :: AnnSortKey BindTag - -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] - -> [LHsDecl GhcPs] -orderedDeclsBinds sortKey binds sigs = - case sortKey of - NoAnnSortKey -> - sortBy (\a b -> compare (realSrcSpan $ getLocA a) - (realSrcSpan $ getLocA b)) (binds ++ sigs) - AnnSortKey keys -> - let - go [] _ _ = [] - go (BindTag:ks) (b:bs) ss = b : go ks bs ss - go (SigDTag:ks) bs (s:ss) = s : go ks bs ss - go (_:ks) bs ss = go ks bs ss - in - go keys binds sigs - hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs] hsDeclsLocalBinds lb = case lb of - HsValBinds _ (ValBinds sortKey bs sigs) -> - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds + HsValBinds _ (ValBinds _ bs) -> map unWrapValBind bs HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" HsIPBinds {} -> [] EmptyLocalBinds {} -> [] hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs] -hsDeclsValBinds (ValBinds sortKey bs sigs) = - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds +hsDeclsValBinds (ValBinds _ bs) = map unWrapValBind bs hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds" +unWrapValBind :: ValBind (GhcPass p) (GhcPass p) -> LHsDecl (GhcPass p) +unWrapValBind (VbBind (L l b)) = L l (ValD noExtField b) +unWrapValBind (VbSig (L l s)) = L l (SigD noExtField s) + +sig2Decl :: LSig (GhcPass p) -> LHsDecl (GhcPass p) +sig2Decl (L l s) = L l (SigD noExtField s) + +bind2Decl :: LHsBind (GhcPass p) -> LHsDecl (GhcPass p) +bind2Decl (L l b) = L l (ValD noExtField b) + -- --------------------------------------------------------------------- -- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00cfa6f8de2b7af756cd12f5f2cb7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00cfa6f8de2b7af756cd12f5f2cb7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 17 commits: EPA: Keep binds and sigs together in HsValBindsLR
by Alan Zimmerman (＠alanz) 12 Jul '26

12 Jul '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: cd00cfa6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - bdcf06e8 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 Keep decls together in ClassDecl - - - - - 7edc40af by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: ClsInstDecl as list in GhcPs - - - - - 5332f9e9 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedP from OverlapMode - - - - - 8d2cce09 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedP from CType - - - - - 7fc7704e by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedP, last use in WarningTxt - - - - - 95f4865f by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedE from WarningCategory - - - - - dc64cf1b by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocateE from XCImport and XCExport - - - - - ec93f36a by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedE from HsRecFields dot - - - - - 2ab825e0 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedE completely, last usage for pats - - - - - 396c0dc9 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove AnnList (EpToken "where") usages This is moving toward removing the parameter from AnnList completely - - - - - 81b0dca9 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA remove AnnList (EpToken "rec") usages - - - - - 42dd18b8 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove last parameterised AnnList usage (EpaLocation) Also remove the parameter - - - - - a8d9e812 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 TTG: Add extension points to BooleanFormula They are currently unused, but will be used for exact print annotations next - - - - - cd1074e6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Remove LocatedBC / SrcSpanBF - - - - - 3e34e3f9 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: remove unused addTrailingAnnToL. Squash appropriately - - - - - 9d7f690d by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPS: Remove NoEpTok/NoEpUniTok, using an unhelpful SrcSpan instead Also introduce helper functions noEpTok and noEpUniTok to serve as simple replacements in code inserting an token annotation without location information. - - - - - 86 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Core/Class.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Stats.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/BooleanFormula.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/haddock_examples/haddock.Test.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.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/T14189.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.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/a0cea896c52c385051f0194441fa87… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0cea896c52c385051f0194441fa87… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/metrics-changes] ci: flingus flongus
by Magnus (＠MangoIV) 12 Jul '26

12 Jul '26

Magnus pushed to branch wip/mangoiv/metrics-changes at Glasgow Haskell Compiler / GHC Commits: 6c961d5f by mangoiv at 2026-07-12T10:34:20+02:00 ci: flingus flongus Metrics Decrease (test_env="aarch64-linux-deb13-validate"): LinkableUsage02 Metrics Decrease (test_env="i386-linux-alpine3_23-validate"): T24471 Resolves #27489 - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c961d5f3ff02920f966b411341e9a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c961d5f3ff02920f966b411341e9a4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/metrics-changes] ci: bingus bongus
by Magnus (＠MangoIV) 12 Jul '26

12 Jul '26

Magnus pushed to branch wip/mangoiv/metrics-changes at Glasgow Haskell Compiler / GHC Commits: 7574811c by mangoiv at 2026-07-12T10:24:13+02:00 ci: bingus bongus Metrics Decrease (test_env="aarch64-linux-deb13-validate"): LinkableUsage02 Metrics Decrease (test_env="i386-linux-alpine3_23-validate"): T24471 Resolves #27489 - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7574811c718b4e3eb35796d403cde27… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7574811c718b4e3eb35796d403cde27… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0