GitLab

Cheng Shao pushed to branch wip/ghci-spark at Glasgow Haskell Compiler / GHC

Commits:

3142ed32

by Cheng Shao at 2025-12-28T06:41:07+01:00

ghci: avoid arbitrary chunking in parallelized CreateBCOs serialization

Previously, when the `CreateBCOs` message is serialized, we split the
`[ResolvedBCO]` list into chunks and use sparks to serialize the
chunks in parallel. However, in terms of load balancing, instead of
arbitrarily grouping work, it's better to spawn work on a finer
granularity and rely on the work-stealing nature of the sparks
mechanism to distribute work more evenly across idle Capabilities.

So this patch refactors the `CreateBCOs` serialization logic to spawn
one spark per `ResolvedBCO` object. This is based on an added helper
module `GHC.Utils.Spark` in `ghc-boot`, which might come in handy
later when we want to use sparks in other parts of the compiler.

3 changed files:

+ libraries/ghc-boot/GHC/Utils/Spark.hs
libraries/ghc-boot/ghc-boot.cabal.in
libraries/ghci/GHCi/Message.hs

Changes:

libraries/ghc-boot/GHC/Utils/Spark.hs

 +{-# LANGUAGE MagicHash #-}
++
 +module GHC.Utils.Spark
 +  ( sparkST,
 +    sparkIO,
 +  )
 +where
++
 +import Control.Monad
 +import GHC.Exts
 +import GHC.IO
 +import GHC.ST
 +import Prelude
++
 +-- | Same as 'sparkIO' but in the 'ST' monad, useful if no other side
 +-- effects are involved.
 +sparkST :: ST s a -> ST s a
 +sparkST = ST . spark# <=< unsafeInterleaveST
++
 +-- | Spawns an 'IO' computation as a spark and returns a thunk that
 +-- evaluates to the computation's result. The computation is guarded
 +-- by 'noDuplicate' to prevent being executed by multiple threads at
 +-- once.
 +sparkIO :: IO a -> IO a
 +sparkIO = IO . spark# <=< unsafeInterleaveIO

libraries/ghc-boot/ghc-boot.cabal.in

@@ -55,6 +55,7 @@ Library
              GHC.Data.SizedSeq
              GHC.Utils.Encoding
              GHC.Utils.Encoding.UTF8
 +            GHC.Utils.Spark
              GHC.LanguageExtensions
              GHC.Unit.Database
              GHC.Serialized

libraries/ghci/GHCi/Message.hs

@@ -44,13 +44,13 @@ import qualified GHC.Exts.Heap as Heap
  #endif
  import GHC.ForeignSrcLang
  import GHC.Fingerprint
 -import GHC.Conc (pseq, par)
  import Control.Concurrent
  import Control.DeepSeq
  import Control.Exception
  #if MIN_VERSION_base(4,20,0)
  import Control.Exception.Context
  #endif
 +import Control.Monad.ST
  import Data.Binary
  import Data.Binary.Get
  import Data.Binary.Put
@@ -66,6 +66,7 @@ import Data.Map (Map)
  import Foreign
  import GHC.Generics
  import GHC.Stack.CCS
 +import GHC.Utils.Spark
  import qualified GHC.Boot.TH.Syntax        as TH
  import qualified GHC.Boot.TH.Monad         as TH
  import System.Exit
@@ -572,7 +573,7 @@ getMessage = do
 -> Msg <$> RemoveLibrarySearchPath <$> get
 -> Msg <$> return ResolveObjs
 -> Msg <$> FindSystemLibrary <$> get
 -      12 -> Msg <$> (CreateBCOs . concatMap (runGet get)) <$> (get :: Get [LB.ByteString])
 +      12 -> Msg <$> (CreateBCOs . fmap (runGet get)) <$> (get :: Get [LB.ByteString])
                      -- See Note [Parallelize CreateBCOs serialization]
 -> Msg <$> FreeHValueRefs <$> get
 -> Msg <$> MallocData <$> get
@@ -653,29 +654,17 @@ putMessage m = case m of
  Note [Parallelize CreateBCOs serialization]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Serializing ResolvedBCO is expensive, so we do it in parallel.
 -We split the list [ResolvedBCO] into chunks of length <= 100,
 -and serialize every chunk in parallel, getting a [LB.ByteString]
 -where every bytestring corresponds to a single chunk (multiple ResolvedBCOs).
 +For each element in the list [ResolvedBCO], we spawn a spark which
 +serializes it, getting a [LB.ByteString] where every fully evaluated
 +lazy ByteString corresponds to a single ResolvedBCO.
  Previously, we stored [LB.ByteString] in the Message object, but that
  incurs unneccessary serialization with the internal interpreter (#23919).
  -}
  serializeBCOs :: [ResolvedBCO] -> [LB.ByteString]
 -serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos)
 - where
 -  -- make sure we force the whole lazy ByteString
 -  doChunk c = pseq (LB.length bs) bs
 -    where bs = runPut (put c)
+-
 -  -- We don't have the parallel package, so roll our own simple parMap
 -  parMap _ [] = []
 -  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
 -    where fx = f x; fxs = parMap f xs
+-
 -  chunkList :: Int -> [a] -> [[a]]
 -  chunkList _ [] = []
 -  chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs
 +serializeBCOs rbcos =
 +  runST $ traverse (sparkST . pure . force . runPut . put) rbcos
  -- -----------------------------------------------------------------------------
  -- Reading/writing messages