Sebastian Graf pushed to branch wip/sg/enter-taggable-invariant at Glasgow Haskell Compiler / GHC Commits: ad5b71c3 by Sebastian Graf at 2026-07-31T15:55:27+02:00 rts: tag boxed unlifted primitives handed to Haskell Producers hand tagged pointers to Haskell: stg_listThreadszh and stg_threadLabelzh return their Array#/ByteArray# with tag 1, listThreads tags the ThreadId# array elements, scheduleFinalizers tags the finalizer batch Array#, and the allocation limit handler receives the offending TSO as a tagged ThreadId#. C consumers strip the tag from unlifted values they dereference: the MVar#s obtained through StablePtrs in hs_try_putmvar_with_value, the scheduler inbox and sendCloneStackMessage, and the ThreadId# key of the main thread's Weak#. The GC preserves the tag: evacuate copies primitive closures with copy_tag, copyPart carries the reference's tag, mark-compact restores tag 1 for primitive closure types, and compact region append stores tagged pointers. - - - - - 76ca53df by Sebastian Graf at 2026-07-31T15:55:35+02:00 testsuite: T21305: return the MutableByteArray# with its pointer tag A 'foreign import prim' callee returns unlifted boxed results tagged, following the convention of the out-of-line primops in rts/PrimOps.cmm. - - - - - e74ed796 by Sebastian Graf at 2026-07-31T15:55:46+02:00 StgToCmm: untag unlifted boxed primop arguments by subtracting the tag untagPrimArg subtracts the tag constant 1, which the backend folds into the memory operand displacement of the consuming load or store. Arguments are matched against the primop's declared signature type, so only container arguments are untagged and a polymorphic value or element argument keeps its tag. The declared argument types line up with the unarised Cmm arguments only when the primop has no unboxed-tuple argument; the primops that have one take no boxed unlifted container, and their arguments pass through unchanged. isUnliftedBoxedTy matches the tycon head first, which is total on representation-polymorphic type variables. - - - - - 12 changed files: - compiler/GHC/StgToCmm/Prim.hs - rts/CloneStack.c - rts/Compact.cmm - rts/PrimOps.cmm - rts/RtsAPI.c - rts/Schedule.c - rts/Threads.c - rts/TopHandler.c - rts/Weak.c - rts/sm/Compact.c - rts/sm/Evac.c - testsuite/tests/ffi/should_run/T21305_cmm.cmm Changes: ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -83,8 +83,19 @@ cgOpApp (StgPrimOp primop) args res_ty = do cfg <- getStgToCmmConfig let platform = stgToCmmPlatform cfg cmm_args <- getNonVoidArgAmodes args - -- See Note [Pointer tagging of unlifted boxed primitives] - let cmm_args' = zipWith (untagPrimArg platform) (nonVoidStgArgs args) cmm_args + -- See Note [Pointer tagging of unlifted boxed primitives]. Untag by the + -- primop's DECLARED signature type, so only a container argument is untagged + -- while a polymorphic value/element argument keeps its tag. The declared arg + -- types line up with the (unarised) Cmm arguments only when the primop has no + -- unboxed-tuple argument; the primops that do (e.g. VecPackOp) take no boxed + -- unlifted container, so leaving their arguments untouched is correct. + let (_, arg_tys, _, _, _) = primOpSig primop + nonVoid_arg_tys = [ ty | (arg, ty) <- zip args arg_tys + , not (null (stgArgRep arg)) ] + cmm_args' + | length nonVoid_arg_tys == length cmm_args + = zipWith (untagPrimArg platform) nonVoid_arg_tys cmm_args + | otherwise = cmm_args cmmPrimOpApp cfg primop cmm_args' (Just res_ty) cgOpApp (StgPrimCallOp primcall) args _res_ty @@ -110,10 +121,10 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do -- | Strip the pointer tag from a primop argument that is an unlifted boxed -- primitive (ByteArray#, Array#, MVar#, ...). See -- Note [Pointer tagging of unlifted boxed primitives]. -untagPrimArg :: Platform -> NonVoid StgArg -> CmmExpr -> CmmExpr -untagPrimArg platform nv_arg e - | isUnliftedBoxedTy (stgArgType (fromNonVoid nv_arg)) = cmmUntag platform e - | otherwise = e +untagPrimArg :: Platform -> Type -> CmmExpr -> CmmExpr +untagPrimArg platform arg_ty e + | isUnliftedBoxedTy arg_ty = cmmOffsetB platform e (negate 1) + | otherwise = e -- | Is this the type of an unlifted boxed /primitive/ (ByteArray#, Array#, -- MVar#, ...), whose pointer a producer tags with 1? Restricted to primitive @@ -122,11 +133,13 @@ untagPrimArg platform nv_arg e -- (e.g. an array element) must not be stripped here. isUnliftedBoxedTy :: Type -> Bool isUnliftedBoxedTy ty = - isUnliftedType ty && isBoxedType ty && - -- Look through newtypes (e.g. the ArrayArray# wrappers, which are newtypes - -- over MutableArray#) so a wrapped primitive container is still recognised, - -- while a user-defined unlifted @data@ type is not. - maybe False isPrimTyCon (tyConAppTyCon_maybe (unwrapType ty)) + -- Match the tycon head first: it is total and yields Nothing for a (possibly + -- representation-polymorphic) type variable, for which isUnliftedType panics. + -- Look through newtypes (e.g. the ArrayArray# wrappers, newtypes over + -- MutableArray#) so a wrapped primitive container is still recognised. + case tyConAppTyCon_maybe (unwrapType ty) of + Just tc -> isPrimTyCon tc && isUnliftedType ty && isBoxedType ty + Nothing -> False -- | Strip the tag from an unlifted boxed argument passed across a foreign-prim -- (or FFI) boundary, where the callee works with raw pointers. Unlike @@ -182,6 +195,11 @@ Foreign and foreign-prim arguments @Any \@UnliftedRep@ arguments, so the predicate here admits any unlifted boxed type rather than only the primitive ones. + In the result direction the callee is a producer: an unlifted boxed value + returned by a 'foreign import prim' callee carries tag 1, following the + convention of the out-of-line primops in rts/PrimOps.cmm. Callers read the + result through that tag (see e.g. T21305). + Stripping the tag from an already-untagged pointer is the identity, so the boundaries are correct whether or not a given producer has been taught to tag. ===================================== rts/CloneStack.c ===================================== @@ -78,7 +78,9 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { MessageCloneStack *msg; msg = (MessageCloneStack *)allocate(srcCapability, sizeofW(MessageCloneStack)); msg->tso = tso; - msg->result = (StgMVar*)deRefStablePtr(mvar); + // The stable pointer's referent (an MVar#) carries the boxed-unlifted- + // primitive pointer tag; strip it before the RTS dereferences it. + msg->result = (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)); SET_HDR_RELEASE(msg, &stg_MSG_CLONE_STACK_info, CCS_SYSTEM); sendMessage(srcCapability, tso->cap, (Message *)msg); ===================================== rts/Compact.cmm ===================================== @@ -143,7 +143,7 @@ eval: case ARR_WORDS: { (should) = ccall shouldCompact(compact "ptr", p "ptr"); - if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); } if (should == SHOULDCOMPACT_PINNED) { jump stg_raisezh(HsIface_cannotCompactPinned_closure(W_[ghc_hs_iface])); } @@ -154,7 +154,7 @@ eval: W_ size; size = SIZEOF_StgArrBytes + StgArrBytes_bytes(p); ALLOCATE(compact, ROUNDUP_BYTES_TO_WDS(size), p, to, tag); - P_[pp] = to; + P_[pp] = tag | to; prim %memcpy(to, p, size, 1); return(); } @@ -164,7 +164,7 @@ eval: MUT_ARR_PTRS_FROZEN_CLEAN: { (should) = ccall shouldCompact(compact "ptr", p "ptr"); - if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); } CHECK_HASH(); @@ -196,7 +196,7 @@ eval: SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: { (should) = ccall shouldCompact(compact "ptr", p "ptr"); - if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); } CHECK_HASH(); ===================================== rts/PrimOps.cmm ===================================== @@ -1113,7 +1113,8 @@ stg_listThreadszh () jump stg_raisezh(HsIface_heapOverflow_closure(W_[ghc_hs_iface])); } - return (arr); + // Tag the freshly allocated Array# with the boxed-unlifted-primitive tag. + return (arr + 1); } stg_isCurrentThreadBoundzh (/* no args */) @@ -1130,7 +1131,8 @@ stg_threadLabelzh ( gcptr tso ) if (r == 0) { return (0, 0); } else { - return (1, r); + // The label is a ByteArray#, stored untagged; tag it for the consumer. + return (1, r + 1); } } ===================================== rts/RtsAPI.c ===================================== @@ -982,7 +982,9 @@ void hs_try_putmvar_with_value (/* in */ int capability, #if !defined(THREADED_RTS) - performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value); + // The stable pointer's referent (an MVar#) carries the boxed-unlifted- + // primitive pointer tag; strip it before the RTS dereferences it. + performTryPutMVar(cap, (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)), value); freeStablePtr(mvar); #else @@ -995,7 +997,9 @@ void hs_try_putmvar_with_value (/* in */ int capability, task->cap = cap; RELEASE_LOCK(&cap->lock); - performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value); + // The stable pointer's referent (an MVar#) carries the boxed-unlifted- + // primitive pointer tag; strip it before the RTS dereferences it. + performTryPutMVar(cap, (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)), value); freeStablePtr(mvar); ===================================== rts/Schedule.c ===================================== @@ -1053,7 +1053,8 @@ scheduleProcessInbox (Capability **pcap USED_IF_THREADS) while (p != NULL) { pnext = p->link; - performTryPutMVar(cap, (StgMVar*)deRefStablePtr(p->mvar), + performTryPutMVar(cap, + (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(p->mvar)), Unit_closure); freeStablePtr(p->mvar); stgFree(p); @@ -1135,7 +1136,10 @@ schedulePostRunThread (Capability *cap, StgTSO *t) if(allocLimitRunHook) { // Create a thread to run the allocation limit handler. - StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t); + // The handler receives the offending thread as a ThreadId#, which + // carries the boxed-unlifted-primitive pointer tag. + StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, + TAG_CLOSURE(1, (StgClosure*)t)); StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c); setThreadLabel(cap, hookThread, "allocation limit handler thread"); // Schedule the handler to be run immediatelly. ===================================== rts/Threads.c ===================================== @@ -934,7 +934,9 @@ StgMutArrPtrs *listThreads(Capability *cap) // Ignore them. if (i == n_threads) break; - arr->payload[i] = (StgClosure *) t; + // The array elements are ThreadId#s, which carry the + // boxed-unlifted-primitive pointer tag. + arr->payload[i] = TAG_CLOSURE(1, (StgClosure *) t); i++; } } ===================================== rts/TopHandler.c ===================================== @@ -19,7 +19,8 @@ void rts_setMainThread(StgWeak *weak) { // See Note [rts_setMainThread has an unsound type] in // libraries/base/GHC/TopHandler.hs. - ASSERT(weak->key->header.info == &stg_TSO_info); + // The key is a ThreadId#, which carries the boxed-unlifted-primitive tag. + ASSERT(UNTAG_CLOSURE(weak->key)->header.info == &stg_TSO_info); RELEASE_LOCK(&m); } @@ -34,7 +35,7 @@ StgTSO *getTopHandlerThread(void) { } const StgInfoTable *info = ACQUIRE_LOAD(&weak->header.info); if (info == &stg_WEAK_info) { - StgClosure *key = ((StgWeak*)weak)->key; + StgClosure *key = UNTAG_CLOSURE(((StgWeak*)weak)->key); // See Note [rts_setMainThread has an unsound type] in // libraries/base/GHC/TopHandler.hs. ===================================== rts/Weak.c ===================================== @@ -173,7 +173,9 @@ scheduleFinalizers(Capability *cap, StgWeak *list) rts_apply(cap, (StgClosure *)runFinalizerBatch_closure, rts_mkInt(cap,n)), - (StgClosure *)arr) + // runFinalizerBatch indexes this as an Array#, so it + // must carry the boxed-unlifted-primitive pointer tag. + TAG_CLOSURE(1, (StgClosure *)arr)) ); scheduleThread(cap,t); ===================================== rts/sm/Compact.c ===================================== @@ -122,6 +122,31 @@ get_iptr_tag(StgInfoTable *iptr) } } + 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: + case WEAK: + case PRIM: + case MUT_PRIM: + case TSO: + case STACK: + case TREC_CHUNK: + case CONTINUATION: + // Boxed unlifted primitives carry the pointer tag 1; restore it (this is + // only consulted for references that were tagged before threading). + return 1; + default: return 0; } ===================================== rts/sm/Evac.c ===================================== @@ -328,7 +328,7 @@ copy_tag_nolock(StgClosure **p, const StgInfoTable *info, */ ATTR_ALWAYS_INLINE static inline bool copyPart(StgClosure **p, StgClosure *src, uint32_t size_to_reserve, - uint32_t size_to_copy, uint32_t gen_no) + uint32_t size_to_copy, uint32_t gen_no, StgWord tag) { StgPtr to, from; uint32_t i; @@ -361,7 +361,7 @@ spin: to[i] = from[i]; } - RELEASE_STORE(p, (StgClosure *) to); + RELEASE_STORE(p, TAG_CLOSURE(tag, (StgClosure *) to)); RELEASE_STORE(&src->header.info, (const StgInfoTable*)MK_FORWARDING_PTR(to)); #if defined(PROFILING) @@ -965,11 +965,13 @@ loop: case WEAK: case PRIM: case MUT_PRIM: - copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); + // These boxed unlifted primitives carry the pointer tag 1; preserve it + // across evacuation. + copy_tag(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag); return; case BCO: - copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no); + copy_tag(p,info,q,bco_sizeW((StgBCO *)q),gen_no,tag); return; case THUNK_SELECTOR: @@ -1009,28 +1011,28 @@ loop: return; case ARR_WORDS: - // just copy the block - copy(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no); + // just copy the block, preserving the pointer tag + copy_tag(p,info,q,arr_words_sizeW((StgArrBytes *)q),gen_no,tag); return; case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN_CLEAN: case MUT_ARR_PTRS_FROZEN_DIRTY: - // just copy the block - copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no); + // just copy the block, preserving the pointer tag + copy_tag(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no,tag); return; 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: - // just copy the block - copy(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no); + // just copy the block, preserving the pointer tag + copy_tag(p,info,q,small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs *)q),gen_no,tag); return; case TSO: - copy(p,info,q,sizeofW(StgTSO),gen_no); + copy_tag(p,info,q,sizeofW(StgTSO),gen_no,tag); return; case STACK: @@ -1045,7 +1047,7 @@ loop: bool mine; mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack), - sizeofW(StgStack), gen_no); + sizeofW(StgStack), gen_no, tag); if (mine) { new_stack = (StgStack *)*p; move_STACK(stack, new_stack); @@ -1059,11 +1061,11 @@ loop: } case TREC_CHUNK: - copy(p,info,q,sizeofW(StgTRecChunk),gen_no); + copy_tag(p,info,q,sizeofW(StgTRecChunk),gen_no,tag); return; case CONTINUATION: - copy(p,info,q,continuation_sizeW((StgContinuation*)q),gen_no); + copy_tag(p,info,q,continuation_sizeW((StgContinuation*)q),gen_no,tag); return; default: ===================================== testsuite/tests/ffi/should_run/T21305_cmm.cmm ===================================== @@ -2,5 +2,7 @@ f(P_ a, P_ b, P_ c) { I64[c + SIZEOF_StgArrBytes + 8] = 770000; - return (b, a, c); + // c is a MutableByteArray#; unlifted boxed results carry tag 1. + // See Note [Pointer tagging of unlifted boxed primitives] in GHC.StgToCmm.Prim. + return (b, a, c + 1); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45f976404bf4632ed48f765da8c61a6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45f976404bf4632ed48f765da8c61a6... 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