Sebastian Graf pushed to branch wip/sg/enter-taggable-invariant at Glasgow Haskell Compiler / GHC Commits: 550057da by Simon Jakobi at 2026-07-31T19:15:49+02:00 Compile-time perf: convey only correctness-relevant LFInfos at -O0 Attaching LFInfo to every IfaceId at every optimisation level (needed so imported value references carry their pointer tag) regressed compiler allocations at -O0. Only LFCon/LFScalar/LFPrim are correctness-relevant (values without enterable entry code); functions and thunks are safely enterable and their LFInfo is a mere optimisation, so omit it under -fomit-interface-pragmas, and restore the pre-existing gating of CAF-info and tag sigs. Also drop a dead warnPprTrace in updateDecl. Measured (quick flavour): T1969 -0.26%; most of the remaining regression comes from the enforcement code itself (see the MR discussion). Assisted-by: Claude Fable 5 - - - - - a15d734e by Sebastian Graf at 2026-07-31T19:15:49+02:00 testsuite: LFCon must reach importers at -O0 (T23173a) A module cases on an imported statically evaluated constructor at -O0, running under --fatal-enter-taggable. The exporting interface carries LFCon despite -fomit-interface-pragmas, so the importer tags the reference; a compiler that omits it makes the importer enter the constructor and the test aborts. - - - - - 447b76be by Simon Jakobi at 2026-07-31T19:16:09+02:00 Don't emit the enter-taggable check when profiling LDV profiling relies on entering closures to mark them as used, so under profiling the RTS deliberately does not shortcut ENTER() on the tag (rts/include/Cmm.h) and tagged constructors are legitimately entered. With checkEnteredTaggable in every taggable constructor's entry code this aborted (under the temporary fatal default) or warned in every profiled program. Emit the check only when not profiling. The tag-test in emitEnter is kept under profiling: the scrutinee path (AssignTo) has always had one, so LDV never saw those enters anyway. Assisted-by: Claude Fable 5 - - - - - f844fada by Simon Jakobi at 2026-07-31T19:16:09+02:00 Enter-taggable check: changelog entry, relaxed atomics, wasm note Add the changelog.d entry for --fatal-enter-taggable, use relaxed atomics for checkEnteredTaggable's one-shot warning latch, and document that the wasm dynamic linker path hands out untagged constructor closures. Assisted-by: Claude Fable 5 - - - - - 0f1742f6 by Simon Jakobi at 2026-07-31T19:16:09+02:00 Enter-taggable check: share the report code in a single RTS stub The check emitted into every taggable constructor's entry code (#23173) was a C call with a per-constructor descr string, which costs both compile time (T1969 +3%) and code size. Since the constructor name and tag are both derivable from the info table, the entry code can instead be a single tail-jump to a shared RTS stub, stg_enteredTaggable, which reports the violation and self-returns the value tagged. T1969 compiler allocations: -2.8%; T18304: -1.4%. Assisted-by: Claude Fable 5 - - - - - d9c6cc7e by Simon Jakobi at 2026-07-31T19:16:09+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 - - - - - 00cefb86 by Simon Jakobi at 2026-07-31T19:16:30+02:00 wasm: untag the Weak# obtained through a StablePtr in rts_promiseThrowTo Same defect class as the hs_try_putmvar fixes: the Weak# created around a JSFFI export's TSO carries tag 1 (#23173) and makeStablePtr# stores it tagged, so rts_promiseThrowTo read all StgWeak fields one byte off and crashed in throwToMsg. The resolve/reject paths were already covered by the hs_try_putmvar_with_value fix. Assisted-by: Claude Fable 5 - - - - - b9c37398 by Simon Jakobi at 2026-07-31T19:16:30+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: - 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. Assisted-by: Claude Fable 5 - - - - - 20 changed files: - + changelog.d/enter-taggable-invariant-23173 - compiler/GHC/Iface/Make.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghci/GHCi/ObjLink.hs - rts/Prelude.h - rts/RtsMessages.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Messages.h - rts/include/rts/RtsToHsIface.h - rts/include/stg/MiscClosures.h - rts/sm/Sanity.c - rts/wasm/JSFFI.c - testsuite/tests/codeGen/should_compile/T21710a.stderr - + testsuite/tests/codeGen/should_run/T23173a.hs - + testsuite/tests/codeGen/should_run/T23173a.stdout - + testsuite/tests/codeGen/should_run/T23173a_A.hs - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== changelog.d/enter-taggable-invariant-23173 ===================================== @@ -0,0 +1,20 @@ +section: codegen +synopsis: Pointers to boxed unlifted primitives (``ByteArray#``, ``Array#``, + ``MVar#``, ...) are now tagged, and entering a taggable normal form is + reported. +issues: #23173 +mrs: !16259 + +description: { + References to boxed unlifted primitive values such as ``ByteArray#``, + ``Array#`` or ``MVar#`` now carry pointer tag 1, like single-constructor + data types. Together with this, GHC now enforces the invariant that the + 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 + and return unlifted boxed results with their pointer tag (1 for primitive + objects). C code that obtains an unlifted boxed value, e.g. an ``MVar#``, + through a ``StablePtr`` strips the tag before dereferencing the pointer. +} ===================================== compiler/GHC/Iface/Make.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Types.TyThing import GHC.Types.CompleteMatch import GHC.Types.Name.Cache -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Utils.Binary @@ -139,7 +138,12 @@ mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos stubs foreign_files -- value must carry the value's pointer tag, which needs its LambdaFormInfo), -- not an inlining pragma. Attach it regardless of -fomit-interface-pragmas -- so imported value references are tagged at every optimisation level. - let decls = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos + -- (At -O0 the code generator only conveys the correctness-relevant + -- LFInfos; see generatedInfo in GHC.StgToCmm.) CAF-info and tag sigs + -- remain ordinary pragmas, omitted under -fomit-interface-pragmas. + let omit_prags = gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) + mb_stg_infos' = if omit_prags then Nothing else mb_stg_infos + decls = updateDecl (mi_decls partial_iface) mb_stg_infos' omit_prags mb_cmm_infos -- See Note [Foreign stubs and TH bytecode linking] mi_simplified_core <- for (mi_simplified_core partial_iface) $ \simpl_core -> do @@ -189,13 +193,15 @@ shareIface nc compressionLevel mi = do initBinMemSize :: Int initBinMemSize = 1024 * 1024 -- 1 MB -updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl] -updateDecl decls Nothing Nothing = decls -updateDecl decls m_stg_infos m_cmm_infos +updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Bool -> Maybe CmmCgInfos -> [IfaceDecl] +updateDecl decls Nothing _ Nothing = decls +updateDecl decls m_stg_infos omit_prags m_cmm_infos = map update_decl decls where (non_cafs,lf_infos) = maybe (mempty, mempty) - (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info)) + (\cmm_info -> ( if omit_prags then mempty + else ncs_nameSet (cgNonCafs cmm_info) + , cgLFInfos cmm_info )) m_cmm_infos tag_sigs = fromMaybe mempty m_stg_infos @@ -203,9 +209,8 @@ updateDecl decls m_stg_infos m_cmm_infos | let not_caffy = elemNameSet nm non_cafs , let mb_lf_info = lookupNameEnv lf_infos nm , let sig = lookupNameEnv tag_sigs nm - -- NB: with LFInfo now attached at every optimisation level, a missing - -- LFInfo is unremarkable (e.g. at -O0), so we do not trace it here. - , warnPprTrace False "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True + -- A missing LFInfo is unremarkable: at -O0 only the + -- correctness-relevant LFInfos are conveyed (see GHC.StgToCmm). -- Only allocate a new IfaceId if we're going to update the infos , isJust mb_lf_info || not_caffy || isJust sig = IfaceId nm ty details $ ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -21,9 +21,11 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import GHC.StgToCmm.Ticky -import GHC.StgToCmm.Types (ModuleLFInfos) +import GHC.StgToCmm.Types (ModuleLFInfos, LambdaFormInfo(..)) import GHC.StgToCmm.CgUtils (CgStream) +import GHC.Platform.Profile (profileIsProfiling) + import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel @@ -137,11 +139,21 @@ codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) tycons !lf = cg_lf info -- LFInfo is part of the STG-ABI (a reference to an imported value - -- must carry its pointer tag), not an inlining pragma, so collect - -- it for every binding regardless of -fomit-interface-pragmas. - -- (Only LFInfo is conveyed here, never unfoldings.) + -- must carry its pointer tag), not an inlining pragma, so even + -- under -fomit-interface-pragmas we must convey the LFInfos that + -- pointer-tagging correctness depends on: values without entry + -- code that may be entered (LFCon under the tag-test in + -- emitEnter; LFScalar/LFPrim never). Functions and thunks are + -- safely enterable, so their LFInfo remains a mere optimisation + -- and is omitted at -O0 to keep interfaces small. + keep_lf_info lf = case lf of + LFCon{} -> True + LFScalar -> True + LFPrim -> True + _ -> not (stgToCmmOmitIfPragmas cfg) !generatedInfo - = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) + = mkNameEnv [ i | i@(_, lf) <- Prelude.map extractInfo (nonDetEltsUFM cg_id_infos) + , keep_lf_info lf ] ; rn_mapping <- liftIO (readIORef uniqRnRef) ; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping) @@ -370,15 +382,21 @@ cgDataCon mn data_con ; tickyReturnOldCon (length arg_reps) -- A taggable (small-family) normal form should never be entered: -- every reference to it carries the constructor's pointer tag, so - -- reaching this entry code is an invariant violation. We report it - -- (aborting under +RTS --fatal-enter-taggable, otherwise warning once) - -- and then self-return the value tagged with the constructor tag. + -- reaching this entry code is an invariant violation. We jump to + -- a shared RTS stub that reports it (aborting under +RTS + -- --fatal-enter-taggable, otherwise warning once) and self-returns + -- the value tagged with the constructor tag; sharing the stub keeps + -- the per-constructor entry code to a single tail-jump. -- Larger families have no spare tag, so their values are entered -- as normal and the entry returns them tagged with the -- family-saturating tag. - ; when taggable $ - emitCheckEnteredTaggable (showPprUnsafe data_con) - ; void $ emitReturn - [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))] + -- When profiling, entering tagged constructors is sanctioned: + -- LDV profiling relies on it to mark closures as used (ENTER() + -- in rts/include/Cmm.h does not shortcut on the tag), so the + -- check would fire on every constructor use. + ; if taggable && not (profileIsProfiling profile) + then emitJumpEnteredTaggable node + else void $ emitReturn + [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))] } } ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -10,7 +10,7 @@ module GHC.StgToCmm.Utils ( emitDataLits, emitRODataLits, emitDataCon, - emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, emitCheckEnteredTaggable, + emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, emitJumpEnteredTaggable, emitBarf, assignTemp, newTemp, @@ -193,11 +193,16 @@ emitBarf msg = do -- Call from a taggable normal form's entry code (which the pointer-tagging -- invariant makes unreachable). It aborts under +RTS --fatal-enter-taggable and -- otherwise warns once; the entry then self-returns the tagged value. -emitCheckEnteredTaggable :: String -> FCode () -emitCheckEnteredTaggable con = do - strLbl <- newStringCLit con - emitRtsCall rtsUnitId (fsLit "checkEnteredTaggable") - [(CmmLit strLbl, AddrHint)] False +-- Tail-jump to the RTS's shared entry code for taggable normal forms +-- (stg_enteredTaggable in rts/StgMiscClosures.cmm), which reports the +-- invariant violation and self-returns the value tagged with its +-- constructor tag (both derived from the info table). +emitJumpEnteredTaggable :: CmmExpr -> FCode () +emitJumpEnteredTaggable node = do + profile <- getProfile + updfr_off <- getUpdFrameOff + let lbl = mkCmmCodeLabel rtsUnitId (fsLit "stg_enteredTaggable") + emit (mkJump profile NativeNodeCall (CmmLit (CmmLabel lbl)) [node] updfr_off) emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) CmmMayReturn ===================================== 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) ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -302,6 +302,10 @@ isWindowsHost = False #endif #if defined(wasm32_HOST_ARCH) +-- The wasm dynamic linker resolves symbols out of process, so the RTS +-- helper below is unavailable; looked-up constructor closures stay +-- untagged and forcing one triggers the (non-fatal) enter-taggable +-- warning. tagClosurePtr :: Ptr a -> Ptr a tagClosurePtr = id #else ===================================== 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/RtsMessages.c ===================================== @@ -88,9 +88,9 @@ checkEnteredTaggable(const char *con) ssbarf("entered a taggable normal form: %s", con); // ssbarf does not return } - static int warned = 0; - if (!warned) { - warned = 1; + static StgWord warned = 0; + if (!RELAXED_LOAD(&warned)) { + RELAXED_STORE(&warned, 1); debugBelch("warning: entered a taggable normal form: %s\n" "(further occurrences suppressed; rerun with " "+RTS --fatal-enter-taggable to abort)\n", @@ -98,6 +98,16 @@ checkEnteredTaggable(const char *con) } } +// Backing for stg_enteredTaggable (StgMiscClosures.cmm), the shared entry +// code of taggable normal forms: report the violation and hand back the +// pointer retagged with its constructor tag so the entry can self-return. +StgClosure * +enteredTaggableClosure(StgClosure *p) +{ + checkEnteredTaggable(GET_CON_DESC(get_con_itbl(p))); + return tagConstr(p); +} + void _assertFail(const char*filename, unsigned int linenum) { ===================================== rts/RtsSymbols.c ===================================== @@ -542,7 +542,7 @@ extern char **environ; SymI_HasProto(barf) \ SymI_HasProto(sbarf) \ SymI_HasProto(ssbarf) \ - SymI_HasProto(checkEnteredTaggable) \ + SymI_HasProto(stg_enteredTaggable) \ SymI_HasProto(tagClosureIfConstr) \ SymI_HasProto(startEventLogging) \ SymI_HasProto(endEventLogging) \ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -103,6 +103,19 @@ INFO_TABLE_RET (stg_restore_cccs_eval, RET_SMALL, W_ info_ptr, W_ cccs) jump stg_ap_0_fast(ret); } +/* Shared entry code for taggable normal forms, which the pointer-tagging + invariant makes unreachable: every taggable data constructor's entry code + tail-jumps here (see cgDataCon in GHC.StgToCmm) instead of carrying its own + report call. Reports the violation (aborting under +RTS + --fatal-enter-taggable, otherwise warning once) and self-returns the value + tagged with its constructor tag; name and tag come from the info table. */ +stg_enteredTaggable (P_ node) +{ + P_ tagged; + (tagged) = ccall enteredTaggableClosure(node "ptr"); + return (tagged); +} + /* ---------------------------------------------------------------------------- Support for the bytecode interpreter. ------------------------------------------------------------------------- */ ===================================== rts/include/rts/Messages.h ===================================== @@ -49,11 +49,15 @@ void pbarf(const char *fmt, void *p) void ssbarf(const char *fmt, const char *s) STG_NORETURN; -/* Called from a taggable normal form's entry code (which the pointer-tagging - invariant makes unreachable). Aborts under +RTS --fatal-enter-taggable, otherwise - warns once and lets the entry self-return the tagged value. */ +/* Report that a taggable normal form was entered (its entry code is + unreachable under the pointer-tagging invariant). Aborts under +RTS + --fatal-enter-taggable, otherwise warns once. */ void checkEnteredTaggable(const char *con); +/* Backing for stg_enteredTaggable: report the violation and return the + closure pointer retagged with its constructor tag. */ +StgClosure *enteredTaggableClosure(StgClosure *p); + // declared in Rts.h: // extern void _assertFail(const char *filename, unsigned int linenum) // STG_NORETURN; ===================================== 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/include/stg/MiscClosures.h ===================================== @@ -477,6 +477,7 @@ RTS_FUN_DECL(stg_raiseIOzh); RTS_FUN_DECL(stg_paniczh); RTS_FUN_DECL(stg_keepAlivezh); RTS_FUN_DECL(stg_absentErrorzh); +RTS_FUN_DECL(stg_enteredTaggable); RTS_FUN_DECL(stg_newPromptTagzh); RTS_FUN_DECL(stg_promptzh); ===================================== 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); } ===================================== rts/wasm/JSFFI.c ===================================== @@ -297,7 +297,9 @@ __attribute__((export_name("rts_promiseThrowTo"))) void rts_promiseThrowTo(HsStablePtr, HsJSVal); void rts_promiseThrowTo(HsStablePtr sp, HsJSVal js_err) { Capability *cap = &MainCapability; - StgWeak *w = (StgWeak *)deRefStablePtr(sp); + // Weak# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed + // primitives] in GHC.StgToCmm.Prim. (The key field is stored untagged.) + StgWeak *w = (StgWeak *)UNTAG_CLOSURE((StgClosure *)deRefStablePtr(sp)); if (w->header.info == &stg_DEAD_WEAK_info) { return; } ===================================== 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/codeGen/should_run/T23173a.hs ===================================== @@ -0,0 +1,11 @@ +module Main where + +import T23173a_A + +-- Cases on an imported evaluated constructor at -O0. With LFCon conveyed in +-- the interface the reference is tagged and never entered; without it the +-- scrutinee is entered and --fatal-enter-taggable aborts. +main :: IO () +main = case x of + Just b -> print b + Nothing -> putStrLn "nothing" ===================================== testsuite/tests/codeGen/should_run/T23173a.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== testsuite/tests/codeGen/should_run/T23173a_A.hs ===================================== @@ -0,0 +1,8 @@ +module T23173a_A where + +-- A statically evaluated constructor value. Its interface must carry LFCon +-- even at -O0 (where -fomit-interface-pragmas is on), so importers tag +-- references to it. See Note [Pointer tagging of unlifted boxed primitives] +-- in GHC.StgToCmm.Prim and mkFullIface in GHC.Iface.Make. +x :: Maybe Bool +x = Just True ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -172,6 +172,8 @@ test('T12622', normal, multimod_compile_and_run, ['T12622', '-O']) # present even at -O0) and survives hs-boot indirections. Compiled at -O0, # where a dropped tag manifests. test('T24136', normal, multimod_compile_and_run, ['T24136', '']) +test('T23173a', extra_run_opts('+RTS --fatal-enter-taggable -RTS'), + multimod_compile_and_run, ['T23173a', '']) test('T12757', normal, compile_and_run, ['']) test('T12855', normal, compile_and_run, ['']) test('T9577', [ unless(arch('x86_64') or arch('i386'),skip), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f7072d7e2d356829a3278794de5378... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f7072d7e2d356829a3278794de5378... 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