Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC Commits: e5d219db by Simon Jakobi at 2026-07-10T23:19:05+02:00 StgToCmm: don't untag primop args when unarisation broke positional alignment cgOpApp zips the primop's declared argument types positionally against the STG args to decide untagging (see Note [Pointer tagging of unlifted boxed primitives]), but unarisation splits a declared unboxed-tuple argument (e.g. packFloatX4#'s) into several STG args, so the zip truncated and dropped arguments: "emitPrimOp: VecPackOp has wrong number of arguments", failing all simd tests in the first CI run of !16329. When the lengths disagree we now skip declared-type-driven untagging altogether; no such primop takes a boxed pointer through a tuple. Assisted-by: Claude Fable 5 - - - - - 71fa62be by Simon Jakobi at 2026-07-10T23:19:26+02:00 rts: untag MVar# pointers obtained through StablePtrs MVar# pointers now carry tag 1 (#23173), and deRefStablePtr returns the pointer as stored, so C code casting the result to StgMVar* must strip the tag first: hs_try_putmvar (RtsAPI.c, plus the deferred-PutMVar path in Schedule.c) and sendCloneStackMessage (CloneStack.c). Fixes hs_try_putmvar001/2/3, T15427, cloneThreadStack{,Migrating} and T26640 from the first CI run of !16329. Assisted-by: Claude Fable 5 - - - - - 7d55d5a0 by Simon Jakobi at 2026-07-10T23:19:36+02:00 foreign import prim: callees must tag returned unlifted boxed results A foreign-prim callee is a producer under the tagging discipline of #23173: an unlifted boxed result must be returned with its proper tag, just like the out-of-line primops in rts/PrimOps.cmm, because compiled code assumes the tag on the result. T21305's Cmm now returns the MutableByteArray# tagged; without it the caller's subtract-1 untag read one byte off. The convention is documented in Note [Pointer tagging of unlifted boxed primitives] and the changelog entry. Assisted-by: Claude Fable 5 - - - - - a43c6f95 by Simon Jakobi at 2026-07-10T23:19:46+02:00 testsuite: accept T21710a output for the shared stg_enteredTaggable stub The expected output still had the per-constructor checkEnteredTaggable ccall plus return call; each constructor entry now makes a single call to the shared stg_enteredTaggable stub. Assisted-by: Claude Fable 5 - - - - - c00b949f by Simon Jakobi at 2026-07-10T23:19:46+02:00 Accept the T13960 compile-time regression from enter-taggable enforcement The ~3% compile-time allocation increase on T13960 is the cost of the emitEnter tag test, the semantic core of the invariant enforcement (#23173). The perf driver reads the Metric Increase block from the HEAD commit only, hence this empty commit at the branch tip. ------------------------- Metric Increase: T13960 ------------------------- Assisted-by: Claude Fable 5 - - - - - 7 changed files: - changelog.d/enter-taggable-invariant-23173 - compiler/GHC/StgToCmm/Prim.hs - rts/CloneStack.c - rts/RtsAPI.c - rts/Schedule.c - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/ffi/should_run/T21305_cmm.cmm Changes: ===================================== changelog.d/enter-taggable-invariant-23173 ===================================== @@ -12,4 +12,10 @@ description: { entry code of a taggable normal form is unreachable: entering such a closure prints a one-shot warning at runtime, or aborts the program when the new RTS flag ``--fatal-enter-taggable`` is given. + + ``foreign import prim`` callees receive unlifted boxed arguments untagged, + as before, but must now return unlifted boxed results with their proper + pointer tag (1 for primitive objects). Likewise, C code that obtains an + unlifted boxed value, e.g. an ``MVar#``, through a ``StablePtr`` must strip + the tag before dereferencing the pointer. } ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -92,8 +92,15 @@ cgOpApp (StgPrimOp primop) args res_ty = do cmm_args <- getNonVoidArgAmodes args -- See Note [Pointer tagging of unlifted boxed primitives] let decl_tys = map scaledThing (fst (splitFunTys (dropForAlls (primOpType primop)))) - nv_decl_tys = [ dty - | (dty, arg) <- zip decl_tys args + -- Unarisation splits a declared unboxed-tuple argument (e.g. + -- packFloatX4#'s) into several STG args, breaking positional + -- alignment with the declared types. No such primop takes a boxed + -- pointer through a tuple, so fall back to not untagging anything. + mb_decl_tys + | decl_tys `equalLength` args = map Just decl_tys + | otherwise = map (const Nothing) args + nv_decl_tys = [ mb_dty + | (mb_dty, arg) <- zip mb_decl_tys args , not (null (stgArgRep arg)) ] cmm_args' = zipWith3 (untagPrimArg platform) nv_decl_tys (nonVoidStgArgs args) cmm_args -- The RTS dereferences the key field of a Weak directly (GC key @@ -145,9 +152,10 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do -- yet (e.g. ThreadId#s in the array filled in by C listThreads). -- -- See Note [Pointer tagging of unlifted boxed primitives]. -untagPrimArg :: Platform -> Type -> NonVoid StgArg -> CmmExpr -> CmmExpr -untagPrimArg platform decl_ty nv_arg e - | Just tc <- tyConAppTyCon_maybe decl_ty +untagPrimArg :: Platform -> Maybe Type -> NonVoid StgArg -> CmmExpr -> CmmExpr +untagPrimArg platform mb_decl_ty nv_arg e + | Just decl_ty <- mb_decl_ty + , Just tc <- tyConAppTyCon_maybe decl_ty = if isKnownTag1PrimTyCon tc then cmmOffsetB platform e (-1) else if isUnliftedBoxedTy (stgArgType (fromNonVoid nv_arg)) @@ -238,6 +246,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 other direction the callee is a producer: an unlifted boxed value + /returned/ by a 'foreign import prim' must carry its proper tag (1 for a + primitive object), just like the out-of-line primops in rts/PrimOps.cmm. + Compiled code assumes the tag on the result (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); + // MVar# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed + // primitives] in GHC.StgToCmm.Prim. + 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/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); + // MVar# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed + // primitives] in GHC.StgToCmm.Prim. + performTryPutMVar(cap, (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)), value); freeStablePtr(mvar); #else @@ -995,7 +997,8 @@ void hs_try_putmvar_with_value (/* in */ int capability, task->cap = cap; RELEASE_LOCK(&cap->lock); - performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value); + 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); ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -53,35 +53,34 @@ } {offset cqw: // global - if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy; // CmmCondBranch + if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy; cqx: // global - R1 = M.foo_closure; // CmmAssign - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + R1 = M.foo_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; cqy: // global - I64[Sp - 8] = cqo; // CmmStore - R1 = R2; // CmmAssign - Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cqo; else goto cqp; // CmmCondBranch + I64[Sp - 8] = cqo; + R1 = R2; + Sp = Sp - 8; + if (R1 & 7 != 0) goto cqo; else goto cqp; cqp: // global - call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8; // CmmCall + call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8; cqo: // global - _cqv::P64 = R1 & 7; // CmmAssign - if (_cqv::P64 != 1) goto n0; else goto cqt; // CmmCondBranch + _cqv::P64 = R1 & 7; + if (_cqv::P64 != 1) goto n0; else goto cqt; n0: // global - if (_cqv::P64 != 2) goto cqs; else goto cqu; // CmmCondBranch + if (_cqv::P64 != 2) goto cqs; else goto cqu; cqs: // global - // dataToTagSmall# - R1 = R1 & 7 - 1; // CmmAssign - Sp = Sp + 8; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + R1 = R1 & 7 - 1; + Sp = Sp + 8; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; cqu: // global - R1 = 42; // CmmAssign - Sp = Sp + 8; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + R1 = 42; + Sp = Sp + 8; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; cqt: // global - R1 = 2; // CmmAssign - Sp = Sp + 8; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + R1 = 2; + Sp = Sp + 8; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } }, section ""data" . M.foo_closure" { @@ -92,27 +91,7 @@ ==================== Output Cmm ==================== -[section ""cstring" . cqJ_str" { - cqJ_str: - I8[] "A" - }, - section ""cstring" . cqL_str" { - cqL_str: - I8[] "B" - }, - section ""cstring" . cqN_str" { - cqN_str: - I8[] "C" - }, - section ""cstring" . cqP_str" { - cqP_str: - I8[] "D" - }, - section ""cstring" . cqR_str" { - cqR_str: - I8[] "E" - }, - section ""relreadonly" . M.E_closure_tbl" { +[section ""relreadonly" . M.E_closure_tbl" { M.E_closure_tbl: const M.A_closure+1; const M.B_closure+2; @@ -121,73 +100,63 @@ const M.E_closure+5; }, M.A_con_entry() { // [] - { info_tbls: [(cqK, + { info_tbls: [(cqJ, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cqK: // global - call "ccall" arg hints: [PtrHint] result hints: [] checkEnteredTaggable(cqJ_str); // CmmUnsafeForeignCall - R1 = R1 + 1; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cqJ: // global + call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8; } }, M.B_con_entry() { // [] - { info_tbls: [(cqM, + { info_tbls: [(cqK, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cqM: // global - call "ccall" arg hints: [PtrHint] result hints: [] checkEnteredTaggable(cqL_str); // CmmUnsafeForeignCall - R1 = R1 + 2; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cqK: // global + call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8; } }, M.C_con_entry() { // [] - { info_tbls: [(cqO, + { info_tbls: [(cqL, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cqO: // global - call "ccall" arg hints: [PtrHint] result hints: [] checkEnteredTaggable(cqN_str); // CmmUnsafeForeignCall - R1 = R1 + 3; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cqL: // global + call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8; } }, M.D_con_entry() { // [] - { info_tbls: [(cqQ, + { info_tbls: [(cqM, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cqQ: // global - call "ccall" arg hints: [PtrHint] result hints: [] checkEnteredTaggable(cqP_str); // CmmUnsafeForeignCall - R1 = R1 + 4; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cqM: // global + call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8; } }, M.E_con_entry() { // [] - { info_tbls: [(cqS, + { info_tbls: [(cqN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cqS: // global - call "ccall" arg hints: [PtrHint] result hints: [] checkEnteredTaggable(cqR_str); // CmmUnsafeForeignCall - R1 = R1 + 5; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cqN: // global + call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8; } }] ===================================== testsuite/tests/ffi/should_run/T21305_cmm.cmm ===================================== @@ -2,5 +2,8 @@ f(P_ a, P_ b, P_ c) { I64[c + SIZEOF_StgArrBytes + 8] = 770000; - return (b, a, c); + // c arrives untagged and is a MutableByteArray#, so it must be returned + // with 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/14141caa5a34e1a3b2cc35eef943595... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14141caa5a34e1a3b2cc35eef943595... You're receiving this email because of your account on gitlab.haskell.org.