Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: dacd00dc by Rodrigo Mesquita at 2026-03-30T17:43:34+01:00 fixup! Allocate static constructors for bytecode - - - - - eb40cc66 by Rodrigo Mesquita at 2026-03-30T17:43:34+01:00 fixup! Add float# and subword tests for #25636 - - - - - 17 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/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - + testsuite/tests/codeGen/should_run/T25636c/T25636c.script - + testsuite/tests/codeGen/should_run/T25636c/T25636c.stdout - + testsuite/tests/codeGen/should_run/T25636c/all.T - + testsuite/tests/codeGen/should_run/T25636d/T25636d.script - + testsuite/tests/codeGen/should_run/T25636d/T25636d.stdout - + testsuite/tests/codeGen/should_run/T25636d/all.T - + testsuite/tests/codeGen/should_run/T25636e/T25636e.script - + testsuite/tests/codeGen/should_run/T25636e/T25636e.stdout - + testsuite/tests/codeGen/should_run/T25636e/all.T Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -78,6 +78,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) -- ----------------------------------------------------------------------------- @@ -216,8 +218,9 @@ assembleBCO platform , protoStaticCon = dc , protoStaticConData = args }) = 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 @@ -226,7 +229,7 @@ assembleBCO platform , unlinkedStaticConIsUnlifted = isUnliftedType (idType (dataConWrapId dc)) } where - litBCOArg (Left l) = Just $ case literal platform l of + litBCOArg (Left l) = Just $ case l of OnlyOne np -> unitFlatBag np OnlyTwo np1 np2 -> TupleFlatBag np1 np2 litBCOArg (Right var) @@ -295,6 +298,69 @@ 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 (OneOrTwo BCONPtr) Id] +packSubwordArgs platform = map packWord . groupWords + where + -- Assumes packed sub-words are always ordered from largest to smallest literal + packWord :: Either [Literal] Id -> Either (OneOrTwo BCONPtr) Id + packWord (Right v) = Right v -- already word size + packWord (Left [lit]) = Left $ literal platform lit -- single >=word_size literal + packWord (Left lits) = Left $ OnlyOne (BCONPtrWord packedWord) + where + packedWord = go 0 lits + + go :: Int -> [Literal] -> Word + go _ [] = 0 + go offset (l:ls) = + (subwordLiteral l `shiftBy` offset) .|. go (offset + litBits l) ls + + shiftBy :: Word -> Int -> Word + shiftBy w offset = case platformByteOrder platform of + LittleEndian -> w `unsafeShiftL` offset + BigEndian -> w `unsafeShiftR` offset + + subwordLiteral :: Literal -> Word + subwordLiteral l = case literal platform l of + OnlyOne (BCONPtrWord w) -> w + _ -> pprPanic "packSubwordArgs: expected a subword literal to lower to one BCONPtrWord" (ppr l) + + litBits :: Literal -> Int + litBits l = litBytes l * 8 + + -- Group literals into lists of literals making up a full word, where in + -- singleton lists the literal may be larger than a word + -- (e.g. Word64 in 32bit platform) + groupWords :: [Either Literal Id] -> [Either [Literal] Id] + groupWords = unfoldr step + where + step [] = Nothing + step (Right v:xs) = Just (Right v, xs) + step (Left l:xs) = + let (chunk, rest) = takeWord [] (Left l:xs) + in Just (Left chunk, rest) + + -- take subwords from list until a full-word is accumulated + takeWord acc rest + -- reached a full word in the accumulator; exit! + | sum (map litBytes acc) == ws + = (reverse acc, rest) + takeWord [sing] rest + -- a larger than word single lit in the accumulator; exit! + | litBytes sing > ws + = ([sing], rest) + takeWord acc (Left l:ls) + -- contiguous lits should be sub-words of right size to form full + -- word; else, the exit condition is never reached. + = takeWord (l:acc) ls + takeWord acc _ + = pprPanic "packSubwordArgs: Reached Ptr or end of list before forming a full word from contiguous literals." + (text "acc:" <+> ppr acc) + + litBytes = primRepSizeB platform . typePrimRepU . literalType + 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 ===================================== @@ -271,7 +271,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 } @@ -340,7 +342,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 ===================================== @@ -305,16 +305,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/CreateBCO.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) import GHC.Internal.Prim ( BCO, mkApUpd0#, newBCO# ) import GHC.IO import Control.Exception ( ErrorCall(..) ) +import Control.Monad {- Note [Tying the knot in createBCOs] @@ -198,7 +199,7 @@ createUnliftedStaticCons objs lif_arr = do getUnlDeps :: ResolvedBCO -> [Int] getUnlDeps (ResolvedStaticCon{..}) = - [ k | ptr <- ssElts resolvedStaticConPtrs + [ k | ptr <- smallArrayToList resolvedStaticConPtrs , ResolvedUnliftedStaticConRef k <- [ptr] ] getUnlDeps _ = [] @@ -219,24 +220,22 @@ linkBCO' arr unl_arr resolved_obj = bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap) literals_barr = barr (getBCOByteArray resolvedBCOLits) - PtrsArr marr <- mkPtrsArray arr resolvedBCOPtrs + PtrsArr marr <- mkPtrsArray arr unl_arr resolvedBCOPtrs IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s + case newBCO# insns_barr literals_barr arr arity# bitmap_barr s of { (# s, bco #) -> + (# s, LinkedBCO resolvedBCOArity bco #) }} ResolvedStaticCon{..} -> do let - ptrs = ssElts resolvedStaticConPtrs - n_ptrs = sizeSS resolvedStaticConPtrs !(W# data_size#) = resolvedStaticConArity literals_barr = barr (getBCOByteArray resolvedStaticConLits) !(Ptr itbl_ptr#) = fromRemotePtr resolvedStaticConInfoPtr - PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs + PtrsArr marr <- mkPtrsArray arr unl_arr resolvedStaticConPtrs IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> @@ -384,4 +383,3 @@ emptyArr = unsafeDupablePerformIO $ IO $ \s -> (# s, EmptyArr farr #) }} - ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -65,9 +65,20 @@ data ResolvedBCO resolvedBCOIsLE :: !Bool, resolvedStaticConInfoPtr :: !(RemotePtr Heap.StgInfoTable), resolvedStaticConArity :: {-# UNPACK #-} !Word, - resolvedStaticConLits :: BCOByteArray Word, - resolvedStaticConPtrs :: SizedSeq ResolvedBCOPtr, - resolvedStaticConIsUnlifted :: Bool + -- ^ 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 :: !(SmallArray ResolvedBCOPtr), + resolvedStaticConIsUnlifted :: !Bool } deriving (Generic, Show) ===================================== testsuite/tests/codeGen/should_run/T25636c/T25636c.script ===================================== @@ -0,0 +1,28 @@ +:set -XMagicHash +import GHC.Exts +import GHC.Word +:{ +data A = A Word8# Word16# Word8# +a = A (wordToWord8# 1##) (wordToWord16# 258##) (wordToWord8# 3##) +unA :: A -> (Word8, Word16, Word8) +unA (A x y z) = (W8# x, W16# y, W8# z) + +data B = B Word16# Word8# Word8# +b = B (wordToWord16# 772##) (wordToWord8# 5##) (wordToWord8# 6##) +unB :: B -> (Word16, Word8, Word8) +unB (B x y z) = (W16# x, W8# y, W8# z) + +data C = C Word8# Word8# Word8# Word8# +c = C (wordToWord8# 7##) (wordToWord8# 8##) (wordToWord8# 9##) (wordToWord8# 10##) +unC :: C -> (Word8, Word8, Word8, Word8) +unC (C w x y z) = (W8# w, W8# x, W8# y, W8# z) + +data D = D Word32# Word8# Word16# Word8# +d = D (wordToWord32# 16909060##) (wordToWord8# 11##) (wordToWord16# 3086##) (wordToWord8# 13##) +unD :: D -> (Word32, Word8, Word16, Word8) +unD (D w x y z) = (W32# w, W8# x, W16# y, W8# z) +:} +print (unA a) +print (unB b) +print (unC c) +print (unD d) ===================================== testsuite/tests/codeGen/should_run/T25636c/T25636c.stdout ===================================== @@ -0,0 +1,4 @@ +(1,258,3) +(772,5,6) +(7,8,9,10) +(16909060,11,3086,13) ===================================== testsuite/tests/codeGen/should_run/T25636c/all.T ===================================== @@ -0,0 +1 @@ +test('T25636c', [], ghci_script, ['T25636c.script']) ===================================== testsuite/tests/codeGen/should_run/T25636d/T25636d.script ===================================== @@ -0,0 +1,28 @@ +:set -XMagicHash +import GHC.Exts +import GHC.Int +:{ +data E = E Int8# Int16# Int8# +e = E (intToInt8# (-1#)) (intToInt16# (-258#)) (intToInt8# 3#) +unE :: E -> (Int8, Int16, Int8) +unE (E x y z) = (I8# x, I16# y, I8# z) + +data F = F Int16# Int8# Int8# +f = F (intToInt16# (-1025#)) (intToInt8# 6#) (intToInt8# (-7#)) +unF :: F -> (Int16, Int8, Int8) +unF (F x y z) = (I16# x, I8# y, I8# z) + +data G = G Int8# Int8# Int8# Int8# +g = G (intToInt8# (-8#)) (intToInt8# 9#) (intToInt8# (-10#)) (intToInt8# 11#) +unG :: G -> (Int8, Int8, Int8, Int8) +unG (G w x y z) = (I8# w, I8# x, I8# y, I8# z) + +data H = H Int32# Int8# Int16# Int8# +h = H (intToInt32# (-16909060#)) (intToInt8# 12#) (intToInt16# (-3342#)) (intToInt8# 14#) +unH :: H -> (Int32, Int8, Int16, Int8) +unH (H w x y z) = (I32# w, I8# x, I16# y, I8# z) +:} +print (unE e) +print (unF f) +print (unG g) +print (unH h) ===================================== testsuite/tests/codeGen/should_run/T25636d/T25636d.stdout ===================================== @@ -0,0 +1,4 @@ +(-1,-258,3) +(-1025,6,-7) +(-8,9,-10,11) +(-16909060,12,-3342,14) ===================================== testsuite/tests/codeGen/should_run/T25636d/all.T ===================================== @@ -0,0 +1 @@ +test('T25636d', [], ghci_script, ['T25636d.script']) ===================================== testsuite/tests/codeGen/should_run/T25636e/T25636e.script ===================================== @@ -0,0 +1,16 @@ +:set -XMagicHash +import GHC.Exts +import GHC.Word +:{ +data J = J Char# Word16# Word8# Word8# +j = J 'A'# (wordToWord16# 258##) (wordToWord8# 3##) (wordToWord8# 4##) +unJ :: J -> (Char, Word16, Word8, Word8) +unJ (J a b c d) = (C# a, W16# b, W8# c, W8# d) + +data K = K Word16# Char# Word8# Char# +k = K (wordToWord16# 1286##) 'B'# (wordToWord8# 7##) 'C'# +unK :: K -> (Word16, Char, Word8, Char) +unK (K a b c d) = (W16# a, C# b, W8# c, C# d) +:} +print (unJ j) +print (unK k) ===================================== testsuite/tests/codeGen/should_run/T25636e/T25636e.stdout ===================================== @@ -0,0 +1,2 @@ +('A',258,3,4) +(1286,'B',7,'C') ===================================== testsuite/tests/codeGen/should_run/T25636e/all.T ===================================== @@ -0,0 +1 @@ +test('T25636e', [], ghci_script, ['T25636e.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/81cbdb13a30f56fe2503ee873278953... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/81cbdb13a30f56fe2503ee873278953... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Rodrigo Mesquita (＠alt-romes)