Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: 0fa83d73 by Rodrigo Mesquita at 2025-12-23T20:00:03+00:00 Allocate static constructors for bytecode This commit adds support for static constructors when compiling and linking ByteCode objects. Top-level StgRhsCon get lowered to ProtoStaticCons rather than to ProtoBCOs. A ProtoStaticCon gets allocated directly as a data con application on the heap (using the new primop newConApp#). Previously, we would allocate a ProtoBCO which, when evaluated, would PACK and return the constructor. A few more details are given in Note [Static constructors in Bytecode]. Secondly, this commit also fixes issue #25636 which was caused by linking *unlifted* constructors in BCO instructions as - (1) a thunk indexing the array of BCOs in a module - (2) which evaluated to a BCO which still had to be evaluated to return the unlifted constructor proper. The (2) issue has been resolved by allocating the static constructors directly. The (1) issue can be resolved by ensuring that we allocate all unlifted top-level constructors eagerly, and leave the knot-tying for the lifted BCOs and top-level constructors only. The top-level unlifted constructors are never mutually recursive, so we can allocate them all in one go as long as we do it in topological order. Lifted fields of unlifted constructors can still be filled by the knot-tied lifted variables since in those fields it is fine to keep those thunks. See Note [Tying the knot in createBCOs] for more details. Fixes #25636 - - - - - 21 changed files: - compiler/GHC/Builtin/primops.txt.pp - 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/Cmm/Liveness.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/Interpreter.c - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/include/rts/storage/ClosureMacros.h - rts/include/stg/MiscClosures.h - + testsuite/tests/codeGen/should_run/T23146/T25636.stdout - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3947,6 +3947,18 @@ primop NewBCOOp "newBCO#" GenPrimOp effect = ReadWriteEffect out_of_line = True +primop NewConAppObjOp "newConAppObj#" GenPrimOp + Addr# -> ByteArray# -> Array# a_levpoly -> Word# -> State# s -> (# State# s, b_levpoly #) + { @'newConAppObj#' datacon_itbl lits ptrs arity@ creates a new constructor + application object on the heap from the info table pointer of the data + constructor and the data arguments given in @ptrs@ and @lits@. The + resulting object is a heap closure for the constructor application. It is + evaluated and properly tagged. The given @arity@ gives the total size of + pointers and literals in number of words. } + with + effect = ReadWriteEffect + out_of_line = True + primop UnpackClosureOp "unpackClosure#" GenPrimOp a -> (# Addr#, ByteArray#, Array# b #) { @'unpackClosure#' closure@ copies the closure and pointers in the ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE LambdaCase #-} -- -- -- (c) The University of Glasgow 2002-2006 @@ -21,9 +22,9 @@ module GHC.ByteCode.Asm ( assembleBCO ) where -import GHC.Prelude hiding ( any ) - +import GHC.Prelude hiding ( any, words ) +import Data.Maybe import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types @@ -37,9 +38,12 @@ import GHC.Types.SptEntry import GHC.Types.Unique.FM import GHC.Unit.Types -import GHC.Utils.Outputable +import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat ) import GHC.Utils.Panic +import GHC.Builtin.Types.Prim ( addrPrimTy ) +import GHC.Core.Type ( isUnliftedType ) +import GHC.Core.TyCo.Compare ( eqType ) import GHC.Core.TyCon import GHC.Data.SizedSeq import GHC.Data.SmallArray @@ -66,11 +70,13 @@ import Data.Array.Base ( unsafeWrite ) import Foreign hiding (shiftL, shiftR) import Data.ByteString (ByteString) import Data.Char (ord) -import Data.Maybe (fromMaybe) import GHC.Float (castFloatToWord32, castDoubleToWord64) import qualified Data.List as List ( any ) import GHC.Exts +import GHC.Core.DataCon +import GHC.Data.FlatBag +import GHC.Types.Id -- ----------------------------------------------------------------------------- @@ -83,14 +89,23 @@ import GHC.Exts -- defined by this group of BCOs themselves bcoFreeNames :: UnlinkedBCO -> UniqDSet Name bcoFreeNames bco - = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] + = bco_refs bco where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + bco_refs UnlinkedBCO{unlinkedBCOName, unlinkedBCOLits, unlinkedBCOPtrs} + = unionManyUniqDSets ( + mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag unlinkedBCOPtrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag unlinkedBCOLits ] : + map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag unlinkedBCOPtrs ] + ) `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName] + bco_refs UnlinkedStaticCon{ unlinkedStaticConName, unlinkedStaticConDataConName + , unlinkedStaticConLits, unlinkedStaticConPtrs } = unionManyUniqDSets ( - mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : - mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : - map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ] + 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 ] -- ----------------------------------------------------------------------------- -- The bytecode assembler @@ -147,9 +162,9 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do -- data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16) - , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr) - , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr ) - } + , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr) + , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr) + } data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16) , final_ptr_array :: !(SmallArray BCOPtr) @@ -195,6 +210,40 @@ assembleInspectAsm :: Platform -> BCInstr -> InspectAsm () assembleInspectAsm p i = assembleI @InspectAsm p i assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO +assembleBCO platform + (ProtoStaticCon { protoStaticConName + , protoStaticCon = dc + , protoStaticConData = args + }) = do + let ptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args) + let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args) + pure UnlinkedStaticCon + { unlinkedStaticConName = protoStaticConName + , unlinkedStaticConDataConName = dataConName dc + , unlinkedStaticConLits = nonptrs + , unlinkedStaticConPtrs = ptrs + , unlinkedStaticConIsUnlifted = isUnliftedType (idType (dataConWrapId dc)) + } + where + litBCOArg (Left l) = Just $ case literal platform l of + OnlyOne np -> unitFlatBag np + OnlyTwo np1 np2 -> TupleFlatBag np1 np2 + litBCOArg (Right var) + -- Addr# literals are non-pointers + | idType var `eqType` addrPrimTy + = Just $ unitFlatBag (BCONPtrAddr (getName var)) + | otherwise + = Nothing + + idBCOArg (Left _) = Nothing + idBCOArg (Right var) + | idType var `eqType` addrPrimTy + = Nothing + | Just prim <- isPrimOpId_maybe var + = Just $ unitFlatBag (BCOPtrPrimOp prim) + | otherwise + = Just $ unitFlatBag (BCOPtrName (getName var)) + assembleBCO platform (ProtoBCO { protoBCOName = nm , protoBCOInstrs = instrs @@ -561,9 +610,9 @@ oneTwoLength (OnlyTwo {}) = 2 class Monad m => MonadAssembler m where ioptr :: IO BCOPtr -> m Word - lit :: OneOrTwo BCONPtr -> m Word + lit :: OneOrTwo BCONPtr -> m Word label :: LocalLabel -> m () - emit :: PlatformWordSize -> Word16 -> [Operand] -> m () + emit :: PlatformWordSize -> Word16 -> [Operand] -> m () lit1 :: MonadAssembler m => BCONPtr -> m Word lit1 p = lit (OnlyOne p) @@ -603,20 +652,20 @@ assembleI platform i = case i of tuple_proto p <- ioptr (liftM BCOPtrBCO ul_bco) p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco) - info <- word (fromIntegral $ - mkNativeCallInfoSig platform call_info) + info <- lit $ word $ fromIntegral $ + mkNativeCallInfoSig platform call_info emit_ bci_PUSH_ALTS_T [Op p, Op info, Op p_tup] PUSH_PAD8 -> emit_ bci_PUSH_PAD8 [] PUSH_PAD16 -> emit_ bci_PUSH_PAD16 [] PUSH_PAD32 -> emit_ bci_PUSH_PAD32 [] - PUSH_UBX8 lit -> do np <- literal lit + PUSH_UBX8 litv -> do np <- lit $ literal platform litv emit_ bci_PUSH_UBX8 [Op np] - PUSH_UBX16 lit -> do np <- literal lit + PUSH_UBX16 litv -> do np <- lit $ literal platform litv emit_ bci_PUSH_UBX16 [Op np] - PUSH_UBX32 lit -> do np <- literal lit + PUSH_UBX32 litv -> do np <- lit $ literal platform litv emit_ bci_PUSH_UBX32 [Op np] - PUSH_UBX lit nws -> do np <- literal lit + PUSH_UBX litv nws -> do np <- lit $ literal platform litv emit_ bci_PUSH_UBX [Op np, wOp nws] -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode PUSH_ADDR nm -> do np <- lit1 (BCONPtrAddr nm) @@ -644,53 +693,53 @@ assembleI platform i = case i of PACK dcon sz -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon)) emit_ bci_PACK [Op itbl_no, wOp sz] LABEL lbl -> label lbl - TESTLT_I i l -> do np <- int i + TESTLT_I i l -> do np <- lit $ int i emit_ bci_TESTLT_I [Op np, LabelOp l] - TESTEQ_I i l -> do np <- int i + TESTEQ_I i l -> do np <- lit $ int i emit_ bci_TESTEQ_I [Op np, LabelOp l] - TESTLT_W w l -> do np <- word w + TESTLT_W w l -> do np <- lit $ word w emit_ bci_TESTLT_W [Op np, LabelOp l] - TESTEQ_W w l -> do np <- word w + TESTEQ_W w l -> do np <- lit $ word w emit_ bci_TESTEQ_W [Op np, LabelOp l] - TESTLT_I64 i l -> do np <- word64 (fromIntegral i) + TESTLT_I64 i l -> do np <- lit $ word64 platform (fromIntegral i) emit_ bci_TESTLT_I64 [Op np, LabelOp l] - TESTEQ_I64 i l -> do np <- word64 (fromIntegral i) + TESTEQ_I64 i l -> do np <- lit $ word64 platform (fromIntegral i) emit_ bci_TESTEQ_I64 [Op np, LabelOp l] - TESTLT_I32 i l -> do np <- word (fromIntegral i) + TESTLT_I32 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTLT_I32 [Op np, LabelOp l] - TESTEQ_I32 i l -> do np <- word (fromIntegral i) + TESTEQ_I32 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTEQ_I32 [Op np, LabelOp l] - TESTLT_I16 i l -> do np <- word (fromIntegral i) + TESTLT_I16 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTLT_I16 [Op np, LabelOp l] - TESTEQ_I16 i l -> do np <- word (fromIntegral i) + TESTEQ_I16 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTEQ_I16 [Op np, LabelOp l] - TESTLT_I8 i l -> do np <- word (fromIntegral i) + TESTLT_I8 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTLT_I8 [Op np, LabelOp l] - TESTEQ_I8 i l -> do np <- word (fromIntegral i) + TESTEQ_I8 i l -> do np <- lit $ word (fromIntegral i) emit_ bci_TESTEQ_I8 [Op np, LabelOp l] - TESTLT_W64 w l -> do np <- word64 w + TESTLT_W64 w l -> do np <- lit $ word64 platform w emit_ bci_TESTLT_W64 [Op np, LabelOp l] - TESTEQ_W64 w l -> do np <- word64 w + TESTEQ_W64 w l -> do np <- lit $ word64 platform w emit_ bci_TESTEQ_W64 [Op np, LabelOp l] - TESTLT_W32 w l -> do np <- word (fromIntegral w) + TESTLT_W32 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTLT_W32 [Op np, LabelOp l] - TESTEQ_W32 w l -> do np <- word (fromIntegral w) + TESTEQ_W32 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTEQ_W32 [Op np, LabelOp l] - TESTLT_W16 w l -> do np <- word (fromIntegral w) + TESTLT_W16 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTLT_W16 [Op np, LabelOp l] - TESTEQ_W16 w l -> do np <- word (fromIntegral w) + TESTEQ_W16 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTEQ_W16 [Op np, LabelOp l] - TESTLT_W8 w l -> do np <- word (fromIntegral w) + TESTLT_W8 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTLT_W8 [Op np, LabelOp l] - TESTEQ_W8 w l -> do np <- word (fromIntegral w) + TESTEQ_W8 w l -> do np <- lit $ word (fromIntegral w) emit_ bci_TESTEQ_W8 [Op np, LabelOp l] - TESTLT_F f l -> do np <- float f + TESTLT_F f l -> do np <- lit $ float platform f emit_ bci_TESTLT_F [Op np, LabelOp l] - TESTEQ_F f l -> do np <- float f + TESTEQ_F f l -> do np <- lit $ float platform f emit_ bci_TESTEQ_F [Op np, LabelOp l] - TESTLT_D d l -> do np <- double d + TESTLT_D d l -> do np <- lit $ double platform d emit_ bci_TESTLT_D [Op np, LabelOp l] - TESTEQ_D d l -> do np <- double d + TESTEQ_D d l -> do np <- lit $ double platform d emit_ bci_TESTEQ_D [Op np, LabelOp l] TESTLT_P i l -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l] TESTEQ_P i l -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l] @@ -864,84 +913,86 @@ assembleI platform i = case i of where unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width" - emit_ = emit word_size - - literal :: Literal -> m Word - literal (LitLabel fs _) = litlabel fs - literal LitNullAddr = word 0 - literal (LitFloat r) = float (fromRational r) - literal (LitDouble r) = double (fromRational r) - literal (LitChar c) = int (ord c) - literal (LitString bs) = lit1 (BCONPtrStr bs) - -- LitString requires a zero-terminator when emitted - literal (LitNumber nt i) = case nt of - LitNumInt -> word (fromIntegral i) - LitNumWord -> word (fromIntegral i) - LitNumInt8 -> word8 (fromIntegral i) - LitNumWord8 -> word8 (fromIntegral i) - LitNumInt16 -> word16 (fromIntegral i) - LitNumWord16 -> word16 (fromIntegral i) - LitNumInt32 -> word32 (fromIntegral i) - LitNumWord32 -> word32 (fromIntegral i) - LitNumInt64 -> word64 (fromIntegral i) - LitNumWord64 -> word64 (fromIntegral i) - LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" + emit_ = emit (platformWordSize platform) + +literal :: Platform -> Literal -> OneOrTwo BCONPtr +literal platform = \case + LitLabel fs _ -> OnlyOne (BCONPtrLbl fs) + LitNullAddr -> word 0 + LitFloat r -> float platform (fromRational r) + LitDouble r -> double platform (fromRational r) + LitChar c -> int (ord c) + LitString bs -> OnlyOne (BCONPtrStr bs) + -- LitString requires a zero-terminator when emitted + LitNumber nt i -> case nt of + LitNumInt -> word (fromIntegral i) + LitNumWord -> word (fromIntegral i) + LitNumInt8 -> word8 platform (fromIntegral i) + LitNumWord8 -> word8 platform (fromIntegral i) + LitNumInt16 -> word16 platform (fromIntegral i) + LitNumWord16 -> word16 platform (fromIntegral i) + LitNumInt32 -> word32 platform (fromIntegral i) + LitNumWord32 -> word32 platform (fromIntegral i) + LitNumInt64 -> word64 platform (fromIntegral i) + LitNumWord64 -> word64 platform (fromIntegral i) + LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most -- likely to elicit a crash (rather than corrupt memory) in case absence -- analysis messed up. - literal (LitRubbish {}) = word 0 - - litlabel fs = lit1 (BCONPtrLbl fs) - words ws = lit (fmap BCONPtrWord ws) - word w = words (OnlyOne w) - word2 w1 w2 = words (OnlyTwo w1 w2) - word_size = platformWordSize platform - word_size_bits = platformWordSizeInBits platform - - -- Make lists of host-sized words for literals, so that when the - -- words are placed in memory at increasing addresses, the - -- bit pattern is correct for the host's word size and endianness. - -- - -- Note that we only support host endianness == target endianness for now, - -- even with the external interpreter. This would need to be fixed to - -- support host endianness /= target endianness - int :: Int -> m Word - int i = word (fromIntegral i) - - float :: Float -> m Word - float f = word32 (castFloatToWord32 f) - - double :: Double -> m Word - double d = word64 (castDoubleToWord64 d) - - word64 :: Word64 -> m Word - word64 ww = case word_size of - PW4 -> - let !wl = fromIntegral ww - !wh = fromIntegral (ww `unsafeShiftR` 32) - in case platformByteOrder platform of - LittleEndian -> word2 wl wh - BigEndian -> word2 wh wl - PW8 -> word (fromIntegral ww) - - word8 :: Word8 -> m Word - word8 x = case platformByteOrder platform of - LittleEndian -> word (fromIntegral x) - BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8)) - - word16 :: Word16 -> m Word - word16 x = case platformByteOrder platform of - LittleEndian -> word (fromIntegral x) - BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16)) - - word32 :: Word32 -> m Word - word32 x = case platformByteOrder platform of - LittleEndian -> word (fromIntegral x) - BigEndian -> case word_size of - PW4 -> word (fromIntegral x) - PW8 -> word (fromIntegral x `unsafeShiftL` 32) + LitRubbish {} -> word 0 + +words :: OneOrTwo Word -> OneOrTwo BCONPtr +words ws = fmap BCONPtrWord ws + +word :: Word -> OneOrTwo BCONPtr +word w = words (OnlyOne w) +word2 :: Word -> Word -> OneOrTwo BCONPtr +word2 w1 w2 = words (OnlyTwo w1 w2) + +-- Make lists of host-sized words for literals, so that when the +-- words are placed in memory at increasing addresses, the +-- bit pattern is correct for the host's word size and endianness. +-- +-- Note that we only support host endianness == target endianness for now, +-- even with the external interpreter. This would need to be fixed to +-- support host endianness /= target endianness +int :: Int -> OneOrTwo BCONPtr +int i = word (fromIntegral i) + +float :: Platform -> Float -> OneOrTwo BCONPtr +float platform f = word32 platform (castFloatToWord32 f) + +double :: Platform -> Double -> OneOrTwo BCONPtr +double p d = word64 p (castDoubleToWord64 d) + +word64 :: Platform -> Word64 -> OneOrTwo BCONPtr +word64 platform ww = case platformWordSize platform of + PW4 -> + let !wl = fromIntegral ww + !wh = fromIntegral (ww `unsafeShiftR` 32) + in case platformByteOrder platform of + LittleEndian -> word2 wl wh + BigEndian -> word2 wh wl + PW8 -> word (fromIntegral ww) + +word8 :: Platform -> Word8 -> OneOrTwo BCONPtr +word8 platform x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (platformWordSizeInBits platform - 8)) + +word16 :: Platform -> Word16 -> OneOrTwo BCONPtr +word16 platform x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (platformWordSizeInBits platform - 16)) + +word32 :: Platform -> Word32 -> OneOrTwo BCONPtr +word32 platform x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> case platformWordSize platform of + PW4 -> word (fromIntegral x) + PW8 -> word (fromIntegral x `unsafeShiftL` 32) isLargeW :: Word -> Bool isLargeW n = n > 65535 ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -16,6 +16,7 @@ import GHC.Cmm.Type (Width) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name +import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Unique import GHC.Core.DataCon @@ -43,9 +44,63 @@ data ProtoBCO protoBCOBitmap :: [StgWord], protoBCOBitmapSize :: Word, protoBCOArity :: Int, - -- what the BCO came from, for debugging only + -- | What the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs } + -- | 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, + -- ^ The DataCon being constructed. + -- 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. + protoStaticConExpr :: CgStgRhs + -- ^ What the static con came from, for debugging only + } + +{- +Note [Static constructors in Bytecode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In bytecode, top-level 'StgRhsCon's are lowered to 'ProtoStaticCon' rather than +'ProtoBCO'. A 'ProtoStaticCon' represents directly a heap allocated data +constructor application. We can do this only for top-level 'StgRhsCon's, where +all the data arguments to the constructor are statically known. + +'StgRhsCon's which have free variables are compiled down to BCOs which push the +arguments and then 'PACK' the constructor, just like 'StgConApp's. + +Example: + + Haskell: + + data X = X Char# Char + x = X 'a'# 'b' + + Stg: + + x1 = GHC.Types.C#! ['b'#]; + X.x = X.X! ['a#' x2]; + + X.X = \r [arg1 arg2] X.X [arg1 arg2]; + + ByteCode: + ProtoStaticCon x1: + C# [Left 'b'#] + ProtoStaticCon X.x: + X.X [Left 'a'#, Right x1] + + ProtoBCO X.X: + PUSH_LL 0 1 + PACK X.X 2 + SLIDE 1 2 + RETURN P +-} -- | A local block label (e.g. identifying a case alternative). newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 } @@ -278,6 +333,11 @@ data BCInstr -- Printing bytecode instructions instance Outputable ProtoBCO where + ppr (ProtoStaticCon nm con args origin) + = text "ProtoStaticCon" <+> ppr nm <> colon + $$ nest 3 (pprStgRhsShort shortStgPprOpts origin) + $$ nest 3 (text "constructor: " <+> ppr con) + $$ nest 3 (text "sorted args: " <+> ppr args) ppr (ProtoBCO { protoBCOName = name , protoBCOInstrs = instrs , protoBCOBitmap = bitmap @@ -469,7 +529,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 ===================================== @@ -12,6 +12,7 @@ module GHC.ByteCode.Linker , lookupStaticPtr , lookupIE , linkFail + , BCOIx(..) ) where @@ -46,31 +47,68 @@ import Data.Array.Unboxed import Foreign.Ptr import GHC.Exts -{- +{- | Linking interpretables into something we can run -} - linkBCO :: Interp -> PkgsLoaded -> BytecodeLoaderState - -> NameEnv Int + -> NameEnv BCOIx + -- ^ A mapping from names to references to other BCOs + -- or static constructors in this group. -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp pkgs_loaded bytecode_state bco_ix - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do - -- fromIntegral Word -> Word64 should be a no op if Word is Word64 - -- otherwise it will result in a cast to longlong on 32bit systems. - (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0) - ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0) - let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits - return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian - , resolvedBCOArity = arity - , resolvedBCOInstrs = insns - , resolvedBCOBitmap = bitmap - , resolvedBCOLits = mkBCOByteArray lits' - , resolvedBCOPtrs = addListToSS emptySS ptrs - } +linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do + case unl_bco of + UnlinkedBCO _ arity insns + bitmap lits0 ptrs0 -> do + lits <- doLits lits0 + ptrs <- doPtrs ptrs0 + return ResolvedBCO + { resolvedBCOIsLE = isLittleEndian + , resolvedBCOArity = arity + , resolvedBCOInstrs = insns + , resolvedBCOBitmap = bitmap + , resolvedBCOLits = lits + , resolvedBCOPtrs = ptrs + } + + UnlinkedStaticCon + { unlinkedStaticConLits = lits0 + , unlinkedStaticConPtrs = ptrs0 + , unlinkedStaticConDataConName + , unlinkedStaticConIsUnlifted + } -> do + Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state unlinkedStaticConDataConName + lits <- doLits lits0 + ptrs <- doPtrs ptrs0 + return ResolvedStaticCon + { resolvedBCOIsLE = isLittleEndian + , resolvedStaticConInfoPtr = W# (int2Word# (addr2Int# itbl_ptr#)) + , resolvedStaticConArity = sizeFlatBag lits0 + sizeFlatBag ptrs0 + , resolvedStaticConLits = lits + , resolvedStaticConPtrs = ptrs + , resolvedStaticConIsUnlifted = unlinkedStaticConIsUnlifted + } + where + doLits lits0 = do + (lits :: [Word]) <- mapM (lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0) + let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits + return $ mkBCOByteArray lits' + doPtrs ptrs0 = addListToSS emptySS <$> do + mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0) + +-- | An index into a BCO or Static Constructor in this group. +-- +-- We distinguish between lifted and unlifted static constructors because +-- lifted ones get resolved by tying a knot, since there may be circular +-- dependencies between them, whereas unlifted ones get constructed in a first +-- pass. +data BCOIx = BCOIx !Int + | LiftedStaticConIx !Int + | UnliftedStaticConIx !Int + deriving (Eq, Ord, Show) lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of @@ -154,13 +192,16 @@ resolvePtr :: Interp -> PkgsLoaded -> BytecodeLoaderState - -> NameEnv Int + -> NameEnv BCOIx -> BCOPtr -> IO ResolvedBCOPtr resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of BCOPtrName nm - | Just ix <- lookupNameEnv bco_ix nm - -> return (ResolvedBCORef ix) -- ref to another BCO in this group + | Just bix <- lookupNameEnv bco_ix nm + -> return $ case bix of + BCOIx ix -> ResolvedBCORef ix + LiftedStaticConIx ix -> ResolvedStaticConRef ix + UnliftedStaticConIx ix -> ResolvedUnliftedStaticConRef ix | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -315,22 +315,39 @@ instance Binary CompiledByteCode where put_ bh bc_spt_entries instance Binary UnlinkedBCO where - get bh = - UnlinkedBCO - <$> getViaBinName bh - <*> get bh - <*> (Binary.decode <$> get bh) - <*> (Binary.decode <$> get bh) - <*> get bh - <*> get bh + get bh = do + t <- getByte bh + case t of + 0 -> UnlinkedBCO + <$> getViaBinName bh + <*> get bh + <*> (Binary.decode <$> get bh) + <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh + 1 -> UnlinkedStaticCon + <$> getViaBinName bh + <*> getViaBinName bh + <*> get bh + <*> get bh + <*> get bh + _ -> panic "Binary UnlinkedBCO: invalid byte" put_ bh UnlinkedBCO {..} = do + putByte bh 0 putViaBinName bh unlinkedBCOName put_ bh unlinkedBCOArity put_ bh $ Binary.encode unlinkedBCOInstrs put_ bh $ Binary.encode unlinkedBCOBitmap put_ bh unlinkedBCOLits put_ bh unlinkedBCOPtrs + put_ bh UnlinkedStaticCon {..} = do + putByte bh 1 + putViaBinName bh unlinkedStaticConName + putViaBinName bh unlinkedStaticConDataConName + put_ bh unlinkedStaticConLits + put_ bh unlinkedStaticConPtrs + put_ bh unlinkedStaticConIsUnlifted instance Binary BCOPtr where get bh = do ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -29,6 +29,7 @@ module GHC.ByteCode.Types ) where import GHC.Prelude +import qualified Data.ByteString.Char8 as BS8 import GHC.Data.FastString import GHC.Data.FlatBag @@ -248,16 +249,31 @@ data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns - unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap - unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + } + -- | An unlinked top-level static constructor + -- 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 + unlinkedStaticConIsUnlifted :: !Bool } instance NFData UnlinkedBCO where rnf UnlinkedBCO{..} = rnf unlinkedBCOLits `seq` rnf unlinkedBCOPtrs + rnf UnlinkedStaticCon{..} = + rnf unlinkedStaticConLits `seq` + rnf unlinkedStaticConPtrs data BCOPtr = BCOPtrName !Name @@ -270,6 +286,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 " ppr mod <> char '>' + data BCONPtr = BCONPtrWord {-# UNPACK #-} !Word | BCONPtrLbl !FastString @@ -287,6 +309,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 " ftext lbl <> char '>' + ppr (BCONPtrItbl nm) = text " ppr nm <> char '>' + ppr (BCONPtrAddr nm) = text " ppr nm <> char '>' + ppr (BCONPtrStr bs) = text " text (BS8.unpack bs) <> char '>' + ppr (BCONPtrFS fs) = text " ftext fs <> char '>' + ppr (BCONPtrFFIInfo _) = text "<FFIInfo>" + ppr (BCONPtrCostCentre bid) = text " ppr bid <> char '>' + instance NFData BCONPtr where rnf x = x `seq` () @@ -295,6 +327,12 @@ instance Outputable UnlinkedBCO where = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] + ppr (UnlinkedStaticCon nm dc_nm lits ptrs unl) + = 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 ptrs), text "ptrs" ] instance Binary FFIInfo where get bh = FFIInfo <$> get bh <*> get bh ===================================== compiler/GHC/Cmm/Liveness.hs ===================================== @@ -63,7 +63,7 @@ cmmGlobalLiveness platform graph = -- | On entry to the procedure, there had better not be any LocalReg's live-in. -- If you see this error it most likely means you are trying to use a variable --- without it being defined in the given scope. +-- without it being defined, or initialized, in the given scope. noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a noLiveOnEntry bid in_fact x = if nullRegSet in_fact then x ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1043,11 +1043,35 @@ linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods [] do_link [] = return [] do_link mods = do let flat = [ bco | bcos <- mods, bco <- bcos ] - names = map unlinkedBCOName flat - bco_ix = mkNameEnv (zip names [0..]) + unl_objs = filter isUnliftedObj flat + lif_objs = filter (not . isUnliftedObj) flat + unl_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] unl_objs) + lif_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] lif_objs) + bco_ix = plusNameEnv unl_objs_ix lif_objs_ix resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ] - hvrefs <- createBCOs interp resolved - return (zip names hvrefs) + hvrefs <- createBCOs interp resolved + return (zip (map mkBCOName $ unl_objs ++ lif_objs) hvrefs) + + mkBCOName UnlinkedBCO{unlinkedBCOName} + = unlinkedBCOName + mkBCOName UnlinkedStaticCon{unlinkedStaticConName} + = unlinkedStaticConName + + mkBCOIx ix + UnlinkedBCO{unlinkedBCOName} + = (unlinkedBCOName, BCOIx ix) + mkBCOIx ix + UnlinkedStaticCon + { unlinkedStaticConName + , unlinkedStaticConIsUnlifted } + | unlinkedStaticConIsUnlifted + = (unlinkedStaticConName, UnliftedStaticConIx ix) + | otherwise + = (unlinkedStaticConName, LiftedStaticConIx ix) + + isUnliftedObj = \case + UnlinkedStaticCon{..} -> unlinkedStaticConIsUnlifted + _ -> False -- | Useful to apply to the result of 'linkSomeBCOs' makeForeignNamedHValueRefs ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -301,6 +301,21 @@ argBits platform (rep : args) -- Compile code for the right-hand side of a top-level binding 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 + return ProtoStaticCon + { protoStaticConName = getName id + , protoStaticCon = dc + , protoStaticConData = [ case a of StgLitArg l -> Left l + StgVarArg i -> Right i + | (NonVoid a, _) <- args_offsets ] + , protoStaticConExpr = rhs + } schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do @@ -321,7 +336,6 @@ schemeTopBind (id, rhs) | otherwise = schemeR [{- No free variables -}] (getName id, rhs) - -- ----------------------------------------------------------------------------- -- schemeR @@ -341,22 +355,22 @@ schemeR :: [Id] -- Free vars of the RHS, ordered as they -- top-level things, which have no free vars. -> (Name, CgStgRhs) -> BcM ProtoBCO -schemeR fvs (nm, rhs) - = schemeR_wrk fvs nm rhs (collect rhs) +schemeR fvs (nm, rhs@(StgRhsClosure _ _ _ args body _)) + = schemeR_wrk fvs nm rhs (args, body) +schemeR fvs (nm, rhs@(StgRhsCon _cc dc cnum _ticks args _type)) + -- unlike top-level StgRhsCon, which are static (see schemeTopBind), + -- non-top-level StgRhsCon are compiled just like StgRhsClosure StgConApp + = schemeR_wrk fvs nm rhs ([], StgConApp dc cnum args []) -- If an expression is a lambda, return the -- list of arguments to the lambda (in R-to-L order) and the -- underlying expression -collect :: CgStgRhs -> ([Var], CgStgExpr) -collect (StgRhsClosure _ _ _ args body _) = (args, body) -collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args []) - schemeR_wrk :: [Id] -> Name -> CgStgRhs -- expression e, for debugging only - -> ([Var], CgStgExpr) -- result of collect on e + -> ([Var], CgStgExpr) -- the args and body of an StgRhsClosure -> BcM ProtoBCO schemeR_wrk fvs nm original_body (args, body) = do @@ -546,7 +560,9 @@ schemeE d s p (StgLet _ext binds body) = do sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss -- the arity of each rhs - arities = map (strictGenericLength . fst . collect) rhss + stgRhsArity (StgRhsClosure _ _ _ args _ _) = strictGenericLength args + stgRhsArity StgRhsCon{} = 0 + arities = map stgRhsArity rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1 word. d' and p' reflect the stack @@ -622,7 +638,7 @@ schemeE d s p (StgCase scrut bndr _ alts) and then compile the code as if it was just the expression E. -} --- Compile code to do a tail call. Specifically, push the fn, +-- | Compile code to do a tail call. Specifically, push the fn, -- slide the on-stack app back down to the sequel depth, -- and enter. Four cases: -- @@ -642,7 +658,6 @@ schemeE d s p (StgCase scrut bndr _ alts) -- -- 4. Otherwise, it must be a function call. Push the args -- right to left, SLIDE and ENTER. - schemeT :: StackDepth -- Stack depth -> Sequel -- Sequel depth -> BCEnv -- stack env ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -339,7 +339,7 @@ type DynTag = Int -- The tag on a *pointer* -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the --- tagging strategy; see tagConstr in rts/Interpreter.c. +-- tagging strategy; see tagConstr in rts/storage/ClosureMacros.h. isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1771,6 +1771,7 @@ emitPrimOp cfg primop = DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal + NewConAppObjOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ListThreadsOp -> alwaysExternal ClosureSizeOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -1165,6 +1165,7 @@ genPrim prof bound ty op = case op of AnyToAddrOp -> unhandledPrimop op MkApUpd0_Op -> unhandledPrimop op NewBCOOp -> unhandledPrimop op + NewConAppObjOp -> unhandledPrimop op UnpackClosureOp -> unhandledPrimop op ClosureSizeOp -> unhandledPrimop op GetApStackValOp -> unhandledPrimop op ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -1,11 +1,16 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnliftedNewtypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE KindSignatures #-} -- -- (c) The University of Glasgow 2002-2006 @@ -15,103 +20,321 @@ module GHCi.CreateBCO (createBCOs) where import Prelude -- See note [Why do we import Prelude here?] +import Data.List (sortBy) +import Data.Ord (comparing) import GHCi.ResolvedBCO import GHCi.RemoteTypes import GHCi.BreakArray import GHC.Data.SizedSeq +import Data.List (partition) +import Data.Graph import System.IO (fixIO) import Control.Monad import Data.Array.Base import Foreign hiding (newArray) -import Unsafe.Coerce (unsafeCoerce) +import Unsafe.Coerce (unsafeCoerce, unsafeCoerceUnlifted) import GHC.Arr ( Array(..) ) import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# ) import GHC.IO import Control.Exception ( ErrorCall(..) ) +{- +Note [Tying the knot in createBCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two passes for creating the BCOs: + +1. Allocate unlifted static cons, which are never mutual recursive, but may refer + to the array constructed in the second pass. + +2. Allocate BCOs and lifted static cons, which may have circular references + amongst themselves, and also refer to the unlifted cons allocated in the + first pass. + +Notably, it is crucial that all unlifted static cons are eagerly allocated, +returning an evaluated and properly tagged unlifted value, and that all +references to an unlifted static constructor use that unlifted value directly, +rather than a thunk, to preserve the unliftedness invariants. Not doing so +resulted in #25636, which was fixed by the commit introducing this Note. + +The unlifted static cons must be allocated in topological order, to ensure a +reference from one to another has already been allocated and can be promptly used. + +The BCOs and lifted cons are allocated in 'fixIO', where references to other +BCOs and static cons in the same group are resolved by writing into the +'PtrsArr' a thunk that indexes the recursively constructed array of BCOs. +References to unlifted cons are looked up in the array from the first pass and +must definitely not be thunks. + +References from unlifted cons to BCOs are resolved similarly by constructing a +thunk into the second pass array, hence why allocating the unlifted cons must +be inside of the 'fixIO'. +-} + createBCOs :: [ResolvedBCO] -> IO [HValueRef] -createBCOs bcos = do +createBCOs objs = do + + let (unl_objs, bcos) = partition isUnliftedObj objs + let n_bcos = length bcos - hvals <- fixIO $ \hvs -> do - let arr = listArray (0, n_bcos-1) hvs - mapM (createBCO arr) bcos - mapM mkRemoteRef hvals + -- See Note [Tying the knot in createBCOs] + (unl_hvals, hvals) <- fixIO $ \ ~(_, hvs) -> do + + let arr = listArray (0, n_bcos-1) hvs -createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue -createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian + -- First, construct the array of unlifted static cons. + -- + -- Top-level unlifted constructors are never mutual recursive, so we can do + -- this by filling the array in topological order. + -- + -- Lifted fields of unlifted data will store + -- thunks indexing the `arr` constructed by fixIO. + (unl_cons, unl_hvals) <- createUnliftedStaticCons unl_objs arr + + -- Second, construct the lifted BCOs and static cons which may have + -- (circular) references to one another in this group. References from this + -- group to the unlifted static cons will be resolved by looking them up in + -- the array constructed in the first pass. + hvals <- mapM (createBCO arr unl_cons) bcos + return (unl_hvals, hvals) + + mapM mkRemoteRef (unl_hvals ++ hvals) + + where + isUnliftedObj :: ResolvedBCO -> Bool + isUnliftedObj = \case + ResolvedStaticCon{..} -> resolvedStaticConIsUnlifted + _ -> False + +createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue +createBCO _ _ obj | resolvedBCOIsLE obj /= isLittleEndian = throwIO (ErrorCall $ unlines [ "The endianness of the ResolvedBCO does not match" , "the systems endianness. Using ghc and iserv in a" , "mixed endianness setup is not supported!" ]) -createBCO arr bco - = do linked_bco <- linkBCO' arr bco - -- Note [Updatable CAF BCOs] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Why do we need mkApUpd0 here? Otherwise top-level - -- interpreted CAFs don't get updated after evaluation. A - -- top-level BCO will evaluate itself and return its value - -- when entered, but it won't update itself. Wrapping the BCO - -- in an AP_UPD thunk will take care of the update for us. - -- - -- Furthermore: - -- (a) An AP thunk *must* point directly to a BCO - -- (b) A zero-arity BCO *must* be wrapped in an AP thunk - -- (c) An AP is always fully saturated, so we *can't* wrap - -- non-zero arity BCOs in an AP thunk. - -- - -- See #17424. - if (resolvedBCOArity bco > 0) - then return (HValue (unsafeCoerce linked_bco)) - else case mkApUpd0# linked_bco of { (# final_bco #) -> - return (HValue final_bco) } - - -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO -linkBCO' arr ResolvedBCO{..} = do - let - ptrs = ssElts resolvedBCOPtrs - n_ptrs = sizeSS resolvedBCOPtrs +createBCO arr unl_arr bco + = do linked_thing <- linkBCO' arr unl_arr bco + case linked_thing of + LinkedBCO bco_arity linked_bco -> do + -- Note [Updatable CAF BCOs] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Why do we need mkApUpd0 here? Otherwise top-level + -- interpreted CAFs don't get updated after evaluation. A + -- top-level BCO will evaluate itself and return its value + -- when entered, but it won't update itself. Wrapping the BCO + -- in an AP_UPD thunk will take care of the update for us. + -- + -- Furthermore: + -- (a) An AP thunk *must* point directly to a BCO + -- (b) A zero-arity BCO *must* be wrapped in an AP thunk + -- (c) An AP is always fully saturated, so we *can't* wrap + -- non-zero arity BCOs in an AP thunk. + -- + -- See #17424. + if (bco_arity > 0) + then return (HValue (unsafeCoerce linked_bco)) + else case mkApUpd0# linked_bco of { (# final_bco #) -> + return (HValue final_bco) } + LinkedStaticCon linked_static_con -> do + return linked_static_con + LinkedUnliftedStaticCon linked_static_con -> do + return $! forgetUnliftedHValue linked_static_con + +-- | The resulting of linking a BCO or static constructor +data LinkedBCO + = LinkedBCO !Int{-BCO arity-} BCO + | LinkedStaticCon HValue + | LinkedUnliftedStaticCon UnliftedHValue + +-- | Construct an array of unlifted constructor closures given a list of 'UnliftedStaticCons'. +-- +-- INVARIANT: Top-level unlifted constructors are never mutual recursive, so we +-- can do this by filling the array in topological order. +-- +-- Lifted fields of unlifted data will be filled by looking them up in the +-- given array of lifted resolved objs. +createUnliftedStaticCons + :: [ResolvedBCO] -- ^ 'UnliftedStaticCon's ONLY. + -> Array Int HValue -- ^ Lifted resolved objects + -> IO (UnlConsArr, [HValue]) + -- ^ Return both the array to look up the unlifted static constrs by 'BCOIx', + -- and a list with the same unlifted objects, albeit the unliftedness is + -- forgotten using 'forgetUnliftedHValue' (allowing them to be put into a + -- list and later combined with the heap values of lifted objects). +createUnliftedStaticCons objs lif_arr = do + + -- Get topologically sorted objs with their original indices + let topoSortedObjs = topSortObjs objs + unl_arr <- newUnlConsArr (length topoSortedObjs) - !(I# arity#) = resolvedBCOArity + -- Process objs in topological order, but write them at their original indexes + indexed_vs <- forM topoSortedObjs $ \(origIdx, obj) -> case obj of + ResolvedStaticCon{..} + | resolvedStaticConIsUnlifted + -> do + -- Because we topologically sort the objs, all unlifted references we + -- care about when linking this BCO will already be filled in. + -- The lifted ones are resolved by knot tying (see the fixIO above). + lbc <- linkBCO' lif_arr unl_arr obj + case lbc of + LinkedUnliftedStaticCon linked_static_con -> do + writeUnlConsArr origIdx linked_static_con unl_arr -- Write it to its original index position + return (origIdx, forgetUnliftedHValue linked_static_con) + _ -> error "createUnliftedStaticCons: unexpected lifted ResolvedBCO" + _ -> + error "createUnliftedStaticCons: unexpected lifted ResolvedBCO" - !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array] - barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr# - insns_barr = barr (getBCOByteArray resolvedBCOInstrs) - bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap) - literals_barr = barr (getBCOByteArray resolvedBCOLits) + -- Return them in the original order + let vs = map snd $ sortBy (comparing fst) indexed_vs + return (unl_arr, vs) + where + -- Return the topologically sorted objects with their original index. + topSortObjs :: [ResolvedBCO] -> [(Int, ResolvedBCO)] + topSortObjs objs = + let + edges = [ ((origIdx, obj), origIdx, getUnlDeps obj) + | (origIdx, obj) <- zip [0..] objs ] - PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs - IO $ \s -> - case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} + getUnlDeps :: ResolvedBCO -> [Int] + getUnlDeps (ResolvedStaticCon{..}) = + [ k | ptr <- ssElts resolvedStaticConPtrs + , ResolvedUnliftedStaticConRef k <- [ptr] ] + getUnlDeps _ = [] + (graph, vertexToNode, _keyToVertex) = graphFromEdges edges + sortedVertices = topSort graph + in + [ ix_obj | v <- sortedVertices + , let (ix_obj, _, _) = vertexToNode v ] + +linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO +linkBCO' arr unl_arr resolved_obj = + case resolved_obj of + ResolvedBCO{..} -> do + let + ptrs = ssElts resolvedBCOPtrs + n_ptrs = sizeSS resolvedBCOPtrs + + !(I# arity#) = resolvedBCOArity + + insns_barr = barr (getBCOByteArray resolvedBCOInstrs) + bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap) + literals_barr = barr (getBCOByteArray resolvedBCOLits) + + PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs + IO $ \s -> + case unsafeFreezeArray# marr s of { (# s, arr #) -> + case newBCO# insns_barr literals_barr arr arity# bitmap_barr s of + (# s, hval #) -> (# s, LinkedBCO resolvedBCOArity hval #) + } + ResolvedStaticCon{..} -> do + + let + ptrs = ssElts resolvedStaticConPtrs + n_ptrs = sizeSS resolvedStaticConPtrs + !(W# data_size#) = resolvedStaticConArity + + literals_barr = barr (getBCOByteArray resolvedStaticConLits) + + !(W# itbl_ptr_w#) = resolvedStaticConInfoPtr + !(Ptr itbl_ptr#) = Ptr (int2Addr# (word2Int# itbl_ptr_w#)) + + PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs + + IO $ \s -> + case unsafeFreezeArray# marr s of { (# s, arr #) -> + case newConAppObj# itbl_ptr# literals_barr arr data_size# s of + (# s, hval #) -> + if resolvedStaticConIsUnlifted then + (# s, LinkedUnliftedStaticCon (UnliftedHValue (unsafeCoerce# hval)) #) + else + (# s, LinkedStaticCon (HValue hval) #) + } + where + !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array] + barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr# -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr -mkPtrsArray arr n_ptrs ptrs = do +mkPtrsArray :: Array Int HValue -> UnlConsArr -> Word -> [ResolvedBCOPtr] -> IO PtrsArr +mkPtrsArray arr unl_arr n_ptrs ptrs = do marr <- newPtrsArray (fromIntegral n_ptrs) let fill (ResolvedBCORef n) i = writePtrsArrayHValue i (arr ! n) marr -- must be lazy! + fill (ResolvedStaticConRef n) i = do + writePtrsArrayHValue i (arr ! n) marr -- must be lazy! + fill (ResolvedUnliftedStaticConRef n) i = do + -- must be strict! we want to store the unlifted con, + -- not the arr indexing thunk. + !unl_val <- readUnlConsArr n unl_arr + writePtrsArrayHValue i unl_val marr fill (ResolvedBCOPtr r) i = do hv <- localRef r writePtrsArrayHValue i hv marr fill (ResolvedBCOStaticPtr r) i = do writePtrsArrayPtr i (fromRemotePtr r) marr fill (ResolvedBCOPtrBCO bco) i = do - bco <- linkBCO' arr bco - writePtrsArrayBCO i bco marr + obj <- linkBCO' arr unl_arr bco + case obj of + LinkedBCO _ bco -> + writePtrsArrayBCO i bco marr + LinkedStaticCon linked_static_con -> + writePtrsArrayHValue i linked_static_con marr + LinkedUnliftedStaticCon linked_static_con -> do + let !unl_val = forgetUnliftedHValue linked_static_con + writePtrsArrayHValue i unl_val marr fill (ResolvedBCOPtrBreakArray r) i = do BA mba <- localRef r writePtrsArrayMBA i mba marr zipWithM_ fill ptrs [0..] return marr +-------------------------------------------------------------------------------- +-- * Unlifted static constructors +-------------------------------------------------------------------------------- + +-- | A heap closure of unlifted type +type UnliftedHValue :: UnliftedType +newtype UnliftedHValue = UnliftedHValue (Any @UnliftedType) + +-- | Forget that a heap closure is unlifted, and return it as a lifted heap closure. +-- Note: Going the other way around for an arbitrary heap closure is totally unsafe! +forgetUnliftedHValue :: UnliftedHValue -> HValue +forgetUnliftedHValue (UnliftedHValue a) = HValue (unsafeCoerce# a) + +-- | A lifted array with unlifted static constructor 'UnliftedHValue's +data UnlConsArr = UnlConsArr (MutableArray# RealWorld UnliftedHValue) + +-- | Create a 'UnlConsArr' of the given size with all elements initialized to +-- an empty ByteArray# +newUnlConsArr :: Int -> IO UnlConsArr +newUnlConsArr (I# arr_size#) = IO $ \s -> + -- Zero value to initialize the array. + -- Would be better to use undefined but can't for unlifted values. + let !(EmptyArr emp_arr#) = emptyArr + in case newArray# arr_size# (UnliftedHValue (unsafeCoerceUnlifted emp_arr#)) s of + (# s, arr #) -> (# s, UnlConsArr arr #) + +-- | Write an unlifted contructor closure into a 'UnlConsArr' +writeUnlConsArr :: Int -> UnliftedHValue -> UnlConsArr -> IO () +writeUnlConsArr (I# i#) unl_hval (UnlConsArr unl_arr#) = IO $ \s -> + case writeArray# unl_arr# i# unl_hval s of + s -> (# s, () #) + +-- | Read an unlifted constructor closure from an 'UnlConsArr', +-- but forget that the heap closure is unlifted using 'forgetUnliftedHValue'. +-- This allows us to return it in @IO@ and return it in the final resolved objs list. +readUnlConsArr :: Int -> UnlConsArr -> IO HValue +readUnlConsArr (I# n#) (UnlConsArr unl_arr#) = IO $ \s -> + case readArray# unl_arr# n# s of + (# s, val #) -> (# s, forgetUnliftedHValue val #) + +-------------------------------------------------------------------------------- +-- * PtrsArr +-------------------------------------------------------------------------------- + data PtrsArr = PtrsArr (MutableArray# RealWorld HValue) newPtrsArray :: Int -> IO PtrsArr @@ -145,10 +368,9 @@ writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) -newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO -newBCO instrs lits ptrs arity bitmap = IO $ \s -> - newBCO# instrs lits ptrs arity bitmap s - +-------------------------------------------------------------------------------- +-- * Empty array +-------------------------------------------------------------------------------- {- Note [BCO empty array] ~~~~~~~~~~~~~~~~~~~~~~ Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free: @@ -165,3 +387,5 @@ emptyArr = unsafeDupablePerformIO $ IO $ \s -> case unsafeFreezeByteArray# arr s of { (# s, farr #) -> (# s, EmptyArr farr #) }} + + ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -47,6 +47,16 @@ data ResolvedBCO -- ^ non-ptrs - subword sized entries still take up a full (host) word resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs } + -- | A resolved static constructor + -- See Note [Static constructors in Bytecode] + | ResolvedStaticCon { + resolvedBCOIsLE :: Bool, + resolvedStaticConInfoPtr :: {-# UNPACK #-} !Word, -- ^ info ptr Addr# as a Word + resolvedStaticConArity :: {-# UNPACK #-} !Word, + resolvedStaticConLits :: BCOByteArray Word, + resolvedStaticConPtrs :: SizedSeq ResolvedBCOPtr, + resolvedStaticConIsUnlifted :: Bool + } deriving (Generic, Show) -- | Wrapper for a 'ByteArray#'. @@ -80,13 +90,27 @@ instance Show (BCOByteArray Word) where -- same endianness. instance Binary ResolvedBCO where put ResolvedBCO{..} = do + putWord8 0 put resolvedBCOIsLE put resolvedBCOArity put resolvedBCOInstrs put resolvedBCOBitmap put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + put ResolvedStaticCon{..} = do + putWord8 1 + put resolvedBCOIsLE + put resolvedStaticConInfoPtr + put resolvedStaticConArity + put resolvedStaticConLits + put resolvedStaticConPtrs + put resolvedStaticConIsUnlifted + get = do + t <- getWord8 + case t of + 0 -> ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + 1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get <*> get + _ -> error "Binary ResolvedBCO: invalid byte" -- See Note [BCOByteArray serialization] instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where @@ -96,7 +120,8 @@ instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) wher data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int - -- ^ reference to the Nth BCO in the current set + -- ^ reference to the Nth BCO in the current set of BCOs and + -- lifted static constructors | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue) -- ^ reference to a previously created BCO | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ()) @@ -105,6 +130,12 @@ data ResolvedBCOPtr -- ^ a nested BCO | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray) -- ^ Resolves to the MutableArray# inside the BreakArray + | ResolvedStaticConRef {-# UNPACK #-} !Int + -- ^ reference to the Nth static constructor in the current set of BCOs + -- and lifted static constructors + | ResolvedUnliftedStaticConRef {-# UNPACK #-} !Int + -- ^ reference to the Nth unlifted static constructor in the current set + -- of exclusively unlifted static constructors deriving (Generic, Show) instance Binary ResolvedBCOPtr ===================================== rts/Interpreter.c ===================================== @@ -709,14 +709,6 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } } -// Compute the pointer tag for the constructor and tag the pointer; -// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure. -// -// Note: we need to update this if we change the tagging strategy. -STATIC_INLINE StgClosure *tagConstr(StgClosure *con) { - return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con); -} - static StgWord app_ptrs_itbl[] = { (W_)&stg_ap_p_info, (W_)&stg_ap_pp_info, ===================================== rts/PrimOps.cmm ===================================== @@ -2208,6 +2208,44 @@ for: return (bco); } +// Ptr InfoTable, [Literals] [Ptrs] ==> CONSTR heap closure +stg_newConAppObjzh ( W_ datacon_info, P_ literals, P_ ptrs , W_ arity ) +{ + W_ con_obj, bytes; + + bytes = SIZEOF_StgHeader + WDS(arity); + + ALLOC_PRIM (bytes); + con_obj = Hp - bytes + WDS(1); + + // No memory barrier necessary as this is a new allocation. + SET_HDR(con_obj, datacon_info, CCS_MAIN); + + // Copy the ptrs followed by nonptrs into the constructor payload + W_ i, n_ptrs; + n_ptrs = StgMutArrPtrs_ptrs(ptrs); + i = 0; +loop1: + if (i < n_ptrs) { + StgClosure_payload(con_obj,i) = StgMutArrPtrs_payload(ptrs,i); + i = i + 1; + goto loop1; + } + i = 0; +loop2: + if (i < BYTE_ARR_WDS(literals)) { + W_ offset; + offset = n_ptrs + i; + StgClosure_payload(con_obj,offset) = StgArrBytes_payload(literals,i); + i = i + 1; + goto loop2; + } + + W_ tagged_con_obj; + (tagged_con_obj) = ccall tagConstr(con_obj); + return (tagged_con_obj); +} + stg_mkApUpd0zh ( P_ bco ) { W_ ap; ===================================== rts/RtsSymbols.c ===================================== @@ -634,6 +634,7 @@ extern char **environ; SymI_HasDataProto(stg_casSmallArrayzh) \ SymI_HasDataProto(stg_copyArray_barrier) \ SymI_HasDataProto(stg_newBCOzh) \ + SymI_HasDataProto(stg_newConAppObjzh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ @@ -655,7 +656,7 @@ extern char **environ; SymI_HasDataProto(stg_isMutableByteArrayWeaklyPinnedzh) \ SymI_HasDataProto(stg_shrinkMutableByteArrayzh) \ SymI_HasDataProto(stg_resizzeMutableByteArrayzh) \ - SymI_HasDataProto(stg_shrinkSmallMutableArrayzh) \ + SymI_HasDataProto(stg_shrinkSmallMutableArrayzh) \ SymI_HasProto(newSpark) \ SymI_HasProto(updateRemembSetPushThunk) \ SymI_HasProto(updateRemembSetPushThunk_) \ ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -140,6 +140,16 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con) return get_itbl(con)->srt; } +// Compute the pointer tag for the constructor and tag the pointer; +// see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure. +// +// Note: we need to update this if we change the tagging strategy. +EXTERN_INLINE StgClosure *tagConstr(StgClosure *con); +EXTERN_INLINE StgClosure *tagConstr(StgClosure *con) +{ + return TAG_CLOSURE(stg_min(TAG_MASK, 1 + GET_TAG(con)), con); +} + /* ----------------------------------------------------------------------------- Macros for building closures -------------------------------------------------------------------------- */ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -584,6 +584,7 @@ RTS_FUN_DECL(stg_runRWzh); RTS_FUN_DECL(stg_newBCOzh); RTS_FUN_DECL(stg_mkApUpd0zh); +RTS_FUN_DECL(stg_newConAppObjzh); RTS_FUN_DECL(stg_retryzh); RTS_FUN_DECL(stg_catchRetryzh); ===================================== testsuite/tests/codeGen/should_run/T23146/T25636.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== utils/deriveConstants/Main.hs ===================================== @@ -460,9 +460,10 @@ wanteds os = concat ,closureSize Both "StgAnnFrame" ,closureField C "StgAnnFrame" "ann" - ,closureSize Both "StgMutArrPtrs" - ,closureField Both "StgMutArrPtrs" "ptrs" - ,closureField Both "StgMutArrPtrs" "size" + ,closureSize Both "StgMutArrPtrs" + ,closureField Both "StgMutArrPtrs" "ptrs" + ,closureField Both "StgMutArrPtrs" "size" + ,closurePayload C "StgMutArrPtrs" "payload" ,closureSize Both "StgSmallMutArrPtrs" ,closureField Both "StgSmallMutArrPtrs" "ptrs" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fa83d730f5732be81d7641dfd0cf03f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fa83d730f5732be81d7641dfd0cf03f... You're receiving this email because of your account on gitlab.haskell.org.