Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: 5aaacfeb by Rodrigo Mesquita at 2025-12-18T18:42:33+00:00 +5% - - - - - 13 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - utils/genprimopcode/Main.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2099,6 +2099,9 @@ exceptionContextTyConKey = mkPreludeTyConUnique 420 unsafeUnpackJSStringUtf8ShShKey = mkPreludeMiscIdUnique 805 +staticConObjPrimTyConKey :: Unique +staticConObjPrimTyConKey = mkPreludeTyConUnique 501 + {- ************************************************************************ * * ===================================== compiler/GHC/Builtin/Types/Prim.hs ===================================== @@ -82,6 +82,7 @@ module GHC.Builtin.Types.Prim( stableNamePrimTyCon, mkStableNamePrimTy, compactPrimTyCon, compactPrimTy, bcoPrimTyCon, bcoPrimTy, + staticConObjPrimTyCon, staticConObjPrimTy, weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, stackSnapshotPrimTyCon, stackSnapshotPrimTy, @@ -309,7 +310,7 @@ charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int3 mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, - stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, + stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, staticConObjPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name @@ -347,6 +348,7 @@ stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyC compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon stackSnapshotPrimTyConName = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon +staticConObjPrimTyConName = mkPrimTc (fsLit "StaticConObj#") staticConObjPrimTyConKey staticConObjPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon promptTagPrimTyConName = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon @@ -1399,6 +1401,12 @@ bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy +-- A static constructor object is never a thunk, unlike BCOs +staticConObjPrimTy :: Type +staticConObjPrimTy = mkTyConTy staticConObjPrimTyCon +staticConObjPrimTyCon :: TyCon +staticConObjPrimTyCon = pcPrimTyCon0 staticConObjPrimTyConName unliftedRepTy + {- ************************************************************************ * * ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3909,6 +3909,9 @@ section "Bytecode operations" primtype BCO { Primitive bytecode type. } +primtype StaticConObj# + { Primitive static constructor allocated on the heap type. } + primop AddrToAnyOp "addrToAny#" GenPrimOp Addr# -> (# a_levpoly #) { Convert an 'Addr#' to a followable Any type. } @@ -3947,6 +3950,17 @@ primop NewBCOOp "newBCO#" GenPrimOp effect = ReadWriteEffect out_of_line = True +primop NewStaticConOp "newStaticCon#" GenPrimOp + Array# a -> Int# -> State# s -> (# State# s, StaticConObj# #) + { @'newStaticCon#' data size@ creates a new static constructor object. The + resulting object points to the given data laid out contiguously on a heap allocated location. + The first element of the @data@ array must be a pointer to the info table representing the + constructor, which will be followed by the rest of the data. The given + @size@ describes how many words should be allocated for the data. } + 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/Linker.hs ===================================== @@ -50,16 +50,17 @@ import Data.Array.Unboxed import Foreign.Ptr import GHC.Exts -{- +{- | Linking interpretables into something we can run -} - linkBCO :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks - -> NameEnv Int + -> NameEnv (Int, Bool) + -- ^ A mapping from names to int references to other BCOs or Static Constructors in this group. + -- The boolean identifies whether the referenced object is a BCO (when @True@) or a Static Constructor (when @False@) -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded le lb bco_ix @@ -80,7 +81,7 @@ linkBCO interp pkgs_loaded le lb bco_ix (UnlinkedStaticCon conName conArgs) = do all_data <- mapM (either doBCOPtr doBCONPtr) (Right (BCONPtrItbl conName):elemsFlatBag conArgs) return ResolvedStaticCon - { resolvedStaticConIsLE = isLittleEndian + { resolvedBCOIsLE = isLittleEndian , resolvedStaticConData = addListToSS emptySS all_data } where @@ -170,13 +171,16 @@ resolvePtr -> PkgsLoaded -> LinkerEnv -> LinkedBreaks - -> NameEnv Int + -> NameEnv (Int, Bool) -> BCOPtr -> IO ResolvedBCOPtr resolvePtr interp pkgs_loaded le lb 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 (ix, b) <- lookupNameEnv bco_ix nm + -> if b then + return (ResolvedBCORef ix) -- ref to another BCO in this group + else + return (ResolvedStaticConRef ix) -- ref to another StaticCon in this group | Just (_, rhv) <- lookupNameEnv (closure_env le) nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1025,11 +1025,13 @@ linkSomeBCOs interp pkgs_loaded le lb 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..]) + names = map (\case UnlinkedBCO{unlinkedBCOName} -> (unlinkedBCOName, True) + UnlinkedStaticCon{unlinkedStaticConName} -> (unlinkedStaticConName, False) + ) flat + bco_ix = mkNameEnv (zipWith (\(n,isBCO) ix -> (n,(ix, isBCO))) names [0..]) resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved - return (zip names hvrefs) + return (zipWith (\(n,_) hvr -> (n, hvr)) names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs' makeForeignNamedHValueRefs ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1772,6 +1772,7 @@ emitPrimOp cfg primop = DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal + NewStaticConOp -> 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 + NewStaticConOp -> unhandledPrimop op UnpackClosureOp -> unhandledPrimop op ClosureSizeOp -> unhandledPrimop op GetApStackValOp -> unhandledPrimop op ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -6,6 +6,8 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE KindSignatures #-} -- -- (c) The University of Glasgow 2002-2006 @@ -30,6 +32,7 @@ import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# ) import GHC.IO import Control.Exception ( ErrorCall(..) ) +import Data.Kind createBCOs :: [ResolvedBCO] -> IO [HValueRef] createBCOs bcos = do @@ -40,36 +43,39 @@ createBCOs bcos = do mapM mkRemoteRef hvals createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue -createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian +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 + = do linked_thing <- linkBCO' arr bco + case linked_thing of + LeftL 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 (resolvedBCOArity bco > 0) + then return (HValue (unsafeCoerce linked_bco)) + else case mkApUpd0# linked_bco of { (# final_bco #) -> + return (HValue final_bco) } + RightU linked_static_con -> do + return (HValue (unsafeCoerce linked_static_con)) + +linkBCO' :: Array Int HValue -> ResolvedBCO -> IO (EitherLU BCO StaticConObj#) linkBCO' arr ResolvedBCO{..} = do let ptrs = ssElts resolvedBCOPtrs @@ -83,21 +89,59 @@ linkBCO' arr ResolvedBCO{..} = do bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap) literals_barr = barr (getBCOByteArray resolvedBCOLits) - PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + PtrsArr marr <- mkPtrsArray arr n_ptrs (zip ptrs [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 }} +linkBCO' arr ResolvedStaticCon{..} = do + + let data_size@(I# data_size#) + = sizeSS resolvedStaticConData + data_els = ssElts resolvedStaticConData + + -- First, write pointers at the ptrs locations + PtrsArr marr <- mkPtrsArray arr data_size $ + mapMaybe (\case + (Left _,_) -> Nothing + (Right p,_) -> Just p + ) (zip data_els [0..]) + -- Second, write literals at the remaining location + writeLiterals marr $ + mapMaybe (\case + (Left l,_) -> Just l + (Right _,_) -> Nothing + ) (zip data_els [0..]) + IO $ \s -> + case unsafeFreezeArray# marr' s of { (# s, arr #) -> + newStaticCon# arr data_size# s + } + where + writeLiterals :: MutableArray# RealWorld Word -> [(Word, Int)] -> IO () + writeLiterals arr = mapM_ (uncurry (writeLiteral arr)) + + writeLiteral :: MutableArray# RealWorld Word -> Word -> Int -> IO () + writeLiteral arr w i = IO $ \s -> + case writeArray# arr i w s of s' -> (# s', () #) + +-- | Either for lifted @a@ and unlifted @b@ +data EitherLU (a :: Type) (b :: UnliftedType) = LeftL a | RightU b -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr +mkPtrsArray :: Array Int HValue -> Word -> [(ResolvedBCOPtr, Int{-index of array at which to write ResolvedBCOPtr-})] -> IO PtrsArr mkPtrsArray 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 + -- this MUST be /strict/! + -- the static con reference must be an evaluated pointer to the data con + -- info table, but (arr ! n) would construct a thunk instead if unforced. + let !hv = arr ! n + writePtrsArrayHValue i hv marr fill (ResolvedBCOPtr r) i = do hv <- localRef r writePtrsArrayHValue i hv marr @@ -109,7 +153,7 @@ mkPtrsArray arr n_ptrs ptrs = do fill (ResolvedBCOPtrBreakArray r) i = do BA mba <- localRef r writePtrsArrayMBA i mba marr - zipWithM_ fill ptrs [0..] + mapM_ fill ptrs return marr data PtrsArr = PtrsArr (MutableArray# RealWorld HValue) @@ -165,3 +209,5 @@ emptyArr = unsafeDupablePerformIO $ IO $ \s -> case unsafeFreezeByteArray# arr s of { (# s, farr #) -> (# s, EmptyArr farr #) }} + + ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -50,7 +50,7 @@ data ResolvedBCO -- | A resolved static constructor -- See Note [Static constructors in Bytecode] | ResolvedStaticCon { - resolvedStaticConIsLE :: Bool, + resolvedBCOIsLE :: Bool, resolvedStaticConData :: SizedSeq (Either ResolvedBCOPtr Word) -- ^ All the data to be laid contiguously for this static datacon. -- The first entry is the info table pointer for the datacon it represents. @@ -97,7 +97,7 @@ instance Binary ResolvedBCO where put resolvedBCOPtrs put ResolvedStaticCon{..} = do putWord8 1 - put resolvedStaticConIsLE + put resolvedBCOIsLE put resolvedStaticConData get = do t <- getWord8 @@ -123,6 +123,8 @@ 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 deriving (Generic, Show) instance Binary ResolvedBCOPtr ===================================== rts/PrimOps.cmm ===================================== @@ -2181,6 +2181,21 @@ for: return (bco); } +stg_newStaticConzh ( P_ data, W_ size ) +{ + W_ staticConObj, itbl, bytes; + + bytes = WDS(size); + + ALLOC_PRIM (bytes); + + staticConObj = Hp - bytes; + // No memory barrier necessary as this is a new allocation. + SET_HDR(staticConObj, stg_BCO_info, CCS_MAIN); + + TODOOOOOOO +} + 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_newStaticConzh) \ SymI_HasDataProto(stg_newByteArrayzh) \ SymI_HasDataProto(stg_casIntArrayzh) \ SymI_HasDataProto(stg_casInt8Arrayzh) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -583,6 +583,7 @@ RTS_FUN_DECL(stg_deRefWeakzh); RTS_FUN_DECL(stg_runRWzh); RTS_FUN_DECL(stg_newBCOzh); +RTS_FUN_DECL(stg_newStaticConzh); RTS_FUN_DECL(stg_mkApUpd0zh); RTS_FUN_DECL(stg_retryzh); ===================================== utils/genprimopcode/Main.hs ===================================== @@ -944,6 +944,7 @@ ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" ppType (TyApp (TyCon "BCO") []) = "bcoPrimTy" +ppType (TyApp (TyCon "StaticConObj#") []) = "staticConObjPrimTy" ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy" ppType (TyApp (TyCon "StackSnapshot#") []) = "stackSnapshotPrimTy" ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is GHC.Builtin.Types's name for () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5aaacfeb18855e50cafe15b6667ddf0b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5aaacfeb18855e50cafe15b6667ddf0b... You're receiving this email because of your account on gitlab.haskell.org.