Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 36eed985 by Cheng Shao at 2026-03-26T03:57:03-04:00 ghc-boot: move GHC.Data.SmallArray to ghc-boot This commit moves `GHC.Data.SmallArray` from the `ghc` library to `ghc-boot`, so that it can be used by `ghci` as well: - The `Binary` (from `ghc`) instance of `SmallArray` is moved to `GHC.Utils.Binary` - Util functions `replicateSmallArrayIO`, `mapSmallArrayIO`, `mapSmallArrayM_`, `imapSmallArrayM_` , `smallArrayFromList` and `smallArrayToList` are added - The `Show` instance is added - The `Binary` (from `binary`) instance is added - - - - - fdf828ae by Cheng Shao at 2026-03-26T03:57:03-04:00 compiler: use `Binary` instance of `BCOByteArray` for bytecode objects This commit defines `Binary` (from `compiler`) instance of `BCOByteArray` which serializes the underlying buffer directly, and uses it directly in bytecode object serialization. Previously we reuse the `Binary` (from `binary`) instance, and this change allows us to avoid double-copying via an intermediate `ByteString` when using `put`/`get` in `binnary`. Also see added comment for explanation. - - - - - 3bf62d0a by Cheng Shao at 2026-03-26T03:57:03-04:00 ghci: use SmallArray directly in ResolvedBCO This patch makes ghci use `SmallArray` directly in `ResolvedBCO` when applicable, making the memory representation more compact and reducing marshaling overhead. Closes #27058. - - - - - 10 changed files: - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - compiler/GHC/Data/SmallArray.hs → libraries/ghc-boot/GHC/Data/SmallArray.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -29,7 +29,7 @@ import GHC.Unit.Types import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.SizedSeq +import GHC.Data.SmallArray import GHC.Linker.Types @@ -43,7 +43,10 @@ import GHC.Types.Unique.DFM -- Standard libraries import Control.Concurrent -import Data.Array.Unboxed +import Control.Monad +import Data.Array.Base +import Data.Array.IO.Internals +import Data.Functor import Foreign.Ptr import GHC.Exts @@ -62,15 +65,18 @@ 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 + litsMut <- unsafeNewArray_ (0, fromIntegral (sizeFlatBag lits0) - 1) + foldM_ (\(!i) lit -> (unsafeWrite litsMut i =<< lookupLiteral interp pkgs_loaded bytecode_state lit) $> succ i) 0 lits0 + lits <- unsafeFreezeIOUArray litsMut + ptrsMut <- newSmallArrayIO (fromIntegral (sizeFlatBag ptrs0)) undefined + foldM_ (\(!i) ptr -> (writeSmallArrayIO ptrsMut i =<< resolvePtr interp pkgs_loaded bytecode_state bco_ix ptr) $> succ i) 0 ptrs0 + ptrs <- unsafeFreezeSmallArrayIO ptrsMut return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian , resolvedBCOArity = arity , resolvedBCOInstrs = insns , resolvedBCOBitmap = bitmap - , resolvedBCOLits = mkBCOByteArray lits' - , resolvedBCOPtrs = addListToSS emptySS ptrs + , resolvedBCOLits = mkBCOByteArray lits + , resolvedBCOPtrs = ptrs } lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} -- Orphans are here since the Binary instances use an ad-hoc means of serialising @@ -20,7 +21,7 @@ module GHC.ByteCode.Serialize where import Control.Monad -import Data.Binary qualified as Binary +import Data.ByteString.Short (ShortByteString(..)) import Data.Foldable import Data.IORef import Data.Proxy @@ -320,19 +321,30 @@ instance Binary UnlinkedBCO where UnlinkedBCO <$> getViaBinName bh <*> get bh - <*> (Binary.decode <$> get bh) - <*> (Binary.decode <$> get bh) + <*> get bh + <*> get bh <*> get bh <*> get bh put_ bh UnlinkedBCO {..} = do putViaBinName bh unlinkedBCOName put_ bh unlinkedBCOArity - put_ bh $ Binary.encode unlinkedBCOInstrs - put_ bh $ Binary.encode unlinkedBCOBitmap + put_ bh unlinkedBCOInstrs + put_ bh unlinkedBCOBitmap put_ bh unlinkedBCOLits put_ bh unlinkedBCOPtrs +-- Also see Note [BCOByteArray serialization]. This instance is unlike +-- the `Binary` instances in `ghci`, which are for the `Binary` class +-- in `binary` and are used across host/target platforms; here this +-- instance is only used on the host for bytecode object serialization +-- and doesn't cross host/target boundary. Therefore it's safe to +-- serialize the underlying buffer directly. +instance Binary (BCOByteArray a) where + put_ bh (BCOByteArray ba#) = put_ bh $ SBS ba# + + get bh = (\(SBS ba#) -> BCOByteArray ba#) <$> get bh + instance Binary BCOPtr where get bh = do t <- getByte bh ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -132,6 +132,7 @@ import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc import GHC.Types.Unique +import GHC.Data.SmallArray import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) import GHCi.FFI @@ -975,6 +976,15 @@ instance (Ix a, Binary a, Binary b) => Binary (Array a b) where xs <- get bh return $ listArray bounds xs +instance Binary a => Binary (SmallArray a) where + put_ bh sa = do + put_ bh $ sizeofSmallArray sa + mapSmallArrayM_ (put_ bh) sa + + get bh = do + n <- get bh + replicateSmallArrayIO n $ get bh + instance (Binary a, Binary b) => Binary (a,b) where put_ bh (a,b) = do put_ bh a; put_ bh b get bh = do a <- get bh ===================================== compiler/ghc.cabal.in ===================================== @@ -461,7 +461,6 @@ Library GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair - GHC.Data.SmallArray GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer ===================================== compiler/GHC/Data/SmallArray.hs → libraries/ghc-boot/GHC/Data/SmallArray.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Small-array module GHC.Data.SmallArray @@ -13,8 +15,14 @@ module GHC.Data.SmallArray , indexSmallArray , sizeofSmallArray , listToArray + , smallArrayFromList + , smallArrayToList , mapSmallArray , foldMapSmallArray + , replicateSmallArrayIO + , mapSmallArrayIO + , mapSmallArrayM_ + , imapSmallArrayM_ , rnfSmallArray -- * IO Operations @@ -26,12 +34,13 @@ module GHC.Data.SmallArray where import GHC.Exts -import GHC.Prelude import GHC.IO import GHC.ST -import GHC.Utils.Binary import Control.DeepSeq +import Control.Monad +import Data.Binary import Data.Foldable +import Data.List (unfoldr) data SmallArray a = SmallArray (SmallArray# a) @@ -39,6 +48,17 @@ data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) type SmallMutableArrayIO a = SmallMutableArray RealWorld a +instance Binary a => Binary (SmallArray a) where + put sa = put (sizeofSmallArray sa) *> foldMapSmallArray put sa + + get = do + n <- get + smallArrayFromList <$> replicateM n get + + +instance Show a => Show (SmallArray a) where + showsPrec p = showsPrec p . smallArrayToList + newSmallArray :: Int -- ^ size -> a -- ^ initial contents @@ -142,6 +162,45 @@ foldMapSmallArray f sa = go 0 | i < n = f (indexSmallArray sa i) `mappend` go (i + 1) | otherwise = mempty +-- | Execute the 'IO' action the given number of times and store the +-- results in a 'SmallArray'. +{-# INLINE replicateSmallArrayIO #-} +replicateSmallArrayIO :: Int -> IO a -> IO (SmallArray a) +replicateSmallArrayIO n m = do + arr <- newSmallArrayIO n undefined + let go i + | i < n = do + writeSmallArrayIO arr i =<< m + go $ succ i + | otherwise = pure () + go 0 + unsafeFreezeSmallArrayIO arr + +-- | Apply the 'IO' action to every element, producing a new +-- 'SmallArray'. +{-# INLINE mapSmallArrayIO #-} +mapSmallArrayIO :: (a -> IO b) -> SmallArray a -> IO (SmallArray b) +mapSmallArrayIO f sa = do + ma <- newSmallArrayIO (sizeofSmallArray sa) undefined + flip imapSmallArrayM_ sa $ \i v -> writeSmallArrayIO ma i =<< f v + unsafeFreezeSmallArrayIO ma + +-- | Apply the monadic action to every element, ignoring the results. +{-# INLINE mapSmallArrayM_ #-} +mapSmallArrayM_ :: Applicative f => (a -> f b) -> SmallArray a -> f () +mapSmallArrayM_ f = imapSmallArrayM_ (\_ v -> f v) + +-- | Apply the monadic action to every element and its index, ignoring +-- the results. +{-# INLINE imapSmallArrayM_ #-} +imapSmallArrayM_ :: Applicative f => (Int -> a -> f b) -> SmallArray a -> f () +imapSmallArrayM_ f sa = go 0 + where + n = sizeofSmallArray sa + go i + | i < n = f i (indexSmallArray sa i) *> go (succ i) + | otherwise = pure () + -- | Force the elements of the given 'SmallArray' -- rnfSmallArray :: NFData a => SmallArray a -> () @@ -169,16 +228,27 @@ listToArray (I# size) index_of value_of xs = runST $ ST \s -> s'' -> case unsafeFreezeSmallArray# ma s'' of (# s''', a #) -> (# s''', SmallArray a #) -instance (Binary a) => Binary (SmallArray a) where - get bh = do - len <- get bh - ma <- newSmallArrayIO len undefined - for_ [0 .. len - 1] $ \i -> do - a <- get bh - writeSmallArrayIO ma i a - unsafeFreezeSmallArrayIO ma - - put_ bh sa = do - let len = sizeofSmallArray sa - put_ bh len - for_ [0 .. len - 1] $ \i -> put_ bh $ sa `indexSmallArray` i +-- | Construct a 'SmallArray' from a list. This is different from +-- 'listToArray' since the list elements fill the 'SmallArray' +-- sequentially without recalculating the indices or remapping to +-- other element types. +{-# INLINE smallArrayFromList #-} +smallArrayFromList :: [a] -> SmallArray a +smallArrayFromList vs = runST $ ST $ \s0 -> + case newSmallArray (length vs) undefined s0 of + (# s1, ma #) -> + case foldlM (\i v -> ST $ \s0 -> + case writeSmallArray ma i v s0 of + s1 -> (# s1, succ i #)) 0 vs of + ST m -> case m s1 of + (# s2, _ #) -> unsafeFreezeSmallArray ma s2 + +-- | Construct a list from a 'SmallArray'. +{-# INLINE smallArrayToList #-} +smallArrayToList :: SmallArray a -> [a] +smallArrayToList sa = unfoldr go 0 + where + n = sizeofSmallArray sa + go i + | i < n = Just (indexSmallArray sa i, succ i) + | otherwise = Nothing ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -45,7 +45,7 @@ Flag bootstrap Manual: True Library - default-language: Haskell2010 + default-language: GHC2024 other-extensions: DeriveGeneric, RankNTypes, ScopedTypeVariables default-extensions: NoImplicitPrelude @@ -53,6 +53,7 @@ Library GHC.BaseDir GHC.Data.ShortText GHC.Data.SizedSeq + GHC.Data.SmallArray GHC.Utils.Encoding GHC.Utils.Encoding.UTF8 GHC.LanguageExtensions ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -18,10 +18,9 @@ import Prelude -- See note [Why do we import Prelude here?] import GHCi.ResolvedBCO import GHCi.RemoteTypes import GHCi.BreakArray -import GHC.Data.SizedSeq +import GHC.Data.SmallArray import System.IO (fixIO) -import Control.Monad import Data.Array.Base import Foreign hiding (newArray) import Unsafe.Coerce (unsafeCoerce) @@ -72,9 +71,6 @@ createBCO arr bco linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO linkBCO' arr ResolvedBCO{..} = do let - ptrs = ssElts resolvedBCOPtrs - n_ptrs = sizeSS resolvedBCOPtrs - !(I# arity#) = resolvedBCOArity !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array] @@ -83,7 +79,7 @@ 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 resolvedBCOPtrs IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io -> @@ -92,24 +88,25 @@ linkBCO' arr ResolvedBCO{..} = do -- 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 - marr <- newPtrsArray (fromIntegral n_ptrs) +mkPtrsArray :: Array Int HValue -> SmallArray ResolvedBCOPtr -> IO PtrsArr +mkPtrsArray arr ptrs = do + let n_ptrs = sizeofSmallArray ptrs + marr <- newPtrsArray n_ptrs let - fill (ResolvedBCORef n) i = + fill i (ResolvedBCORef n) = writePtrsArrayHValue i (arr ! n) marr -- must be lazy! - fill (ResolvedBCOPtr r) i = do + fill i (ResolvedBCOPtr r) = do hv <- localRef r writePtrsArrayHValue i hv marr - fill (ResolvedBCOStaticPtr r) i = do + fill i (ResolvedBCOStaticPtr r) = do writePtrsArrayPtr i (fromRemotePtr r) marr - fill (ResolvedBCOPtrBCO bco) i = do + fill i (ResolvedBCOPtrBCO bco) = do bco <- linkBCO' arr bco writePtrsArrayBCO i bco marr - fill (ResolvedBCOPtrBreakArray r) i = do + fill i (ResolvedBCOPtrBreakArray r) = do BA mba <- localRef r writePtrsArrayMBA i mba marr - zipWithM_ fill ptrs [0..] + imapSmallArrayM_ fill ptrs return marr data PtrsArr = PtrsArr (MutableArray# RealWorld HValue) ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -12,7 +12,7 @@ module GHCi.ResolvedBCO #include "MachDeps.h" import Prelude -- See note [Why do we import Prelude here?] -import GHC.Data.SizedSeq +import GHC.Data.SmallArray import GHCi.RemoteTypes import GHCi.BreakArray @@ -51,13 +51,13 @@ isLittleEndian = True -- data ResolvedBCO = ResolvedBCO { - resolvedBCOIsLE :: Bool, + resolvedBCOIsLE :: !Bool, resolvedBCOArity :: {-# UNPACK #-} !Int, - resolvedBCOInstrs :: BCOByteArray Word16, -- ^ insns - resolvedBCOBitmap :: BCOByteArray Word, -- ^ bitmap - resolvedBCOLits :: BCOByteArray Word, + resolvedBCOInstrs :: !(BCOByteArray Word16), -- ^ insns + resolvedBCOBitmap :: !(BCOByteArray Word), -- ^ bitmap + resolvedBCOLits :: !(BCOByteArray Word), -- ^ non-ptrs - subword sized entries still take up a full (host) word - resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ^ ptrs + resolvedBCOPtrs :: !(SmallArray ResolvedBCOPtr) -- ^ ptrs } deriving (Generic, Show) ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -76,7 +76,6 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair -GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -77,7 +77,6 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.OsPath GHC.Data.Pair -GHC.Data.SmallArray GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/161d3285215e85a9ebb24d798cea931... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/161d3285215e85a9ebb24d798cea931... You're receiving this email because of your account on gitlab.haskell.org.