Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC Commits: 00a089fb by Simon Jakobi at 2026-07-10T18:23:36+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 - - - - - 14141caa by Simon Jakobi at 2026-07-10T18:23:36+02:00 Nonmoving GC: retag constructors in the selector shortcut The retag of evaluated constructors in eval_thunk_selector (rts/sm/Evac.c) was missing from its nonmoving counterpart: update_selector_chain installed the untagged value as the indirectee and origin field, violating the enter-taggable invariant (#23173) in nonmoving ways. Mirror the retag at the found-a-value site. Assisted-by: Claude Fable 5 - - - - - 8 changed files: - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Utils.hs - rts/RtsMessages.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/rts/Messages.h - rts/include/stg/MiscClosures.h - rts/sm/NonMovingShortcut.c Changes: ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -382,9 +382,11 @@ 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. @@ -392,9 +394,9 @@ cgDataCon mn data_con -- 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. - ; when (taggable && not (profileIsProfiling profile)) $ - emitCheckEnteredTaggable (showPprUnsafe data_con) - ; void $ emitReturn - [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))] + ; 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 ===================================== rts/RtsMessages.c ===================================== @@ -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/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/NonMovingShortcut.c ===================================== @@ -225,6 +225,15 @@ selectee_changed: default: // Found a value, add the current selector to the chain and // update it. + // Re-establish the pointer tag for an evaluated constructor, + // as in eval_thunk_selector (rts/sm/Evac.c): the indirectees + // and the origin field installed by update_selector_chain + // must carry the tag. + ; + const StgInfoTable *val_info = get_itbl(val); + if (val_info->type >= CONSTR && val_info->type <= CONSTR_NOCAF) { + val = TAG_CLOSURE(stg_min(TAG_MASK, 1 + val_info->srt), val); + } p->payload[0] = chain; chain = p; update_selector_chain(chain, origin, p0, val); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7a5055e9b30655c650a4fb5dac8c0f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7a5055e9b30655c650a4fb5dac8c0f... You're receiving this email because of your account on gitlab.haskell.org.