GitLab

Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC

Commits:

696e1f80

by Rodrigo Mesquita at 2025-12-19T20:05:07+00:00

Where we're at:

We're almost there, but just bumped into a sort of wall.

For bytecode objects, we allocate string literals which are never freed,
and when compiling the ByteCode which references theses string literals,
we PUSH_ADDR a NON-POINTER reference to the Addr# in the string literals
environment kept by the ghci linker.

I believe that these Addr are put in the non-pointers list of data of a
BCO (Rather than on the ptrs list of data) because we don't want them to
be GC-d. They are allocated by the linker and should not be touched by
the RTS.

The problem is that when constructing a static data con application, we
will find addresses and put them as part of the POINTERS fields of the
data application. Now, I expect that the info table NPTRS/PTRS
directives will expect the Addr# to be in the PTRS because it may be
collected by the GC as far as the data con is concerned.

this didn't come up before because we only ever constructed BCOs in
bytecode, never the constructors the directly. Soooooooo

I don't think I should be changing the order of Ids vs Lits after they
come in the proto static con ids. But perhaps it's fine? Perhaps I'm
writing them as Ids but really they should be moved to the literals once
I find them?

Yes, that could make sense.... So, check the actual info table to figure
out where things go

And try an example with lits and ptrs and see what comes first.

7 changed files:

compiler/GHC/ByteCode/Asm.hs
compiler/GHC/ByteCode/Instr.hs
compiler/GHC/ByteCode/Linker.hs
compiler/GHC/ByteCode/Serialize.hs
compiler/GHC/ByteCode/Types.hs
compiler/GHC/Linker/Loader.hs
compiler/GHC/StgToByteCode.hs

Changes:

compiler/GHC/ByteCode/Asm.hs

