GitLab

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);