Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC

Commits:

13 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 
    +}

  • compiler/GHC/CmmToAsm/Config.hs
    ... ... @@ -14,6 +14,7 @@ import GHC.Cmm.Type (Width(..))
    14 14 
     import GHC.Cmm.CLabel (CLabel, hasHaskellName)
    15 15 
     import GHC.CmmToAsm.CFG.Weight
    16 16 
     import GHC.Unit.Module (Module)
    17 
    +import GHC.Types.Name (isBootIndName)
    17 18 
     import GHC.Types.Name.Set (NameSet, elemNameSet)
    18 19 
     import GHC.Utils.Outputable
    19 20
    ... ... @@ -66,12 +67,13 @@ data NCGConfig = NCGConfig
    66 67 
     -- | May a static indirection labelled @symbol@ be eliminated by redirecting it
    67 68 
     -- to its indirectee (the @.equiv@ trick, see Note [emit-time elimination of
    68 69 
     -- static indirections] in "GHC.Cmm.CLabel")?  No, if @symbol@ is exported by
    69 
    --- this module's hs-boot file: SOURCE importers reference it untagged and must be
    70 
    +-- this module's hs-boot file, or is itself a boot indirection ('mkBootIndName'
    71 
    +-- in "GHC.Types.Name"): SOURCE importers reference it untagged and must be
    70 72 
     -- able to enter it to obtain the (tagged) indirectee.
    71 73 
     ncgLabelMayBeRedirected :: NCGConfig -> CLabel -> Bool
    72 74 
     ncgLabelMayBeRedirected config symbol =
    73 75 
       case hasHaskellName symbol of
    74 
    -    Just nm -> not (nm `elemNameSet` ncgBootExports config)
    76 
    +    Just nm -> not (isBootIndName nm || nm `elemNameSet` ncgBootExports config)
    75 77 
         Nothing -> True
    76 78
    77 79 
     -- | Return Word size

  • compiler/GHC/CmmToLlvm/Config.hs
    ... ... @@ -12,6 +12,7 @@ import GHC.Prelude
    12 12 
     import GHC.Platform
    13 13
    14 14 
     import GHC.Cmm.CLabel (CLabel, hasHaskellName)
    15 
    +import GHC.Types.Name (isBootIndName)
    15 16 
     import GHC.Types.Name.Set (NameSet, elemNameSet)
    16 17 
     import GHC.Utils.Outputable
    17 18 
     import GHC.Settings.Utils
    ... ... @@ -40,13 +41,14 @@ data LlvmCgConfig = LlvmCgConfig
    40 41 
     -- | May a static indirection labelled @symbol@ be eliminated by redirecting it
    41 42 
     -- to its indirectee (the alias trick, see Note [emit-time elimination of static
    42 43 
     -- indirections] in "GHC.Cmm.CLabel")?  No, if @symbol@ is exported by this
    43 
    --- module's hs-boot file: SOURCE importers reference it untagged and must be able
    44 
    +-- module's hs-boot file, or is itself a boot indirection ('mkBootIndName' in
    45 
    +-- "GHC.Types.Name"): SOURCE importers reference it untagged and must be able
    44 46 
     -- to enter it to obtain the (tagged) indirectee. Mirrors 'ncgLabelMayBeRedirected'
    45 47 
     -- in "GHC.CmmToAsm.Config".
    46 48 
     llvmLabelMayBeRedirected :: LlvmCgConfig -> CLabel -> Bool
    47 49 
     llvmLabelMayBeRedirected config symbol =
    48 50 
       case hasHaskellName symbol of
    49 
    -    Just nm -> not (nm `elemNameSet` llvmCgBootExports config)
    51 
    +    Just nm -> not (isBootIndName nm || nm `elemNameSet` llvmCgBootExports config)
    50 52 
         Nothing -> True
    51 53
    52 54 
     data LlvmTarget = LlvmTarget

  • 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)
    ... ... @@ -376,7 +388,11 @@ cgDataCon mn data_con
    376 388 
                    -- Larger families have no spare tag, so their values are entered
    377 389 
                    -- as normal and the entry returns them tagged with the
    378 390 
                    -- family-saturating tag.
    379 
    -               ; when taggable $
    391 
    +               -- When profiling, entering tagged constructors is sanctioned:
    392 
    +               -- LDV profiling relies on it to mark closures as used (ENTER()
    393 
    +               -- in rts/include/Cmm.h does not shortcut on the tag), so the
    394 
    +               -- check would fire on every constructor use.
    395 
    +               ; when (taggable && not (profileIsProfiling profile)) $
    380 396 
                        emitCheckEnteredTaggable (showPprUnsafe data_con)
    381 397 
                    ; void $ emitReturn
    382 398 
                        [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))]

  • compiler/GHC/StgToCmm/Env.hs
    ... ... @@ -45,6 +45,8 @@ import GHC.Types.Var.Env
    45 45 
     import GHC.Utils.Outputable
    46 46 
     import GHC.Utils.Panic
    47 47
    48 
    +import Data.Maybe (isNothing)
    49 
    +
    48 50 
     import GHC.Builtin.Names (getUnique)
    49 51
    50 52
    ... ... @@ -151,7 +153,12 @@ getCgIdInfo id
    151 153 
                   -- cgTopBinding, so no indirection exists for them; reference them
    152 154 
                   -- directly. See Note [Boot-exported constructors and pointer
    153 155 
                   -- tagging] in "GHC.StgToCmm.DataCon".
    156 
    +              -- If the Id does carry LFInfo (its real interface got loaded for
    157 
    +              -- some other reason), reference the value's own closure with its
    158 
    +              -- proper tag: diverting would combine that tag with the
    159 
    +              -- indirection's symbol, mistagging an IND_STATIC.
    154 160 
                   use_boot_ind = needsBootInd id
    161 
    +                          && isNothing (idLFInfo_maybe id)
    155 162 
                               && not (isDataConWorkId id)
    156 163 
                               && nameModule name `elemModuleSet` stgToCmmSourceImports cfg
    157 164 
             ; if isExternalName name then

  • compiler/GHC/Types/Name.hs
    ... ... @@ -47,7 +47,7 @@ module GHC.Types.Name (
    47 47 
             mkInternalName, mkClonedInternalName, mkDerivedInternalName,
    48 48 
             mkSystemVarName, mkSysTvName,
    49 49 
             mkFCallName,
    50 
    -        mkExternalName, mkWiredInName, mkBootIndName,
    50 
    +        mkExternalName, mkWiredInName, mkBootIndName, isBootIndName,
    51 51
    52 52 
             -- ** Manipulating and deconstructing 'Name's
    53 53 
             nameUnique, setNameUnique,
    ... ... @@ -545,9 +545,20 @@ mkExternalName uniq mod occ loc
    545 545 
     -- pointer tagging] in "GHC.StgToCmm.DataCon".
    546 546 
     mkBootIndName :: Name -> Name
    547 547 
     mkBootIndName name =
    548 
    -  mkExternalName (nameUnique name) (nameModule name)
    548 
    +  -- Retag the unique rather than reuse it: reusing would make the indirection's
    549 
    +  -- Name (and hence its CLabels) equal to the original's under Eq (by unique)
    550 
    +  -- yet distinct under Ord (stableNameCmp, by occ). Retagging stays
    551 
    +  -- deterministic, so the external symbol is still a pure function of module
    552 
    +  -- and occurrence.
    553 
    +  mkExternalName (newTagUnique (nameUnique name) BootIndTag) (nameModule name)
    549 554 
                      (mkBootIndOcc (nameOccName name)) (nameSrcSpan name)
    550 555
    556 
    +-- | Is this a name made by 'mkBootIndName'? Recognised by its unique's tag,
    557 
    +-- so it works on names reconstructed from labels as well.
    558 
    +isBootIndName :: Name -> Bool
    559 
    +isBootIndName name = case unpkUnique (nameUnique name) of
    560 
    +  (tag, _) -> tag == BootIndTag
    561 
    +
    551 562 
     -- | Create a name which is actually defined by the compiler itself
    552 563 
     mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
    553 564 
     {-# INLINE mkWiredInName #-}

  • compiler/GHC/Types/Unique.hs
    ... ... @@ -133,6 +133,7 @@ data UniqueTag
    133 133 
       = AlphaTyVarTag
    134 134 
       | BcoTag
    135 135 
       | BlockIdTag
    136 
    +  | BootIndTag
    136 137 
       | BoxedTupleDataTag
    137 138 
       | BoxedTupleTyConTag
    138 139 
       | BoxingTyConTag
    ... ... @@ -184,6 +185,7 @@ uniqueTag :: UniqueTag -> Char
    184 185 
     uniqueTag AlphaTyVarTag        = '1'
    185 186 
     uniqueTag BcoTag               = 'I'
    186 187 
     uniqueTag BlockIdTag           = 'L'
    188 
    +uniqueTag BootIndTag           = 'h'
    187 189 
     uniqueTag BoxedTupleDataTag    = '7'
    188 190 
     uniqueTag BoxedTupleTyConTag   = '4'
    189 191 
     uniqueTag BoxingTyConTag       = 'b'
    ... ... @@ -253,6 +255,7 @@ charToUniqueTag 'D' = DsTag
    253 255 
     charToUniqueTag 'E' = PseudoTag
    254 256 
     charToUniqueTag 'f' = FldNSTag
    255 257 
     charToUniqueTag 'g' = StgPTag
    258 
    +charToUniqueTag 'h' = BootIndTag
    256 259 
     charToUniqueTag 'H' = VirtualRegTag
    257 260 
     charToUniqueTag 'i' = IfaceTag
    258 261 
     charToUniqueTag 'I' = BcoTag

  • libraries/ghc-internal/cbits/StackCloningDecoding.cmm
    ... ... @@ -9,7 +9,8 @@ stg_cloneMyStackzh () {
    9 9
    10 10 
         ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr");
    11 11
    12 
    -    return (clonedStack);
    12 
    +    // Boxed unlifted primitives are tagged with 1.
    13 
    +    return (clonedStack + 1);
    13 14 
     }
    14 15
    15 16 
     stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) {

  • 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/Compact.cmm
    ... ... @@ -143,7 +143,7 @@ eval:
    143 143 
         case ARR_WORDS: {
    144 144
    145 145 
             (should) = ccall shouldCompact(compact "ptr", p "ptr");
    146 
    -        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
    146 
    +        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); }
    147 147 
             if (should == SHOULDCOMPACT_PINNED) {
    148 148 
                 jump stg_raisezh(HsIface_cannotCompactPinned_closure(W_[ghc_hs_iface]));
    149 149 
             }
    ... ... @@ -154,7 +154,7 @@ eval:
    154 154 
             W_ size;
    155 155 
             size = SIZEOF_StgArrBytes + StgArrBytes_bytes(p);
    156 156 
             ALLOCATE(compact, ROUNDUP_BYTES_TO_WDS(size), p, to, tag);
    157 
    -        P_[pp] = to;
    157 
    +        P_[pp] = tag | to;
    158 158 
             prim %memcpy(to, p, size, 1);
    159 159 
             return();
    160 160 
         }
    ... ... @@ -164,7 +164,7 @@ eval:
    164 164 
             MUT_ARR_PTRS_FROZEN_CLEAN: {
    165 165
    166 166 
             (should) = ccall shouldCompact(compact "ptr", p "ptr");
    167 
    -        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
    167 
    +        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); }
    168 168
    169 169 
             CHECK_HASH();
    170 170
    ... ... @@ -196,7 +196,7 @@ eval:
    196 196 
             SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: {
    197 197
    198 198 
             (should) = ccall shouldCompact(compact "ptr", p "ptr");
    199 
    -        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
    199 
    +        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = tag | p; return(); }
    200 200
    201 201 
             CHECK_HASH();
    202 202
    ... ... @@ -459,5 +459,6 @@ stg_compactFixupPointerszh ( W_ first_block, W_ root )
    459 459 
         // guaranteed to be valid
    460 460 
         // (this is true even if the fixup phase failed)
    461 461 
         gcstr = str;
    462 
    -    return (gcstr, ok);
    462 
    +    // Boxed unlifted primitives are tagged with 1.
    463 
    +    return (gcstr + 1, ok);
    463 464 
     }

  • 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",

  • rts/sm/Compact.c
    ... ... @@ -122,6 +122,30 @@ get_iptr_tag(StgInfoTable *iptr)
    122 122 
             }
    123 123 
         }
    124 124
    125 
    +    // Boxed unlifted primitives are tagged with 1 (see Note [Pointer tagging
    126 
    +    // of unlifted boxed primitives] in GHC.StgToCmm.Prim). unthread() applies
    127 
    +    // this tag only to fields that were tagged before threading, so a type
    128 
    +    // listed here never gains a tag it did not have.
    129 
    +    case ARR_WORDS:
    130 
    +    case MUT_ARR_PTRS_CLEAN:
    131 
    +    case MUT_ARR_PTRS_DIRTY:
    132 
    +    case MUT_ARR_PTRS_FROZEN_CLEAN:
    133 
    +    case MUT_ARR_PTRS_FROZEN_DIRTY:
    134 
    +    case SMALL_MUT_ARR_PTRS_CLEAN:
    135 
    +    case SMALL_MUT_ARR_PTRS_DIRTY:
    136 
    +    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
    137 
    +    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
    138 
    +    case MUT_VAR_CLEAN:
    139 
    +    case MUT_VAR_DIRTY:
    140 
    +    case MVAR_CLEAN:
    141 
    +    case MVAR_DIRTY:
    142 
    +    case TVAR:
    143 
    +    case WEAK:
    144 
    +    case PRIM:
    145 
    +    case MUT_PRIM:
    146 
    +    case BLOCKING_QUEUE:
    147 
    +        return 1;
    148 
    +
    125 149 
         default:
    126 150 
             return 0;
    127 151 
         }

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help