Sebastian Graf pushed to branch wip/sg/enter-taggable-invariant at Glasgow Haskell Compiler / GHC

Commits:

20 changed files:

Changes:

  • changelog.d/enter-taggable-invariant-23173
    1 
    +section: codegen
    2 
    +synopsis: Pointers to boxed unlifted primitives (``ByteArray#``, ``Array#``,
    3 
    +  ``MVar#``, ...) are now tagged, and entering a taggable normal form is
    4 
    +  reported.
    5 
    +issues: #23173
    6 
    +mrs: !16259
    7 
    +
    8 
    +description: {
    9 
    +  References to boxed unlifted primitive values such as ``ByteArray#``,
    10 
    +  ``Array#`` or ``MVar#`` now carry pointer tag 1, like single-constructor
    11 
    +  data types. Together with this, GHC now enforces the invariant that the
    12 
    +  entry code of a taggable normal form is unreachable: entering such a
    13 
    +  closure prints a one-shot warning at runtime, or aborts the program when
    14 
    +  the new RTS flag ``--fatal-enter-taggable`` is given.
    15 
    +
    16 
    +  ``foreign import prim`` callees receive unlifted boxed arguments untagged
    17 
    +  and return unlifted boxed results with their pointer tag (1 for primitive
    18 
    +  objects). C code that obtains an unlifted boxed value, e.g. an ``MVar#``,
    19 
    +  through a ``StablePtr`` strips the tag before dereferencing the pointer.
    20 
    +}

  • compiler/GHC/Iface/Make.hs
    ... ... @@ -68,7 +68,6 @@ import GHC.Types.TyThing
    68 68 
     import GHC.Types.CompleteMatch
    69 69 
     import GHC.Types.Name.Cache
    70 70
    71 
    -import GHC.Utils.Outputable
    72 71 
     import GHC.Utils.Panic
    73 72 
     import GHC.Utils.Logger
    74 73 
     import GHC.Utils.Binary
    ... ... @@ -139,7 +138,12 @@ mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos stubs foreign_files
    139 138 
         -- value must carry the value's pointer tag, which needs its LambdaFormInfo),
    140 139 
         -- not an inlining pragma.  Attach it regardless of -fomit-interface-pragmas
    141 140 
         -- so imported value references are tagged at every optimisation level.
    142 
    -    let decls = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
    141 
    +    -- (At -O0 the code generator only conveys the correctness-relevant
    142 
    +    -- LFInfos; see generatedInfo in GHC.StgToCmm.)  CAF-info and tag sigs
    143 
    +    -- remain ordinary pragmas, omitted under -fomit-interface-pragmas.
    144 
    +    let omit_prags = gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
    145 
    +        mb_stg_infos' = if omit_prags then Nothing else mb_stg_infos
    146 
    +        decls = updateDecl (mi_decls partial_iface) mb_stg_infos' omit_prags mb_cmm_infos
    143 147
    144 148 
         -- See Note [Foreign stubs and TH bytecode linking]
    145 149 
         mi_simplified_core <- for (mi_simplified_core partial_iface) $ \simpl_core -> do
    ... ... @@ -189,13 +193,15 @@ shareIface nc compressionLevel mi = do
    189 193 
     initBinMemSize :: Int
    190 194 
     initBinMemSize = 1024 * 1024 -- 1 MB
    191 195
    192 
    -updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
    193 
    -updateDecl decls Nothing Nothing = decls
    194 
    -updateDecl decls m_stg_infos m_cmm_infos
    196 
    +updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Bool -> Maybe CmmCgInfos -> [IfaceDecl]
    197 
    +updateDecl decls Nothing _ Nothing = decls
    198 
    +updateDecl decls m_stg_infos omit_prags m_cmm_infos
    195 199 
       = map update_decl decls
    196 200 
       where
    197 201 
         (non_cafs,lf_infos) = maybe (mempty, mempty)
    198 
    -                                (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info))
    202 
    +                                (\cmm_info -> ( if omit_prags then mempty
    203 
    +                                                else ncs_nameSet (cgNonCafs cmm_info)
    204 
    +                                              , cgLFInfos cmm_info ))
    199 205 
                                     m_cmm_infos
    200 206 
         tag_sigs = fromMaybe mempty m_stg_infos
    201 207
    ... ... @@ -203,9 +209,8 @@ updateDecl decls m_stg_infos m_cmm_infos
    203 209 
           | let not_caffy = elemNameSet nm non_cafs
    204 210 
           , let mb_lf_info = lookupNameEnv lf_infos nm
    205 211 
           , let sig = lookupNameEnv tag_sigs nm
    206 
    -      -- NB: with LFInfo now attached at every optimisation level, a missing
    207 
    -      -- LFInfo is unremarkable (e.g. at -O0), so we do not trace it here.
    208 
    -      , warnPprTrace False "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True
    212 
    +        -- A missing LFInfo is unremarkable: at -O0 only the
    213 
    +        -- correctness-relevant LFInfos are conveyed (see GHC.StgToCmm).
    209 214 
             -- Only allocate a new IfaceId if we're going to update the infos
    210 215 
           , isJust mb_lf_info || not_caffy || isJust sig
    211 216 
           = IfaceId nm ty details $

  • compiler/GHC/StgToCmm.hs
    ... ... @@ -21,9 +21,11 @@ import GHC.StgToCmm.Utils
    21 21 
     import GHC.StgToCmm.Closure
    22 22 
     import GHC.StgToCmm.Config
    23 23 
     import GHC.StgToCmm.Ticky
    24 
    -import GHC.StgToCmm.Types (ModuleLFInfos)
    24 
    +import GHC.StgToCmm.Types (ModuleLFInfos, LambdaFormInfo(..))
    25 25 
     import GHC.StgToCmm.CgUtils (CgStream)
    26 26
    27 
    +import GHC.Platform.Profile (profileIsProfiling)
    28 
    +
    27 29 
     import GHC.Cmm
    28 30 
     import GHC.Cmm.Utils
    29 31 
     import GHC.Cmm.CLabel
    ... ... @@ -137,11 +139,21 @@ codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) tycons
    137 139 
                       !lf = cg_lf info
    138 140
    139 141 
                   -- LFInfo is part of the STG-ABI (a reference to an imported value
    140 
    -              -- must carry its pointer tag), not an inlining pragma, so collect
    141 
    -              -- it for every binding regardless of -fomit-interface-pragmas.
    142 
    -              -- (Only LFInfo is conveyed here, never unfoldings.)
    142 
    +              -- must carry its pointer tag), not an inlining pragma, so even
    143 
    +              -- under -fomit-interface-pragmas we must convey the LFInfos that
    144 
    +              -- pointer-tagging correctness depends on: values without entry
    145 
    +              -- code that may be entered (LFCon under the tag-test in
    146 
    +              -- emitEnter; LFScalar/LFPrim never). Functions and thunks are
    147 
    +              -- safely enterable, so their LFInfo remains a mere optimisation
    148 
    +              -- and is omitted at -O0 to keep interfaces small.
    149 
    +              keep_lf_info lf = case lf of
    150 
    +                LFCon{}  -> True
    151 
    +                LFScalar -> True
    152 
    +                LFPrim   -> True
    153 
    +                _        -> not (stgToCmmOmitIfPragmas cfg)
    143 154 
                   !generatedInfo
    144 
    -                = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
    155 
    +                = mkNameEnv [ i | i@(_, lf) <- Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)
    156 
    +                                , keep_lf_info lf ]
    145 157
    146 158 
             ; rn_mapping <- liftIO (readIORef uniqRnRef)
    147 159 
             ; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)
    ... ... @@ -370,15 +382,21 @@ cgDataCon mn data_con
    370 382 
                    ; tickyReturnOldCon (length arg_reps)
    371 383 
                    -- A taggable (small-family) normal form should never be entered:
    372 384 
                    -- every reference to it carries the constructor's pointer tag, so
    373 
    -               -- reaching this entry code is an invariant violation. We report it
    374 
    -               -- (aborting under +RTS --fatal-enter-taggable, otherwise warning once)
    375 
    -               -- and then self-return the value tagged with the constructor tag.
    385 
    +               -- reaching this entry code is an invariant violation. We jump to
    386 
    +               -- a shared RTS stub that reports it (aborting under +RTS
    387 
    +               -- --fatal-enter-taggable, otherwise warning once) and self-returns
    388 
    +               -- the value tagged with the constructor tag; sharing the stub keeps
    389 
    +               -- the per-constructor entry code to a single tail-jump.
    376 390 
                    -- Larger families have no spare tag, so their values are entered
    377 391 
                    -- as normal and the entry returns them tagged with the
    378 392 
                    -- family-saturating tag.
    379 
    -               ; when taggable $
    380 
    -                   emitCheckEnteredTaggable (showPprUnsafe data_con)
    381 
    -               ; void $ emitReturn
    382 
    -                   [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))]
    393 
    +               -- When profiling, entering tagged constructors is sanctioned:
    394 
    +               -- LDV profiling relies on it to mark closures as used (ENTER()
    395 
    +               -- in rts/include/Cmm.h does not shortcut on the tag), so the
    396 
    +               -- check would fire on every constructor use.
    397 
    +               ; if taggable && not (profileIsProfiling profile)
    398 
    +                   then emitJumpEnteredTaggable node
    399 
    +                   else void $ emitReturn
    400 
    +                     [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))]
    383 401 
                    }
    384 402 
             }

  • compiler/GHC/StgToCmm/Utils.hs
    ... ... @@ -10,7 +10,7 @@
    10 10 
     module GHC.StgToCmm.Utils (
    11 11 
             emitDataLits, emitRODataLits,
    12 12 
             emitDataCon,
    13 
    -        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, emitCheckEnteredTaggable,
    13 
    +        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, emitJumpEnteredTaggable,
    14 14 
             emitBarf,
    15 15 
             assignTemp, newTemp,
    16 16
    ... ... @@ -193,11 +193,16 @@ emitBarf msg = do
    193 193 
     -- Call from a taggable normal form's entry code (which the pointer-tagging
    194 194 
     -- invariant makes unreachable). It aborts under +RTS --fatal-enter-taggable and
    195 195 
     -- otherwise warns once; the entry then self-returns the tagged value.
    196 
    -emitCheckEnteredTaggable :: String -> FCode ()
    197 
    -emitCheckEnteredTaggable con = do
    198 
    -  strLbl <- newStringCLit con
    199 
    -  emitRtsCall rtsUnitId (fsLit "checkEnteredTaggable")
    200 
    -    [(CmmLit strLbl, AddrHint)] False
    196 
    +-- Tail-jump to the RTS's shared entry code for taggable normal forms
    197 
    +-- (stg_enteredTaggable in rts/StgMiscClosures.cmm), which reports the
    198 
    +-- invariant violation and self-returns the value tagged with its
    199 
    +-- constructor tag (both derived from the info table).
    200 
    +emitJumpEnteredTaggable :: CmmExpr -> FCode ()
    201 
    +emitJumpEnteredTaggable node = do
    202 
    +  profile   <- getProfile
    203 
    +  updfr_off <- getUpdFrameOff
    204 
    +  let lbl = mkCmmCodeLabel rtsUnitId (fsLit "stg_enteredTaggable")
    205 
    +  emit (mkJump profile NativeNodeCall (CmmLit (CmmLabel lbl)) [node] updfr_off)
    201 206
    202 207 
     emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
    203 208 
     emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) CmmMayReturn

  • libraries/ghc-internal/include/RtsIfaceSymbols.h
    ... ... @@ -59,6 +59,7 @@ CLOSURE(GHCziInternalziExceptionziType, underflowException_closure)
    59 59 
     CLOSURE(GHCziInternalziExceptionziType, overflowException_closure)
    60 60 
     INFO_TBL(GHCziInternalziCString, unpackCStringzh_info)
    61 61 
     INFO_TBL(GHCziInternalziCString, unpackCStringUtf8zh_info)
    62 
    +INFO_TBL(GHCziInternalziHeapziClosures, Box_con_info)
    62 63 
     #if defined(wasm32_HOST_ARCH) && defined(__PIC__)
    63 64 
     CLOSURE(GHCziInternalziWasmziPrimziImports, raiseJSException_closure)
    64 65 
     INFO_TBL(GHCziInternalziWasmziPrimziTypes, JSVal_con_info)

  • libraries/ghci/GHCi/ObjLink.hs
    ... ... @@ -302,6 +302,10 @@ isWindowsHost = False
    302 302 
     #endif
    303 303
    304 304 
     #if defined(wasm32_HOST_ARCH)
    305 
    +-- The wasm dynamic linker resolves symbols out of process, so the RTS
    306 
    +-- helper below is unavailable; looked-up constructor closures stay
    307 
    +-- untagged and forcing one triggers the (non-fatal) enter-taggable
    308 
    +-- warning.
    305 309 
     tagClosurePtr :: Ptr a -> Ptr a
    306 310 
     tagClosurePtr = id
    307 311 
     #else

  • rts/Prelude.h
    ... ... @@ -84,3 +84,4 @@ extern StgClosure ZCMain_main_closure;
    84 84 
     #define FunPtr_con_info           ghc_hs_iface->FunPtr_con_info
    85 85 
     #define StablePtr_static_info     ghc_hs_iface->StablePtr_static_info
    86 86 
     #define StablePtr_con_info        ghc_hs_iface->StablePtr_con_info
    87 
    +#define Box_con_info              ghc_hs_iface->Box_con_info

  • rts/RtsMessages.c
    ... ... @@ -88,9 +88,9 @@ checkEnteredTaggable(const char *con)
    88 88 
         ssbarf("entered a taggable normal form: %s", con);
    89 89 
         // ssbarf does not return
    90 90 
       }
    91 
    -  static int warned = 0;
    92 
    -  if (!warned) {
    93 
    -    warned = 1;
    91 
    +  static StgWord warned = 0;
    92 
    +  if (!RELAXED_LOAD(&warned)) {
    93 
    +    RELAXED_STORE(&warned, 1);
    94 94 
         debugBelch("warning: entered a taggable normal form: %s\n"
    95 95 
                    "(further occurrences suppressed; rerun with "
    96 96 
                    "+RTS --fatal-enter-taggable to abort)\n",
    ... ... @@ -98,6 +98,16 @@ checkEnteredTaggable(const char *con)
    98 98 
       }
    99 99 
     }
    100 100
    101 
    +// Backing for stg_enteredTaggable (StgMiscClosures.cmm), the shared entry
    102 
    +// code of taggable normal forms: report the violation and hand back the
    103 
    +// pointer retagged with its constructor tag so the entry can self-return.
    104 
    +StgClosure *
    105 
    +enteredTaggableClosure(StgClosure *p)
    106 
    +{
    107 
    +  checkEnteredTaggable(GET_CON_DESC(get_con_itbl(p)));
    108 
    +  return tagConstr(p);
    109 
    +}
    110 
    +
    101 111 
     void
    102 112 
     _assertFail(const char*filename, unsigned int linenum)
    103 113 
     {

  • rts/RtsSymbols.c
    ... ... @@ -542,7 +542,7 @@ extern char **environ;
    542 542 
           SymI_HasProto(barf)                                               \
    543 543 
           SymI_HasProto(sbarf)                                              \
    544 544 
           SymI_HasProto(ssbarf)                                             \
    545 
    -      SymI_HasProto(checkEnteredTaggable)                               \
    545 
    +      SymI_HasProto(stg_enteredTaggable)                                \
    546 546 
           SymI_HasProto(tagClosureIfConstr)                                 \
    547 547 
           SymI_HasProto(startEventLogging)                                  \
    548 548 
           SymI_HasProto(endEventLogging)                                    \

  • rts/StgMiscClosures.cmm
    ... ... @@ -103,6 +103,19 @@ INFO_TABLE_RET (stg_restore_cccs_eval, RET_SMALL, W_ info_ptr, W_ cccs)
    103 103 
         jump stg_ap_0_fast(ret);
    104 104 
     }
    105 105
    106 
    +/* Shared entry code for taggable normal forms, which the pointer-tagging
    107 
    +   invariant makes unreachable: every taggable data constructor's entry code
    108 
    +   tail-jumps here (see cgDataCon in GHC.StgToCmm) instead of carrying its own
    109 
    +   report call. Reports the violation (aborting under +RTS
    110 
    +   --fatal-enter-taggable, otherwise warning once) and self-returns the value
    111 
    +   tagged with its constructor tag; name and tag come from the info table. */
    112 
    +stg_enteredTaggable (P_ node)
    113 
    +{
    114 
    +    P_ tagged;
    115 
    +    (tagged) = ccall enteredTaggableClosure(node "ptr");
    116 
    +    return (tagged);
    117 
    +}
    118 
    +
    106 119 
     /* ----------------------------------------------------------------------------
    107 120 
        Support for the bytecode interpreter.
    108 121 
        ------------------------------------------------------------------------- */

  • rts/include/rts/Messages.h
    ... ... @@ -49,11 +49,15 @@ void pbarf(const char *fmt, void *p)
    49 49 
     void ssbarf(const char *fmt, const char *s)
    50 50 
        STG_NORETURN;
    51 51
    52 
    -/* Called from a taggable normal form's entry code (which the pointer-tagging
    53 
    -   invariant makes unreachable). Aborts under +RTS --fatal-enter-taggable, otherwise
    54 
    -   warns once and lets the entry self-return the tagged value. */
    52 
    +/* Report that a taggable normal form was entered (its entry code is
    53 
    +   unreachable under the pointer-tagging invariant). Aborts under +RTS
    54 
    +   --fatal-enter-taggable, otherwise warns once. */
    55 55 
     void checkEnteredTaggable(const char *con);
    56 56
    57 
    +/* Backing for stg_enteredTaggable: report the violation and return the
    58 
    +   closure pointer retagged with its constructor tag. */
    59 
    +StgClosure *enteredTaggableClosure(StgClosure *p);
    60 
    +
    57 61 
     // declared in Rts.h:
    58 62 
     // extern void _assertFail(const char *filename, unsigned int linenum)
    59 63 
     //    STG_NORETURN;

  • rts/include/rts/RtsToHsIface.h
    ... ... @@ -60,6 +60,7 @@ typedef struct {
    60 60 
         StgClosure *overflowException_closure;  // GHC.Internal.Exception.Type.overflowException_closure
    61 61 
         const StgInfoTable *unpackCStringzh_info;  // GHC.Internal.CString.unpackCStringzh_info
    62 62 
         const StgInfoTable *unpackCStringUtf8zh_info;  // GHC.Internal.CString.unpackCStringUtf8zh_info
    63 
    +    const StgInfoTable *Box_con_info;  // GHC.Internal.Heap.Closures.Box_con_info
    63 64 
     #if defined(wasm32_HOST_ARCH)
    64 65 
         StgClosure *raiseJSException_closure;  // GHC.Internal.Wasm.Prim.Imports.raiseJSException_closure
    65 66 
         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);
    477 477 
     RTS_FUN_DECL(stg_paniczh);
    478 478 
     RTS_FUN_DECL(stg_keepAlivezh);
    479 479 
     RTS_FUN_DECL(stg_absentErrorzh);
    480 
    +RTS_FUN_DECL(stg_enteredTaggable);
    480 481
    481 482 
     RTS_FUN_DECL(stg_newPromptTagzh);
    482 483 
     RTS_FUN_DECL(stg_promptzh);

  • rts/sm/Sanity.c
    ... ... @@ -25,6 +25,7 @@
    25 25 
     #include "Sanity.h"
    26 26 
     #include "Schedule.h"
    27 27 
     #include "Apply.h"
    28 
    +#include "Prelude.h"
    28 29 
     #include "Printer.h"
    29 30 
     #include "Arena.h"
    30 31 
     #include "RetainerProfile.h"
    ... ... @@ -42,6 +43,7 @@ int isHeapAlloced ( StgPtr p);
    42 43 
     static void  checkSmallBitmap    ( StgPtr payload, StgWord bitmap, uint32_t );
    43 44 
     static void  checkLargeBitmap    ( StgPtr payload, StgLargeBitmap*, uint32_t );
    44 45 
     static void  checkClosureShallow ( const StgClosure * );
    46 
    +static void  checkPtrTag         ( const StgClosure *, bool );
    45 47
    46 48 
     static void  checkCompactObjects (bdescr *bd);
    47 49
    ... ... @@ -72,6 +74,7 @@ checkSmallBitmap( StgPtr payload, StgWord bitmap, uint32_t size )
    72 74 
         for(i = 0; i < size; i++, bitmap >>= 1 ) {
    73 75 
             if ((bitmap & 1) == 0) {
    74 76 
                 checkClosureShallow((StgClosure *)payload[i]);
    77 
    +            checkPtrTag((StgClosure *)payload[i], false);
    75 78 
             }
    76 79 
         }
    77 80 
     }
    ... ... @@ -89,11 +92,126 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size )
    89 92 
             for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
    90 93 
                 if ((bitmap & 1) == 0) {
    91 94 
                     checkClosureShallow((StgClosure *)payload[i]);
    95 
    +                checkPtrTag((StgClosure *)payload[i], false);
    92 96 
                 }
    93 97 
             }
    94 98 
         }
    95 99 
     }
    96 100
    101 
    +/* Note [Sanity-checking pointer tags]
    102 
    + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    103 
    + * checkPtrTag asserts the pointer-tagging invariant (#23173) at rest: a
    104 
    + * pointer to a constructor carries its constructor tag (see tagConstr in
    105 
    + * ClosureMacros.h and get_iptr_tag in sm/Compact.c), and a pointer to a boxed
    106 
    + * unlifted primitive (MVar#, MutVar#, the arrays, ...) carries tag 1 (see
    107 
    + * Note [Pointer tagging of unlifted boxed primitives] in GHC.StgToCmm.Prim).
    108 
    + * The invariant is otherwise enforced only by crashing entry code, which
    109 
    + * catches a stripped tag only if the pointer is subsequently entered; this
    110 
    + * check catches tag-stripping pointer-rewriting paths (Evac, Compact,
    111 
    + * NonMovingShortcut, ...) mechanically on every sanity-checked GC.
    112 
    + *
    113 
    + * It is called only on user-level fields (stack bitmap slots, PAP/AP
    114 
    + * payloads, constructor/fun/thunk payloads, array elements, MutVar/TVar/MVar
    115 
    + * values, IND indirectees), because the RTS also holds internal untagged
    116 
    + * links. The rules exempt:
    117 
    + *
    118 
    + *  - static constructors: RTS sentinels (stg_END_TSO_QUEUE_closure, ...) are
    119 
    + *    CONSTR_NOCAFs that C code stores untagged, e.g. as an empty MVar's
    120 
    + *    value, so only heap-allocated constructors are checked;
    121 
    + *
    122 
    + *  - large-family constructors (con_tag >= TAG_MASK): tag is capped at
    123 
    + *    TAG_MASK, so no exact requirement is asserted;
    124 
    + *
    125 
    + *  - WEAK, TSO, STACK, BLOCKING_QUEUE, PRIM, MUT_PRIM: user-level references
    126 
    + *    (Weak#, ThreadId#, ...) to these are tagged, but legitimate untagged
    127 
    + *    RTS-internal links (weak_ptr_list, run queues, tso->_link, STM
    128 
    + *    structures) reach the same traversals;
    129 
    + *
    130 
    + *  - C_FINALIZER_LIST nodes: although their info table is a CONSTR, they
    131 
    + *    are RTS-internal. All references to them — StgWeak.cfinalizers and the
    132 
    + *    nodes' link fields — are untagged links built by stg_addCFinalizerToWeakzh
    133 
    + *    (PrimOps.cmm) and walked raw by runCFinalizers (Weak.c); user code never
    134 
    + *    holds a reference to one. (The compacting GC preserves untaggedness:
    135 
    + *    unthread re-applies get_iptr_tag only to originally-tagged references.)
    136 
    + *
    137 
    + *  - fields of ghc-heap's Box (GHC.Internal.Heap.Closures): `data Box = Box
    138 
    + *    Any` wraps a pointer word captured verbatim by heap/stack introspection
    139 
    + *    (unpackClosure#, ghc-heap's stack decoding), so it carries whatever tag
    140 
    + *    the source bits had — possibly none. Box is recognized via
    141 
    + *    ghc_hs_iface->Box_con_info, NULL-guarded since sanity checks can run
    142 
    + *    before ghc-internal registers the interface;
    143 
    + *
    144 
    + *  - BLACKHOLE indirectees (no call site on that field): tag 0 there means
    145 
    + *    "not yet updated". Plain IND indirectees are checked;
    146 
    + *
    147 
    + *  - bitmap-walked slots (stack frames, PAP/AP payloads; heap_field =
    148 
    + *    false): hand-written Cmm legitimately stores untagged pointers there.
    149 
    + *    Codegen untags unlifted boxed primop arguments at the Cmm call
    150 
    + *    boundary, and generic RTS frames save those already-untagged arguments
    151 
    + *    on the stack (the stg_block_{take,read,put}mvar frames and the
    152 
    + *    stg_gc_prim_* heap-check-retry frames in HeapStackCheck.cmm); Cmm code
    153 
    + *    also keeps deliberately untagged working pointers live across calls
    154 
    + *    (e.g. stg_compactAddWorkerzh's "p"), landing them in return-frame
    155 
    + *    slots. Such slots hence get no constructor rule, and the unlifted-
    156 
    + *    primitive rule is relaxed to tag 0-or-1 (still catching corrupt tags).
    157 
    + *    The strict rules apply to heap fields, where all the tag-stripping GC
    158 
    + *    bugs lived.
    159 
    + */
    160 
    +static void
    161 
    +checkPtrTag( const StgClosure *q, bool heap_field )
    162 
    +{
    163 
    +    const StgClosure *p = UNTAG_CONST_CLOSURE(q);
    164 
    +    const StgInfoTable *raw_info = ACQUIRE_LOAD(&p->header.info);
    165 
    +    if (IS_FORWARDING_PTR(raw_info)) return;
    166 
    +    const StgInfoTable *info = INFO_PTR_TO_STRUCT(raw_info);
    167 
    +
    168 
    +    switch (info->type) {
    169 
    +    case CONSTR:
    170 
    +    case CONSTR_1_0:
    171 
    +    case CONSTR_0_1:
    172 
    +    case CONSTR_2_0:
    173 
    +    case CONSTR_1_1:
    174 
    +    case CONSTR_0_2:
    175 
    +    case CONSTR_NOCAF:
    176 
    +    {
    177 
    +        // RTS-internal untagged links; see the C_FINALIZER_LIST bullet in
    178 
    +        // Note [Sanity-checking pointer tags].
    179 
    +        if (raw_info == &stg_C_FINALIZER_LIST_info) {
    180 
    +            break;
    181 
    +        }
    182 
    +        StgWord con_tag = (StgWord)info->srt + 1;
    183 
    +        if (heap_field && con_tag <= TAG_MASK && HEAP_ALLOCED((StgPtr)p)) {
    184 
    +            ASSERT(GET_CLOSURE_TAG(q) == con_tag);
    185 
    +        }
    186 
    +        break;
    187 
    +    }
    188 
    +
    189 
    +    case ARR_WORDS:
    190 
    +    case MUT_ARR_PTRS_CLEAN:
    191 
    +    case MUT_ARR_PTRS_DIRTY:
    192 
    +    case MUT_ARR_PTRS_FROZEN_CLEAN:
    193 
    +    case MUT_ARR_PTRS_FROZEN_DIRTY:
    194 
    +    case SMALL_MUT_ARR_PTRS_CLEAN:
    195 
    +    case SMALL_MUT_ARR_PTRS_DIRTY:
    196 
    +    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    197 
    +    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
    198 
    +    case MUT_VAR_CLEAN:
    199 
    +    case MUT_VAR_DIRTY:
    200 
    +    case MVAR_CLEAN:
    201 
    +    case MVAR_DIRTY:
    202 
    +    case TVAR:
    203 
    +        if (heap_field) {
    204 
    +            ASSERT(GET_CLOSURE_TAG(q) == 1);
    205 
    +        } else {
    206 
    +            ASSERT(GET_CLOSURE_TAG(q) <= 1);
    207 
    +        }
    208 
    +        break;
    209 
    +
    210 
    +    default:
    211 
    +        break;
    212 
    +    }
    213 
    +}
    214 
    +
    97 215 
     /*
    98 216 
      * check that it looks like a valid closure - without checking its payload
    99 217 
      * used to avoid recursion between checking PAPs and checking stack
    ... ... @@ -102,6 +220,8 @@ checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap, uint32_t size )
    102 220 
     static void
    103 221 
     checkClosureShallow( const StgClosure* p )
    104 222 
     {
    223 
    +    // No checkPtrTag here: checkCompactObjects calls this on raw
    224 
    +    // (necessarily untagged) object addresses, not on stored pointers.
    105 225 
         ASSERT(LOOKS_LIKE_CLOSURE_PTR(UNTAG_CONST_CLOSURE(p)));
    106 226 
     }
    107 227
    ... ... @@ -129,10 +249,12 @@ checkStackFrame( StgPtr c )
    129 249 
         case STOP_FRAME:
    130 250 
         case RET_SMALL:
    131 251 
         case ANN_FRAME:
    252 
    +    {
    132 253 
             size = BITMAP_SIZE(info->i.layout.bitmap);
    133 254 
             checkSmallBitmap((StgPtr)c + 1,
    134 255 
                              BITMAP_BITS(info->i.layout.bitmap), size);
    135 256 
             return 1 + size;
    257 
    +    }
    136 258
    137 259 
         case RET_BCO: {
    138 260 
             StgBCO *bco;
    ... ... @@ -377,6 +499,8 @@ checkClosure( const StgClosure* p )
    377 499 
             ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->head));
    378 500 
             ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->tail));
    379 501 
             ASSERT(LOOKS_LIKE_CLOSURE_PTR(mvar->value));
    502 
    +        // head/tail are RTS-internal TSO queue links; only value is user-level
    503 
    +        checkPtrTag(mvar->value, true);
    380 504 
             return sizeofW(StgMVar);
    381 505 
           }
    382 506
    ... ... @@ -390,6 +514,7 @@ checkClosure( const StgClosure* p )
    390 514 
             uint32_t i;
    391 515 
             for (i = 0; i < info->layout.payload.ptrs; i++) {
    392 516 
               ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgThunk *)p)->payload[i]));
    517 
    +          checkPtrTag(((StgThunk *)p)->payload[i], true);
    393 518 
             }
    394 519 
             return thunk_sizeW_fromITBL(info);
    395 520 
           }
    ... ... @@ -407,14 +532,33 @@ checkClosure( const StgClosure* p )
    407 532 
         case CONSTR_1_1:
    408 533 
         case CONSTR_0_2:
    409 534 
         case CONSTR_2_0:
    410 
    -    case BLACKHOLE:
    411 
    -    case PRIM:
    412 
    -    case MUT_PRIM:
    413 535 
         case MUT_VAR_CLEAN:
    414 536 
         case MUT_VAR_DIRTY:
    415 537 
         case TVAR:
    416 538 
         case THUNK_STATIC:
    417 539 
         case FUN_STATIC:
    540 
    +        {
    541 
    +            // ghc-heap's Box holds a raw captured pointer word; see the Box
    542 
    +            // bullet in Note [Sanity-checking pointer tags].
    543 
    +            bool box = ghc_hs_iface != NULL
    544 
    +                && ACQUIRE_LOAD(&p->header.info) == Box_con_info;
    545 
    +            uint32_t i;
    546 
    +            for (i = 0; i < info->layout.payload.ptrs; i++) {
    547 
    +                ASSERT(LOOKS_LIKE_CLOSURE_PTR(p->payload[i]));
    548 
    +                if (!box) {
    549 
    +                    checkPtrTag(p->payload[i], true);
    550 
    +                }
    551 
    +            }
    552 
    +            return sizeW_fromITBL(info);
    553 
    +        }
    554 
    +
    555 
    +    // As above, but without checkPtrTag: a BLACKHOLE indirectee legitimately
    556 
    +    // carries tag 0 ("not yet updated"), and PRIM/MUT_PRIM/COMPACT_NFDATA
    557 
    +    // payloads are RTS-internal links.
    558 
    +    // See Note [Sanity-checking pointer tags].
    559 
    +    case BLACKHOLE:
    560 
    +    case PRIM:
    561 
    +    case MUT_PRIM:
    418 562 
         case COMPACT_NFDATA:
    419 563 
             {
    420 564 
                 uint32_t i;
    ... ... @@ -480,6 +624,7 @@ checkClosure( const StgClosure* p )
    480 624 
                  */
    481 625 
                 StgInd *ind = (StgInd *)p;
    482 626 
                 ASSERT(LOOKS_LIKE_CLOSURE_PTR(ind->indirectee));
    627 
    +            checkPtrTag(ind->indirectee, true);
    483 628 
                 return sizeofW(StgInd);
    484 629 
             }
    485 630
    ... ... @@ -529,6 +674,7 @@ checkClosure( const StgClosure* p )
    529 674 
                 uint32_t i;
    530 675 
                 for (i = 0; i < a->ptrs; i++) {
    531 676 
                     ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
    677 
    +                checkPtrTag(a->payload[i], true);
    532 678 
                 }
    533 679 
                 return mut_arr_ptrs_sizeW(a);
    534 680 
             }
    ... ... @@ -541,6 +687,7 @@ checkClosure( const StgClosure* p )
    541 687 
                 StgSmallMutArrPtrs *a = (StgSmallMutArrPtrs *)p;
    542 688 
                 for (uint32_t i = 0; i < a->ptrs; i++) {
    543 689 
                     ASSERT(LOOKS_LIKE_CLOSURE_PTR(a->payload[i]));
    690 
    +                checkPtrTag(a->payload[i], true);
    544 691 
                 }
    545 692 
                 return small_mut_arr_ptrs_sizeW(a);
    546 693 
             }

  • rts/wasm/JSFFI.c
    ... ... @@ -297,7 +297,9 @@ __attribute__((export_name("rts_promiseThrowTo")))
    297 297 
     void rts_promiseThrowTo(HsStablePtr, HsJSVal);
    298 298 
     void rts_promiseThrowTo(HsStablePtr sp, HsJSVal js_err) {
    299 299 
       Capability *cap = &MainCapability;
    300 
    -  StgWeak *w = (StgWeak *)deRefStablePtr(sp);
    300 
    +  // Weak# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed
    301 
    +  // primitives] in GHC.StgToCmm.Prim. (The key field is stored untagged.)
    302 
    +  StgWeak *w = (StgWeak *)UNTAG_CLOSURE((StgClosure *)deRefStablePtr(sp));
    301 303 
       if (w->header.info == &stg_DEAD_WEAK_info) {
    302 304 
         return;
    303 305 
       }

  • testsuite/tests/codeGen/should_compile/T21710a.stderr
    ... ... @@ -53,35 +53,34 @@
    53 53 
              }
    54 54 
          {offset
    55 55 
            cqw: // global
    56 
    -           if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy;   // CmmCondBranch
    56 
    +           if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy;
    57 57 
            cqx: // global
    58 
    -           R1 = M.foo_closure;   // CmmAssign
    59 
    -           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;   // CmmCall
    58 
    +           R1 = M.foo_closure;
    59 
    +           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
    60 60 
            cqy: // global
    61 
    -           I64[Sp - 8] = cqo;   // CmmStore
    62 
    -           R1 = R2;   // CmmAssign
    63 
    -           Sp = Sp - 8;   // CmmAssign
    64 
    -           if (R1 & 7 != 0) goto cqo; else goto cqp;   // CmmCondBranch
    61 
    +           I64[Sp - 8] = cqo;
    62 
    +           R1 = R2;
    63 
    +           Sp = Sp - 8;
    64 
    +           if (R1 & 7 != 0) goto cqo; else goto cqp;
    65 65 
            cqp: // global
    66 
    -           call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8;   // CmmCall
    66 
    +           call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8;
    67 67 
            cqo: // global
    68 
    -           _cqv::P64 = R1 & 7;   // CmmAssign
    69 
    -           if (_cqv::P64 != 1) goto n0; else goto cqt;   // CmmCondBranch
    68 
    +           _cqv::P64 = R1 & 7;
    69 
    +           if (_cqv::P64 != 1) goto n0; else goto cqt;
    70 70 
            n0: // global
    71 
    -           if (_cqv::P64 != 2) goto cqs; else goto cqu;   // CmmCondBranch
    71 
    +           if (_cqv::P64 != 2) goto cqs; else goto cqu;
    72 72 
            cqs: // global
    73 
    -           // dataToTagSmall#
    74 
    -           R1 = R1 & 7 - 1;   // CmmAssign
    75 
    -           Sp = Sp + 8;   // CmmAssign
    76 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    73 
    +           R1 = R1 & 7 - 1;
    74 
    +           Sp = Sp + 8;
    75 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    77 76 
            cqu: // global
    78 
    -           R1 = 42;   // CmmAssign
    79 
    -           Sp = Sp + 8;   // CmmAssign
    80 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    77 
    +           R1 = 42;
    78 
    +           Sp = Sp + 8;
    79 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    81 80 
            cqt: // global
    82 
    -           R1 = 2;   // CmmAssign
    83 
    -           Sp = Sp + 8;   // CmmAssign
    84 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    81 
    +           R1 = 2;
    82 
    +           Sp = Sp + 8;
    83 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    85 84 
          }
    86 85 
      },
    87 86 
      section ""data" . M.foo_closure" {
    ... ... @@ -92,27 +91,7 @@
    92 91
    93 92
    94 93 
     ==================== Output Cmm ====================
    95 
    -[section ""cstring" . cqJ_str" {
    96 
    -     cqJ_str:
    97 
    -         I8[] "A"
    98 
    - },
    99 
    - section ""cstring" . cqL_str" {
    100 
    -     cqL_str:
    101 
    -         I8[] "B"
    102 
    - },
    103 
    - section ""cstring" . cqN_str" {
    104 
    -     cqN_str:
    105 
    -         I8[] "C"
    106 
    - },
    107 
    - section ""cstring" . cqP_str" {
    108 
    -     cqP_str:
    109 
    -         I8[] "D"
    110 
    - },
    111 
    - section ""cstring" . cqR_str" {
    112 
    -     cqR_str:
    113 
    -         I8[] "E"
    114 
    - },
    115 
    - section ""relreadonly" . M.E_closure_tbl" {
    94 
    +[section ""relreadonly" . M.E_closure_tbl" {
    116 95 
          M.E_closure_tbl:
    117 96 
              const M.A_closure+1;
    118 97 
              const M.B_closure+2;
    ... ... @@ -121,73 +100,63 @@
    121 100 
              const M.E_closure+5;
    122 101 
      },
    123 102 
      M.A_con_entry() { //  []
    124 
    -         { info_tbls: [(cqK,
    103 
    +         { info_tbls: [(cqJ,
    125 104 
                             label: M.A_con_info
    126 105 
                             rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} }
    127 106 
                             srt: Nothing)]
    128 107 
                stack_info: arg_space: 8
    129 108 
              }
    130 109 
          {offset
    131 
    -       cqK: // global
    132 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqJ_str);   // CmmUnsafeForeignCall
    133 
    -           R1 = R1 + 1;   // CmmAssign
    134 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    110 
    +       cqJ: // global
    111 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    135 112 
          }
    136 113 
      },
    137 114 
      M.B_con_entry() { //  []
    138 
    -         { info_tbls: [(cqM,
    115 
    +         { info_tbls: [(cqK,
    139 116 
                             label: M.B_con_info
    140 117 
                             rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} }
    141 118 
                             srt: Nothing)]
    142 119 
                stack_info: arg_space: 8
    143 120 
              }
    144 121 
          {offset
    145 
    -       cqM: // global
    146 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqL_str);   // CmmUnsafeForeignCall
    147 
    -           R1 = R1 + 2;   // CmmAssign
    148 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    122 
    +       cqK: // global
    123 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    149 124 
          }
    150 125 
      },
    151 126 
      M.C_con_entry() { //  []
    152 
    -         { info_tbls: [(cqO,
    127 
    +         { info_tbls: [(cqL,
    153 128 
                             label: M.C_con_info
    154 129 
                             rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} }
    155 130 
                             srt: Nothing)]
    156 131 
                stack_info: arg_space: 8
    157 132 
              }
    158 133 
          {offset
    159 
    -       cqO: // global
    160 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqN_str);   // CmmUnsafeForeignCall
    161 
    -           R1 = R1 + 3;   // CmmAssign
    162 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    134 
    +       cqL: // global
    135 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    163 136 
          }
    164 137 
      },
    165 138 
      M.D_con_entry() { //  []
    166 
    -         { info_tbls: [(cqQ,
    139 
    +         { info_tbls: [(cqM,
    167 140 
                             label: M.D_con_info
    168 141 
                             rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} }
    169 142 
                             srt: Nothing)]
    170 143 
                stack_info: arg_space: 8
    171 144 
              }
    172 145 
          {offset
    173 
    -       cqQ: // global
    174 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqP_str);   // CmmUnsafeForeignCall
    175 
    -           R1 = R1 + 4;   // CmmAssign
    176 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    146 
    +       cqM: // global
    147 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    177 148 
          }
    178 149 
      },
    179 150 
      M.E_con_entry() { //  []
    180 
    -         { info_tbls: [(cqS,
    151 
    +         { info_tbls: [(cqN,
    181 152 
                             label: M.E_con_info
    182 153 
                             rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} }
    183 154 
                             srt: Nothing)]
    184 155 
                stack_info: arg_space: 8
    185 156 
              }
    186 157 
          {offset
    187 
    -       cqS: // global
    188 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqR_str);   // CmmUnsafeForeignCall
    189 
    -           R1 = R1 + 5;   // CmmAssign
    190 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    158 
    +       cqN: // global
    159 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    191 160 
          }
    192 161 
      }]
    193 162

  • testsuite/tests/codeGen/should_run/T23173a.hs
    1 
    +module Main where
    2 
    +
    3 
    +import T23173a_A
    4 
    +
    5 
    +-- Cases on an imported evaluated constructor at -O0. With LFCon conveyed in
    6 
    +-- the interface the reference is tagged and never entered; without it the
    7 
    +-- scrutinee is entered and --fatal-enter-taggable aborts.
    8 
    +main :: IO ()
    9 
    +main = case x of
    10 
    +  Just b  -> print b
    11 
    +  Nothing -> putStrLn "nothing"

  • testsuite/tests/codeGen/should_run/T23173a.stdout
    1 
    +True

  • testsuite/tests/codeGen/should_run/T23173a_A.hs
    1 
    +module T23173a_A where
    2 
    +
    3 
    +-- A statically evaluated constructor value. Its interface must carry LFCon
    4 
    +-- even at -O0 (where -fomit-interface-pragmas is on), so importers tag
    5 
    +-- references to it. See Note [Pointer tagging of unlifted boxed primitives]
    6 
    +-- in GHC.StgToCmm.Prim and mkFullIface in GHC.Iface.Make.
    7 
    +x :: Maybe Bool
    8 
    +x = Just True

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -172,6 +172,8 @@ test('T12622', normal, multimod_compile_and_run, ['T12622', '-O'])
    172 172 
     # present even at -O0) and survives hs-boot indirections.  Compiled at -O0,
    173 173 
     # where a dropped tag manifests.
    174 174 
     test('T24136', normal, multimod_compile_and_run, ['T24136', ''])
    175 
    +test('T23173a', extra_run_opts('+RTS --fatal-enter-taggable -RTS'),
    176 
    +     multimod_compile_and_run, ['T23173a', ''])
    175 177 
     test('T12757', normal, compile_and_run, [''])
    176 178 
     test('T12855', normal, compile_and_run, [''])
    177 179 
     test('T9577', [ unless(arch('x86_64') or arch('i386'),skip),

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/3f7072d7e2d356829a3278794de53783e1109642...b9c373984dcc297d239282d903c3dbfe085f1d08 at 1785518217