[Git][ghc/ghc][wip/sjakobi/mr16259] 2 commits: Enter-taggable check: share the report code in a single RTS stub

10 Jul 2026


      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.

    

Simon Jakobi (＠sjakobi2)

tags

participants (1)