Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: 27c32a9b by Rodrigo Mesquita at 2026-02-13T11:02:45+00:00 NO - - - - - 44e6d4c6 by Rodrigo Mesquita at 2026-02-13T11:02:49+00:00 Revert "NO" This reverts commit 27c32a9b61cec37a1eb2d9bc742ae9703be3a9a6. - - - - - 0c955375 by Rodrigo Mesquita at 2026-02-13T11:03:00+00:00 COMMENTS - - - - - 992f6b5e by Rodrigo Mesquita at 2026-02-13T18:32:26+00:00 wip: start fixing, but manually packing things is kind of awful. how to do better? [skip ci] - - - - - 7 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Layout.hs - libraries/ghci/GHCi/ResolvedBCO.hs Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -38,7 +38,7 @@ import GHC.Types.SptEntry import GHC.Types.Unique.FM import GHC.Unit.Types -import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat ) +import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat, ($$) ) import GHC.Utils.Panic import GHC.Builtin.Types.Prim ( addrPrimTy ) @@ -77,6 +77,8 @@ import GHC.Exts import GHC.Core.DataCon import GHC.Data.FlatBag import GHC.Types.Id +import Data.List (unfoldr) +import GHC.Types.RepType (typePrimRepU) -- ----------------------------------------------------------------------------- @@ -214,9 +216,11 @@ assembleBCO platform (ProtoStaticCon { protoStaticConName , protoStaticCon = dc , protoStaticConData = args + , protoStaticConNonPtrsSize = non_ptr_words }) = do - let ptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args) - let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args) + let fullword_args = packSubwordArgs platform args + let ptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg fullword_args) + let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg fullword_args) pure UnlinkedStaticCon { unlinkedStaticConName = protoStaticConName , unlinkedStaticConDataConName = dataConName dc @@ -294,6 +298,50 @@ assembleBCO platform return ul_bco +-- | Pack sub-word literals (which should appear contiguously in the argument +-- list) into full words, and leave full-word-sized arguments alone. +packSubwordArgs :: Platform -> [Either Literal Id] -> [Either Literal Id] +packSubwordArgs platform = map packWord . groupWords + -- Group arguments into lists of total size=platform word size + where + -- Assumes packed sub-words are always ordered from largest to smallest + packWord :: Either [(Literal, Int{-size in bits-})] Id -> Either Literal Id + packWord (Right v) = Right v -- already word size + packWord (Left litsWithSizes) = Left $ mkLitWord platform packedValue + where + packedValue = case platformByteOrder platform of + BigEndian -> + -- For BE, we shift the accumulator left and OR the new value + foldl' (\acc (val, sz) -> (acc `unsafeShiftL` sz) .|. val) 0 litsWithSizes + + LittleEndian -> + -- For LE, the first element is at shift 0, the next at shift (size of first), etc. + let offsets = scanl (+) 0 [ sz | (_, sz) <- litsWithSizes ] + in foldl' (\acc ((val, _), shift) -> acc .|. (val `unsafeShiftL` shift)) 0 (zip litsWithSizes offsets) + + groupWords :: [Either Literal Id] -> [Either [(Literal, Int{-size in bits-})] Id] + groupWords = unfoldr step + where + step [] = Nothing + step (Right v:xs) = Just (Right v, xs) + step (Left l:xs) = + let (chunk, rest) = takeWord 0 [] (Left l:xs) + in Just (Left chunk, rest) + + takeWord _ _ [] = panic "packSubwordArgs: Input does not align to 64-bit boundary" + takeWord !n acc (Right l:ls) + -- ptrs are word sized by definition, so the accumulated sub-words must already have formed a full word. + = assertPpr (n == ws) (text "packSubwordArgs: Word-sized argument found before accumulated sub-words formed a full word") + (reverse acc, Right l:ls) + takeWord !n acc (Left l:ls) + | n + s < ws = takeWord (n+s) ((l,s*8):acc) ls + | n + s == ws = (reverse ((l,s*8):acc), ls) + | otherwise = panic "packSubwordArgs: Element crosses 64-bit boundary" + where + s = primRepSizeB platform (typePrimRepU (literalType l)) + + ws = platformWordSizeInBytes platform + -- | Construct a word-array containing an @StgLargeBitmap@. mkBitmapArray :: Word -> [StgWord] -> UArray Int Word -- Here the return type must be an array of Words, not StgWords, ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -58,8 +58,16 @@ data ProtoBCO -- We use this to construct the right info table. protoStaticConData :: [Either Literal Id], -- ^ The static constructor pointer and non-pointer arguments, sorted - -- in the order they should appear at runtime (see 'mkVirtConstrOffsets'). - -- The pointers always come first, followed by the non-pointers. + -- in the order they should appear at runtime (see + -- 'mkVirtHeapOffsetsWithPadding' in 'schemeTopBind'). + -- + -- The non-pointer arguments are meant to be laid contiguously in + -- memory using the width of each literal individually. The padding is + -- given as Literals of value 0 with the appropriate width. + protoStaticConNonPtrsSize :: Int, + -- ^ How many words needed to store the non-pointer arguments. + -- Note that this may be smaller than the number of non-pointer + -- arguments, since subword arguments need to be packed. protoStaticConExpr :: CgStgRhs -- ^ What the static con came from, for debugging only } @@ -333,11 +341,12 @@ data BCInstr -- Printing bytecode instructions instance Outputable ProtoBCO where - ppr (ProtoStaticCon nm con args origin) + ppr (ProtoStaticCon nm con args nonPtrsSize origin) = text "ProtoStaticCon" <+> ppr nm <> colon $$ nest 3 (pprStgRhsShort shortStgPprOpts origin) $$ nest 3 (text "constructor: " <+> ppr con) $$ nest 3 (text "sorted args: " <+> ppr args) + $$ nest 3 (text "non-ptrs (packed) size: " <+> int (fromIntegral nonPtrsSize) <+> text "words") ppr (ProtoBCO { protoBCOName = name , protoBCOInstrs = instrs , protoBCOBitmap = bitmap ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -262,7 +262,9 @@ data UnlinkedBCO -- confused with the name of the static constructor itself -- ('unlinkedStaticConDataConName') unlinkedStaticConDataConName :: !Name, - unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedStaticConLits :: !(FlatBag BCONPtr), + -- ^ non-ptrs full words, where sub-word literals have already been + -- packed into full words as needed unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs unlinkedStaticConIsUnlifted :: !Bool } @@ -331,7 +333,7 @@ instance Outputable UnlinkedBCO where = sep [text "StaticCon", ppr nm, text "for", if unl then text "unlifted" else text "lifted", ppr dc_nm, text "with", - ppr (sizeFlatBag lits), text "lits", + ppr (sizeFlatBag lits), text "lits", parens (text "(packed) full words"), ppr (sizeFlatBag ptrs), text "ptrs" ] instance Binary FFIInfo where ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -304,16 +304,25 @@ schemeTopBind :: (Id, CgStgRhs) -> BcM ProtoBCO schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _)) = do profile <- getProfile - let non_voids = addArgReps (assertNonVoidStgArgs args) - (_, _, args_offsets) - -- Compute the expected runtime ordering for the datacon fields - = mkVirtConstrOffsets profile non_voids + let + non_voids = addArgReps (assertNonVoidStgArgs args) + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + nv_args_w_offsets) = + -- Compute the runtime ordering for the datacon fields + -- (Subword-sized fields are laid out contiguously, and padding is + -- represented as literals of value 0 with the appropriate width) + mkVirtHeapOffsetsWithPadding profile StdHeader non_voids + contiguous_args_with_pad = + litsWithPaddingToLits nv_args_w_offsets + return ProtoStaticCon { protoStaticConName = getName id , protoStaticCon = dc , protoStaticConData = [ case a of StgLitArg l -> Left l StgVarArg i -> Right i - | (NonVoid a, _) <- args_offsets ] + | NonVoid a <- contiguous_args_with_pad ] + , protoStaticConNonPtrsSize = tot_wds - ptr_wds , protoStaticConExpr = rhs } schemeTopBind (id, rhs) ===================================== compiler/GHC/StgToCmm/DataCon.hs ===================================== @@ -100,23 +100,7 @@ cgTopRhsCon cfg id con mn args nv_args_w_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) - ; let - -- Decompose padding into units of length 8, 4, 2, or 1 bytes to - -- allow the implementation of mk_payload to use widthFromBytes, - -- which only handles these cases. - fix_padding (x@(Padding n off) : rest) - | n == 0 = fix_padding rest - | n `elem` [1,2,4,8] = x : fix_padding rest - | testBit n 0 = add_pad 1 - | testBit n 1 = add_pad 2 - | testBit n 2 = add_pad 4 - | otherwise = add_pad 8 - where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest) - fix_padding (x : rest) = x : fix_padding rest - fix_padding [] = [] - - mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) - mk_payload (FieldOff arg _) = do + mk_payload arg = do amode <- getArgAmode arg case amode of CmmLit lit -> return lit @@ -129,8 +113,7 @@ cgTopRhsCon cfg id con mn args -- needs to poke around inside it. info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds - - ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets) + ; payload <- mapM mk_payload (litsWithPaddingToLits nv_args_w_offsets) -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs -- NB2: all the amodes should be Lits! -- TODO (osa): Why? ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -23,6 +23,7 @@ module GHC.StgToCmm.Layout ( mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets, mkVirtConstrSizes, + litsWithPaddingToLits, getHpRelOffset, ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep @@ -66,6 +67,7 @@ import Control.Monad import GHC.StgToCmm.Config (stgToCmmPlatform) import GHC.StgToCmm.Types import Data.List.NonEmpty (nonEmpty) +import GHC.Types.Literal ------------------------------------------------------------------------ -- Call and return sequences @@ -423,6 +425,10 @@ data FieldOffOrPadding a | Padding ByteOff -- Length of padding in bytes. ByteOff -- Offset in bytes. +instance Outputable a => Outputable (FieldOffOrPadding a) where + ppr (FieldOff (NonVoid a) off) = text "Field" <+> ppr a <+> text "at offset" <+> int off + ppr (Padding size off) = text "Padding of size" <+> int size <+> text "at offset" <+> int off + -- | Used to tell the various @mkVirtHeapOffsets@ functions what kind -- of header the object has. This will be accounted for in the -- offsets of the fields returned. @@ -512,6 +518,25 @@ mkVirtHeapOffsetsWithPadding profile header things = , field_off ] +-- | Flatten a list of @'FieldOffOrPadding' StgArg@ into a list of @NonVoid StgArg@ +-- by decompose padding into zero-valued 'StgLitArgs' units of length 8, 4, 2, or 1 bytes. +litsWithPaddingToLits :: [FieldOffOrPadding StgArg] -> [NonVoid StgArg] +litsWithPaddingToLits = concatMap $ \case + FieldOff (NonVoid arg) _ -> [NonVoid arg] + Padding size _ -> map (NonVoid . StgLitArg) (zeroBytes size) + where + -- Make literals of value 0 for a total of n bytes of padding. + zeroBytes :: ByteOff -> [Literal] + zeroBytes n + | n == 0 = [] + | n == 1 = [LitNumber LitNumWord8 0] + | n == 2 = [LitNumber LitNumWord16 0] + | n == 4 = [LitNumber LitNumWord32 0] + | n == 8 = [LitNumber LitNumWord64 0] + | testBit n 0 = LitNumber LitNumWord8 0 : zeroBytes (n-1) + | testBit n 1 = LitNumber LitNumWord16 0 : zeroBytes (n-2) + | testBit n 2 = LitNumber LitNumWord32 0 : zeroBytes (n-4) + | otherwise = LitNumber LitNumWord64 0 : zeroBytes (n-8) mkVirtHeapOffsets :: Profile ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -45,7 +45,7 @@ data ResolvedBCO resolvedBCOBitmap :: BCOByteArray Word, -- ^ bitmap resolvedBCOLits :: BCOByteArray Word, -- ^ non-ptrs - subword sized entries still take up a full (host) word - resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs + resolvedBCOPtrs :: SizedSeq ResolvedBCOPtr -- ^ ptrs } -- | A resolved static constructor -- See Note [Static constructors in Bytecode] @@ -53,7 +53,18 @@ data ResolvedBCO resolvedBCOIsLE :: Bool, resolvedStaticConInfoPtr :: !(RemotePtr Heap.StgInfoTable), resolvedStaticConArity :: {-# UNPACK #-} !Word, + -- ^ how many words are used for the payload of the static constructor + -- (size of ptrs and (packed) non-ptrs combined) resolvedStaticConLits :: BCOByteArray Word, + -- ^ Notably, sub-word non-ptr arguments and padding have already been + -- packed into full words, and this array only stores the full final + -- words to write as the constructor payload. + -- + -- This is opposed to what we do for BCO literals, where we keep + -- sub-word literals as full words. For static constructors, the layout + -- must match exactly what the NCG also expects, so we must pack + -- sub-words accordingly for compatibility between interpreted and + -- compiled code. resolvedStaticConPtrs :: SizedSeq ResolvedBCOPtr, resolvedStaticConIsUnlifted :: Bool } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b8a4e57fd722b2be6a55915fcb4b3c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b8a4e57fd722b2be6a55915fcb4b3c... You're receiving this email because of your account on gitlab.haskell.org.