@@ -95,13 +95,15 @@ bcoFreeNames bco
               mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag unlinkedBCOLits ] :
               map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag unlinkedBCOPtrs ]
            ) `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName]
 -    bco_refs UnlinkedStaticCon{unlinkedStaticConName, unlinkedStaticConLits, unlinkedStaticConPtrs}
 +    bco_refs UnlinkedStaticCon{ unlinkedStaticConName, unlinkedStaticConDataConName
 +                              , unlinkedStaticConLits, unlinkedStaticConPtrs }
          = unionManyUniqDSets (
 +             mkUniqDSet [ unlinkedStaticConDataConName ] :
               mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag unlinkedStaticConPtrs ] :
               mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag unlinkedStaticConLits ] :
               map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag unlinkedStaticConPtrs ]
+           )
 -          `uniqDSetMinusUniqSet` mkNameSet [unlinkedStaticConName]
 +          `uniqDSetMinusUniqSet` mkNameSet [ unlinkedStaticConName ]
  -- -----------------------------------------------------------------------------
  -- The bytecode assembler
@@ -207,14 +209,17 @@ assembleInspectAsm p i = assembleI @InspectAsm p i
  assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO
  assembleBCO platform
 -            (ProtoStaticCon { protoStaticCon = dc
 +            (ProtoStaticCon { protoStaticConName
 +                            , protoStaticCon = dc
                              , protoStaticConLits = lits
                              , protoStaticConIds  = ids
                              }) = do
 +  pprTraceM "assembleBCO: static con" (ppr dc <+> ppr lits <+> ppr ids)
    let ptrs    = foldr mappendFlatBag emptyFlatBag (map idBCOArg ids)
    let nonptrs = foldr mappendFlatBag emptyFlatBag (map litBCOArg lits)
    pure UnlinkedStaticCon
 -    { unlinkedStaticConName = dataConName dc
 +    { unlinkedStaticConName = protoStaticConName
 +    , unlinkedStaticConDataConName = dataConName dc
      , unlinkedStaticConLits = nonptrs
      , unlinkedStaticConPtrs = ptrs
+     }

compiler/GHC/ByteCode/Instr.hs

@@ -52,6 +52,9 @@ data ProtoBCO
     -- | A top-level static constructor application object
     -- See Note [Static constructors in Bytecode]
     | ProtoStaticCon {
 +        protoStaticConName :: Name,
 +        -- ^ The name to which this static constructor is bound,
 +        -- not to be confused with the DataCon itself.
          protoStaticCon     :: DataCon,
          protoStaticConLits :: [Literal],
          protoStaticConIds  :: [Id],
@@ -290,8 +293,8 @@ data BCInstr
  -- Printing bytecode instructions
  instance Outputable ProtoBCO where
 -   ppr (ProtoStaticCon con lits ids origin)
 -      = text "ProtoStaticCon" <+> ppr con <> colon
 +   ppr (ProtoStaticCon nm con lits ids origin)
 +      = text "ProtoStaticCon" <+> ppr nm <+> text "for constructor" <+> ppr con <> colon
          $$ nest 3 (pprStgRhsShort shortStgPprOpts origin)
          $$ nest 3 (text "lits: " <+> ppr lits)
          $$ nest 3 (text "ids: "  <+> ppr ids)
@@ -486,7 +489,8 @@ instance Outputable BCInstr where
  -- stack high water mark, but it doesn't seem worth the hassle.
  protoBCOStackUse :: ProtoBCO -> Word
 -protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
 +protoBCOStackUse ProtoBCO{protoBCOInstrs} = sum (map bciStackUse protoBCOInstrs)
 +protoBCOStackUse ProtoStaticCon{} = 0
  bciStackUse :: BCInstr -> Word
  bciStackUse STKCHECK{}            = 0

compiler/GHC/ByteCode/Linker.hs

@@ -80,9 +80,13 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do
        { unlinkedStaticConLits = lits0
        , unlinkedStaticConPtrs = ptrs0
        } -> do
 -        Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state (unlinkedStaticConName unl_bco)
 +        pprTraceM "linkBCO: linking static constructor" (ppr unl_bco)
 +        Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state (unlinkedStaticConDataConName unl_bco)
 +        pprTraceM "linkBCO: itbl_ptr#" (ppr (unlinkedStaticConDataConName unl_bco) <+> text (show (Ptr itbl_ptr#)))
          lits <- doLits lits0
 +        pprTraceM "linkBCO: lits done" (empty)
          ptrs <- doPtrs ptrs0
 +        pprTraceM "linkBCO: ptrs done" (empty)
          return ResolvedStaticCon
            { resolvedBCOIsLE = isLittleEndian
            , resolvedStaticConInfoPtr = W# (int2Word# (addr2Int# itbl_ptr#))
@@ -99,7 +103,7 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do
        mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
  lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
 -lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of
 +lookupLiteral interp pkgs_loaded bytecode_state ptr =  pprTrace "lookupLiteral" (ppr ptr) $ case ptr of
    BCONPtrWord lit -> return lit
    BCONPtrLbl  sym -> do
      Ptr a# <- lookupStaticPtr interp sym
@@ -183,20 +187,24 @@ resolvePtr
    -> NameEnv (Int, Bool)
    -> BCOPtr
    -> IO ResolvedBCOPtr
 -resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of
 +resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = pprTrace "resolvePtr" (ppr ptr) $ case ptr of
    BCOPtrName nm
      | Just (ix, b) <- lookupNameEnv bco_ix nm
 -    -> if b then
 +    -> if b then do
 +        pprTraceM "resolvePtr: ResolvedBCORef" (ppr nm <+> ppr ix)
          return (ResolvedBCORef ix) -- ref to another BCO in this group
 -       else
 +       else do
 +        pprTraceM "resolvePtr: StaticConRef" (ppr nm <+> ppr ix)
          return (ResolvedStaticConRef ix) -- ref to another StaticCon in this group
      | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm
 -    -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
 +    -> do
 +      pprTraceM "resolvePtr: BCOPtr" (ppr nm)
 +      return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
      | otherwise
      -> assertPpr (isExternalName nm) (ppr nm) $
 -       do
 +       pprTrace "resolvePtr: OTHERWISE? ASSERTION FIALURE?" (ppr nm) $ do
            let sym_to_find = IClosureSymbol nm
            m <- lookupHsSymbol interp pkgs_loaded sym_to_find
            case m of

compiler/GHC/ByteCode/Serialize.hs

@@ -327,6 +327,7 @@ instance Binary UnlinkedBCO where
          <*> get bh
 -> UnlinkedStaticCon
          <$> getViaBinName bh
 +        <*> getViaBinName bh
          <*> get bh
          <*> get bh
        _ -> panic "Binary UnlinkedBCO: invalid byte"
@@ -342,6 +343,7 @@ instance Binary UnlinkedBCO where
    put_ bh UnlinkedStaticCon {..} = do
      putByte bh 1
      putViaBinName bh unlinkedStaticConName
 +    putViaBinName bh unlinkedStaticConDataConName
      put_ bh unlinkedStaticConLits
      put_ bh unlinkedStaticConPtrs

compiler/GHC/ByteCode/Types.hs

@@ -31,6 +31,7 @@ module GHC.ByteCode.Types
    ) where
  import GHC.Prelude
 +import qualified Data.ByteString.Char8 as BS8
  import GHC.Data.FastString
  import GHC.Data.FlatBag
@@ -259,6 +260,10 @@ data UnlinkedBCO
     -- See Note [Static constructors in Bytecode]
     | UnlinkedStaticCon {
          unlinkedStaticConName :: !Name,
 +        -- ^ The name to which this static constructor is bound, not to be
 +        -- confused with the name of the static constructor itself
 +        -- ('unlinkedStaticConDataConName')
 +        unlinkedStaticConDataConName :: !Name,
          unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs
          unlinkedStaticConPtrs :: !(FlatBag BCOPtr)   -- ptrs
+    }
@@ -282,6 +287,12 @@ instance NFData BCOPtr where
    rnf (BCOPtrBCO bco) = rnf bco
    rnf x = x `seq` ()
 +instance Outputable BCOPtr where
 +  ppr (BCOPtrName nm)     = text "BCOPtrName" <+> ppr nm
 +  ppr (BCOPtrPrimOp op)   = text "BCOPtrPrimOp" <+> ppr op
 +  ppr (BCOPtrBCO bco)     = text "BCOPtrBCO" <+> ppr bco
 +  ppr (BCOPtrBreakArray mod) = text "<break array for" <+> ppr mod <> char '>'
++
  data BCONPtr
    = BCONPtrWord  {-# UNPACK #-} !Word
    | BCONPtrLbl   !FastString
@@ -299,6 +310,16 @@ data BCONPtr
    -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'
    | BCONPtrCostCentre !InternalBreakpointId
 +instance Outputable BCONPtr where
 +  ppr (BCONPtrWord w)       = integer (fromIntegral w)
 +  ppr (BCONPtrLbl lbl)      = text "<label:" <> ftext lbl <> char '>'
 +  ppr (BCONPtrItbl nm)      = text "<itbl:" <+> ppr nm <> char '>'
 +  ppr (BCONPtrAddr nm)      = text "<addr:" <+> ppr nm <> char '>'
 +  ppr (BCONPtrStr bs)       = text "<string literal: " <+> text (BS8.unpack bs) <> char '>'
 +  ppr (BCONPtrFS fs)        = text "<fast string literal:" <+> ftext fs <> char '>'
 +  ppr (BCONPtrFFIInfo ffi)  = text "<FFIInfo>"
 +  ppr (BCONPtrCostCentre bid) = text "<CostCentre for BreakpointId:" <+> ppr bid <> char '>'
++
  instance NFData BCONPtr where
    rnf x = x `seq` ()
@@ -307,8 +328,9 @@ instance Outputable UnlinkedBCO where
        = sep [text "BCO", ppr nm, text "with",
               ppr (sizeFlatBag lits), text "lits",
               ppr (sizeFlatBag ptrs), text "ptrs" ]
 -   ppr (UnlinkedStaticCon nm lits ptrs)
 -      = sep [text "StaticCon", ppr nm, text "with",
 +   ppr (UnlinkedStaticCon nm dc_nm lits ptrs)
 +      = sep [text "StaticCon", ppr nm, text "for",
 +             ppr dc_nm, text "with",
               ppr (sizeFlatBag lits), text "lits",
               ppr (sizeFlatBag ptrs), text "ptrs" ]

compiler/GHC/Linker/Loader.hs

@@ -1048,6 +1048,13 @@ linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods []
                             UnlinkedStaticCon{unlinkedStaticConName} -> (unlinkedStaticConName, False)
                      ) flat
          bco_ix = mkNameEnv (zipWith (\(n,isBCO) ix -> (n,(ix, isBCO))) names [0..])
 +    pprTraceM "linkSomeBCOs what" $ (ppr mods <+> ppr flat)
 +    pprTraceM "linkSomeBCOs" $
 +      vcat [ text "Linking BCOs:"
 +           , nest 2 (vcat (map (ppr . fst) names))
 +           , text "BCO index:"
 +           , nest 2 (ppr bco_ix)
 +           ]
      resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ]
      hvrefs <- createBCOs interp resolved
      return (zipWith (\(n,_) hvr -> (n, hvr)) names hvrefs)

compiler/GHC/StgToByteCode.hs

@@ -305,15 +305,17 @@ argBits platform (rep : args)
  -- Compile code for the right-hand side of a top-level binding
  schemeTopBind :: (Id, CgStgRhs) -> BcM ProtoBCO
 -schemeTopBind (_, rhs@(StgRhsCon _ dc _ _ args _))
 +schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _))
    = do
 +    pprTraceM "schemeTopBind: static con" (ppr id <+> ppr dc <+> ppr args)
      profile <- getProfile
      let non_voids = addArgReps (assertNonVoidStgArgs args)
          (_, _, args_offsets)
                    -- Compute the expected runtime ordering for the datacon fields
                    = mkVirtConstrOffsets profile non_voids
      return ProtoStaticCon
 -      { protoStaticCon = dc
 +      { protoStaticConName = getName id
 +      , protoStaticCon     = dc
        , protoStaticConLits = [ lit | (NonVoid (StgLitArg lit), _) <- args_offsets ]
        , protoStaticConIds  = [ i   | (NonVoid (StgVarArg i), _)   <- args_offsets {-, assert is never a local var -} ]
        , protoStaticConExpr = rhs