[Git][ghc/ghc][master] Prefer packed representation for CompiledByteCode

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
868c8a78 by Fendor at 2024-04-09T08:51:50-04:00
Prefer packed representation for CompiledByteCode

As there are many 'CompiledByteCode' objects alive during a GHCi
session, representing its element in a more packed manner improves space
behaviour at a minimal cost.

When running GHCi on the agda codebase, we find around 380 live
'CompiledByteCode' objects. Packing their respective 'UnlinkedByteCode'
can save quite some pointers.

- - - - -


5 changed files:

- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/StgToByteCode.hs


Changes:

=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -34,6 +34,7 @@ import GHC.Utils.Panic
 
 import GHC.Core.TyCon
 import GHC.Data.FastString
+import GHC.Data.FlatBag
 import GHC.Data.SizedSeq
 
 import GHC.StgToCmm.Layout     ( ArgRep(..) )
@@ -90,7 +91,7 @@ bcoFreeNames bco
 assembleBCOs
   :: Interp
   -> Profile
-  -> [ProtoBCO Name]
+  -> FlatBag (ProtoBCO Name)
   -> [TyCon]
   -> AddrEnv
   -> Maybe ModBreaks
@@ -129,7 +130,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
 -- top-level string literal bindings] in GHC.StgToByteCode for some discussion
 -- about why.
 --
-mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
+mallocStrings ::  Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
 mallocStrings interp ulbcos = do
   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
   ptrs <- interpCmd interp (MallocStrings bytestrings)
@@ -170,7 +171,7 @@ assembleOneBCO interp profile pbco = do
   -- TODO: the profile should be bundled with the interpreter: the rts ways are
   -- fixed for an interpreter
   ubco <- assembleBCO (profilePlatform profile) pbco
-  [ubco'] <- mallocStrings interp [ubco]
+  UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)
   return ubco'
 
 assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO


=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -54,7 +54,7 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
 -- Compiled Byte Code
 
 data CompiledByteCode = CompiledByteCode
-  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
+  { bc_bcos   :: FlatBag UnlinkedBCO -- Bunch of interpretable bindings
   , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
   , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
   , bc_strs   :: AddrEnv        -- malloc'd top-level strings
@@ -66,7 +66,7 @@ newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
   deriving (Show, NFData)
 
 instance Outputable CompiledByteCode where
-  ppr CompiledByteCode{..} = ppr bc_bcos
+  ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos
 
 -- Not a real NFData instance, because ModBreaks contains some things
 -- we can't rnf


=====================================
compiler/GHC/Data/FlatBag.hs
=====================================
@@ -1,6 +1,6 @@
 {-# LANGUAGE UnboxedTuples #-}
 module GHC.Data.FlatBag
-  ( FlatBag
+  ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)
   , emptyFlatBag
   , unitFlatBag
   , sizeFlatBag


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -92,6 +92,7 @@ import Control.Monad
 
 import qualified Data.Set as Set
 import Data.Char (isSpace)
+import qualified Data.Foldable as Foldable
 import Data.IORef
 import Data.List (intercalate, isPrefixOf, nub, partition)
 import Data.Maybe
@@ -923,7 +924,8 @@ linkSomeBCOs :: Interp
 
 linkSomeBCOs interp le mods = foldr fun do_link mods []
  where
-  fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
+  fun CompiledByteCode{..} inner accum =
+    inner (Foldable.toList bc_bcos : accum)
 
   do_link [] = return []
   do_link mods = do


=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
 import GHC.StgToCmm.Layout
 import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
 import GHC.Data.Bitmap
+import GHC.Data.FlatBag as FlatBag
 import GHC.Data.OrdList
 import GHC.Data.Maybe
 import GHC.Types.Name.Env (mkNameEnv)
@@ -119,14 +120,14 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
         (BcM_State{..}, proto_bcos) <-
            runBc hsc_env this_mod mb_modBreaks $ do
              let flattened_binds = concatMap flattenBind (reverse lifted_binds)
-             mapM schemeTopBind flattened_binds
+             FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
 
         when (notNull ffis)
              (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
 
         putDumpFileMaybe logger Opt_D_dump_BCOs
            "Proto-BCOs" FormatByteCode
-           (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+           (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
 
         cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
           (case modBreaks of



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/868c8a78432459dc2821f1ce70c9a97f7fb31394

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/868c8a78432459dc2821f1ce70c9a97f7fb31394
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240409/834622f7/attachment-0001.html>