Rodrigo Mesquita pushed to branch wip/romes/top-level-bcos-tag at Glasgow Haskell Compiler / GHC Commits: b9198caf by Rodrigo Mesquita at 2025-05-21T12:07:34+01:00 rts: Case continuation BCOs TODO - - - - - 15 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/Types.hs - compiler/GHC/StgToByteCode.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/PrimOps.cmm - rts/Printer.c - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3872,12 +3872,13 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp with out_of_line = True -primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) - { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +primop NewBCOOp "newBCO2#" GenPrimOp + Int8# -> ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO2#' is_case_cont instrs lits ptrs arity bitmap@ creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in @instrs@, and a static reference table usage bitmap given by - @bitmap@. } + @bitmap@. The @is_case_cont@ boolean indicates whether the BCO is a case + continuation (see Note [Case continuation BCOs]) } with effect = ReadWriteEffect out_of_line = True ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -85,7 +85,7 @@ bcoFreeNames :: UnlinkedBCO -> UniqDSet Name bcoFreeNames bco = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs _) = unionManyUniqDSets ( mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : @@ -236,7 +236,8 @@ assembleBCO platform , protoBCOInstrs = instrs , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do + , protoBCOArity = arity + , protoBCOIsCaseCont = isCC }) = do -- pass 1: collect up the offsets of the local labels. let initial_offset = 0 @@ -266,7 +267,7 @@ assembleBCO platform let !insns_arr = mkBCOByteArray $ final_isn_array !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array) isCC -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -53,7 +53,8 @@ data ProtoBCO a -- what the BCO came from, for debugging only protoBCOExpr :: Either [CgStgAlt] CgStgRhs, -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOFFIs :: [FFIInfo], + protoBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } -- | A local block label (e.g. identifying a case alternative). ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -59,7 +59,7 @@ linkBCO -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded le bco_ix - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0 isCC) = 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 le) (elemsFlatBag lits0) @@ -69,7 +69,7 @@ linkBCO interp pkgs_loaded le bco_ix insns bitmap (mkBCOByteArray lits') - (addListToSS emptySS ptrs)) + (addListToSS emptySS ptrs) isCC) lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded le ptr = case ptr of ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -167,14 +167,28 @@ newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable) newtype AddrPtr = AddrPtr (RemotePtr ()) deriving (NFData) +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Does the BCO code depend on stack-pointer-relative offsets? +... why +... example +-} + data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns - unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr), -- ptrs + unlinkedBCOIsCaseCont :: !Bool -- See Note [Case continuation BCOs] } instance NFData UnlinkedBCO where @@ -227,10 +241,11 @@ seqCgBreakInfo CgBreakInfo{..} = rnf cgb_resty instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs pi) = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", - ppr (sizeFlatBag ptrs), text "ptrs" ] + ppr (sizeFlatBag ptrs), text "ptrs", + ppr pi, text "is_pos_indep"] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -253,7 +253,11 @@ mkProtoBCO -> Int -- ^ arity -> WordOff -- ^ bitmap size -> [StgWord] -- ^ bitmap - -> Bool -- ^ True <=> is a return point, rather than a function + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- Used for + -- (A) Stack check collision and + -- (B) Mark the BCO wrt whether it contains non-local stack + -- references. See Note [Case continuation BCOs]. -> [FFIInfo] -> ProtoBCO Name mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis @@ -264,7 +268,8 @@ mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bit protoBCOBitmapSize = fromIntegral bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, - protoBCOFFIs = ffis + protoBCOFFIs = ffis, + protoBCOIsCaseCont = is_ret } where #if MIN_VERSION_rts(1,0,3) @@ -353,6 +358,9 @@ schemeTopBind (id, rhs) -- Park the resulting BCO in the monad. Also requires the -- name of the variable to which this value was bound, -- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack directly before it. schemeR :: [Id] -- Free vars of the RHS, ordered as they -- will appear in the thunk. Empty for -- top-level things, which have no free vars. @@ -391,6 +399,8 @@ schemeR_wrk fvs nm original_body (args, body) -- them unlike constructor fields. szsb_args = map (wordsToBytes platform . idSizeW platform) all_args sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap @@ -1401,7 +1411,7 @@ Note [unboxed tuple bytecodes and tuple_BCO] tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name tupleBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The tuple BCO is never referred to by name, so we can get away @@ -1422,7 +1432,7 @@ tupleBCO platform args_info args = primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name primCallBCO platform args_info args = mkProtoBCO platform Nothing invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} + 0{-no arity-} bitmap_size bitmap False{-not alts-} where {- The primcall BCO is never referred to by name, so we can get away ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -26,12 +26,12 @@ module GHC.Exts -- ** Legacy interface for arrays of arrays module GHC.Internal.ArrayArray, -- * Primitive operations - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} + {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 10.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.BCO, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} Prim.mkApUpd0#, {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.newBCO#, + IExts.newBCO#, module GHC.Prim, module GHC.Prim.Ext, -- ** Running 'RealWorld' state thread @@ -119,7 +119,7 @@ module GHC.Exts maxTupleSize ) where -import GHC.Internal.Exts +import GHC.Internal.Exts hiding ( newBCO# ) import GHC.Internal.ArrayArray import GHC.Prim hiding ( coerce @@ -132,7 +132,7 @@ import GHC.Prim hiding , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# -- deprecated - , BCO, mkApUpd0#, newBCO# + , BCO, mkApUpd0# -- Don't re-export vector FMA instructions , fmaddFloatX4# @@ -256,8 +256,10 @@ import GHC.Prim hiding , minWord8X32# , minWord8X64# ) +import qualified GHC.Internal.Exts as IExts + ( newBCO# ) import qualified GHC.Prim as Prim - ( BCO, mkApUpd0#, newBCO# ) + ( BCO, mkApUpd0# ) import GHC.Prim.Ext ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -163,6 +163,9 @@ module GHC.Internal.Exts -- * The maximum tuple size maxTupleSize, + + -- * Interpreter + newBCO# ) where import GHC.Internal.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge#, whereFrom# ) @@ -469,3 +472,18 @@ resizeSmallMutableArray# arr0 szNew a s0 = -- accessible\" by word. considerAccessible :: Bool considerAccessible = True + +-------------------------------------------------------------------------------- +-- Interpreter + +{-| +@'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The +resulting object encodes a function of the given arity with the instructions +encoded in @instrs@, and a static reference table usage bitmap given by +@bitmap@. + +Note: Case continuation BCOs, with non-local stack references, must be +constructed using @'newBCO2#' 1@ instead. See Note [Case continuation BCOs]. +-} +newBCO# :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) +newBCO# b1 b2 a1 i1 b3 s = newBCO2# (intToInt8# 0#) b1 b2 a1 i1 b3 s ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -87,11 +87,11 @@ linkBCO' arr ResolvedBCO{..} = do literals_barr = barr (getBCOByteArray resolvedBCOLits) PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + let is_case_cont | resolvedBCOIsCaseCont = intToInt8# 1# + | otherwise = intToInt8# 0# IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> - case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> - io s - }} + newBCO2# is_case_cont insns_barr literals_barr arr arity# bitmap_barr s } -- we recursively link any sub-BCOs while making the ptrs array ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -45,7 +45,8 @@ 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 + resolvedBCOIsCaseCont :: !Bool -- ^ See Note [Case continuation BCOs] } deriving (Generic, Show) @@ -86,7 +87,8 @@ instance Binary ResolvedBCO where put resolvedBCOBitmap put resolvedBCOLits put resolvedBCOPtrs - get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get + put resolvedBCOIsCaseCont + get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get <*> get -- See Note [BCOByteArray serialization] instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) where ===================================== rts/PrimOps.cmm ===================================== @@ -55,6 +55,7 @@ import CLOSURE stg_AP_STACK_info; import CLOSURE stg_AP_info; import CLOSURE stg_ARR_WORDS_info; import CLOSURE stg_BCO_info; +import CLOSURE stg_CASE_CONT_BCO_info; import CLOSURE stg_C_FINALIZER_LIST_info; import CLOSURE stg_DEAD_WEAK_info; import CLOSURE stg_END_STM_WATCH_QUEUE_closure; @@ -2434,7 +2435,8 @@ stg_deRefStablePtrzh ( P_ sp ) Bytecode object primitives ------------------------------------------------------------------------- */ -stg_newBCOzh ( P_ instrs, +stg_newBCO2zh ( CBool is_case_cont, + P_ instrs, P_ literals, P_ ptrs, W_ arity, @@ -2449,7 +2451,16 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); // No memory barrier necessary as this is a new allocation. - SET_HDR(bco, stg_BCO_info, CCS_MAIN); + if (is_case_cont > 0) { + /* Uses stg_CASE_CONT_BCO_info to construct the BCO frame (rather than stg_BCO_info). + * Case continuations may contain non-local references to parent frames. The distinct info table + * tag allows the RTS to identify such non-local frames. + * See Note [Case continuation BCOs] + */ + SET_HDR(bco, stg_CASE_CONT_BCO_info, CCS_MAIN); + } else { + SET_HDR(bco, stg_BCO_info, CCS_MAIN); + } StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; ===================================== rts/Printer.c ===================================== @@ -690,6 +690,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("stg_ctoi_V_info" ); } else if (c == (StgWord)&stg_BCO_info) { debugBelch("stg_BCO_info" ); + } else if (c == (StgWord)&stg_CASE_CONT_BCO_info) { + debugBelch("stg_CASE_CONT_BCO_info" ); } else if (c == (StgWord)&stg_apply_interp_info) { debugBelch("stg_apply_interp_info" ); } else if (c == (StgWord)&stg_ret_t_info) { ===================================== rts/RtsSymbols.c ===================================== @@ -639,7 +639,7 @@ extern char **environ; SymI_HasDataProto(stg_copySmallMutableArrayzh) \ SymI_HasDataProto(stg_casSmallArrayzh) \ SymI_HasDataProto(stg_copyArray_barrier) \ - SymI_HasDataProto(stg_newBCOzh) \ + SymI_HasDataProto(stg_newBCO2zh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -464,6 +464,11 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL, /* ---------------------------------------------------------------------------- Entry code for a BCO + + `stg_BCO` and `stg_CASE_CONT_BCO` distinguish between a BCO that refers to + non-local variables in its code (using a stack offset) and those that do not. + Only case-continuation BCOs should use non-local variables. + Otherwise, `stg_BCO` and `stg_CASE_CONT_BCO` behave the same. ------------------------------------------------------------------------- */ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) @@ -478,6 +483,15 @@ INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) jump stg_yield_to_interpreter []; } +INFO_TABLE_FUN( stg_CASE_CONT_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO ) +{ + /* Exactly as for stg_BCO */ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_apply_interp_info; + jump stg_yield_to_interpreter []; +} + /* ---------------------------------------------------------------------------- Info tables for indirections. ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -180,6 +180,7 @@ RTS_ENTRY(stg_BLOCKING_QUEUE_CLEAN); RTS_ENTRY(stg_BLOCKING_QUEUE_DIRTY); RTS_FUN(stg_BCO); +RTS_FUN(stg_CASE_CONT_BCO); RTS_ENTRY(stg_EVACUATED); RTS_ENTRY(stg_WEAK); RTS_ENTRY(stg_DEAD_WEAK); @@ -577,7 +578,7 @@ RTS_FUN_DECL(stg_deRefWeakzh); RTS_FUN_DECL(stg_runRWzh); -RTS_FUN_DECL(stg_newBCOzh); +RTS_FUN_DECL(stg_newBCO2zh); RTS_FUN_DECL(stg_mkApUpd0zh); RTS_FUN_DECL(stg_retryzh); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9198caf9e1955e255325de5c5414067... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9198caf9e1955e255325de5c5414067... You're receiving this email because of your account on gitlab.haskell.org.