[Git][ghc/ghc][wip/T23919] Avoid serializing BCOs with the internal interpreter

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Fri Sep 8 18:17:48 UTC 2023



Krzysztof Gogolewski pushed to branch wip/T23919 at Glasgow Haskell Compiler / GHC


Commits:
53e19e3c by Krzysztof Gogolewski at 2023-09-08T20:17:37+02:00
Avoid serializing BCOs with the internal interpreter

Refs #23919

- - - - -


5 changed files:

- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Utils/Misc.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/GHCi/TH.hs


Changes:

=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -93,7 +93,6 @@ import GHC.Utils.Panic
 import GHC.Utils.Exception as Ex
 import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
 import GHC.Utils.Fingerprint
-import GHC.Utils.Misc
 
 import GHC.Unit.Module
 import GHC.Unit.Module.ModIface
@@ -110,9 +109,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Catch as MC (mask)
 import Data.Binary
-import Data.Binary.Put
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Lazy as LB
 import Data.Array ((!))
 import Data.IORef
 import Foreign hiding (void)
@@ -120,7 +117,6 @@ import qualified GHC.Exts.Heap as Heap
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Directory
 import System.Process
-import GHC.Conc (pseq, par)
 
 {- Note [Remote GHCi]
    ~~~~~~~~~~~~~~~~~~
@@ -353,19 +349,7 @@ mkCostCentres interp mod ccs =
 -- | Create a set of BCOs that may be mutually recursive.
 createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
 createBCOs interp rbcos = do
-  -- Serializing ResolvedBCO is expensive, so we do it in parallel
-  interpCmd interp (CreateBCOs puts)
- where
-  puts = parMap doChunk (chunkList 100 rbcos)
-
-  -- 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
+  interpCmd interp (CreateBCOs rbcos)
 
 addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()
 addSptEntry interp fpr ref =


=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -37,8 +37,6 @@ module GHC.Utils.Misc (
         isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,
         notNull, expectNonEmpty, snocView,
 
-        chunkList,
-
         holes,
 
         changeLast,
@@ -494,11 +492,6 @@ expectOnly _   (a:_) = a
 #endif
 expectOnly msg _     = panic ("expectOnly: " ++ msg)
 
--- | Split a list into chunks of /n/ elements
-chunkList :: Int -> [a] -> [[a]]
-chunkList _ [] = []
-chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs
-
 -- | Compute all the ways of removing a single element from a list.
 --
 --  > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])]


=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -30,11 +30,13 @@ import GHCi.RemoteTypes
 import GHCi.FFI
 import GHCi.TH.Binary () -- For Binary instances
 import GHCi.BreakArray
+import GHCi.ResolvedBCO
 
 import GHC.LanguageExtensions
 import qualified GHC.Exts.Heap as Heap
 import GHC.ForeignSrcLang
 import GHC.Fingerprint
+import GHC.Conc (pseq, par)
 import Control.Concurrent
 import Control.Exception
 import Data.Binary
@@ -84,10 +86,10 @@ data Message a where
   -- Interpreter -------------------------------------------
 
   -- | Create a set of BCO objects, and return HValueRefs to them
-  -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not
-  -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs
-  -- in parallel. See @createBCOs@ in compiler/GHC/Runtime/Interpreter.hs.
-  CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
+  -- See @createBCOs@ in compiler/GHC/Runtime/Interpreter.hs.
+  -- NB: this has a custom Binary behavior,
+  -- see Note [Parallelize CreateBCOs serialization]
+  CreateBCOs :: [ResolvedBCO] -> Message [HValueRef]
 
   -- | Release 'HValueRef's
   FreeHValueRefs :: [HValueRef] -> Message ()
@@ -513,7 +515,8 @@ getMessage = do
       9  -> Msg <$> RemoveLibrarySearchPath <$> get
       10 -> Msg <$> return ResolveObjs
       11 -> Msg <$> FindSystemLibrary <$> get
-      12 -> Msg <$> CreateBCOs <$> get
+      12 -> Msg <$> (CreateBCOs . concatMap (runGet get)) <$> (get :: Get [LB.ByteString])
+                    -- See Note [Parallelize CreateBCOs serialization]
       13 -> Msg <$> FreeHValueRefs <$> get
       14 -> Msg <$> MallocData <$> get
       15 -> Msg <$> MallocStrings <$> get
@@ -557,7 +560,8 @@ putMessage m = case m of
   RemoveLibrarySearchPath ptr -> putWord8 9  >> put ptr
   ResolveObjs                 -> putWord8 10
   FindSystemLibrary str       -> putWord8 11 >> put str
-  CreateBCOs bco              -> putWord8 12 >> put bco
+  CreateBCOs bco              -> putWord8 12 >> put (serializeBCOs bco)
+                              -- See Note [Parallelize CreateBCOs serialization]
   FreeHValueRefs val          -> putWord8 13 >> put val
   MallocData bs               -> putWord8 14 >> put bs
   MallocStrings bss           -> putWord8 15 >> put bss
@@ -586,6 +590,34 @@ putMessage m = case m of
   ResumeSeq a                 -> putWord8 38 >> put a
   NewBreakModule name          -> putWord8 39 >> put name
 
+{-
+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).
+
+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
+
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
 


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -17,8 +17,6 @@ import Prelude -- See note [Why do we import Prelude here?]
 #if !defined(javascript_HOST_ARCH)
 import GHCi.CreateBCO
 import GHCi.InfoTable
-import Data.Binary
-import Data.Binary.Get
 #endif
 
 import GHCi.FFI
@@ -78,7 +76,7 @@ run m = case m of
     toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
   ResolveObjs -> resolveObjs
   FindSystemLibrary str -> findSystemLibrary str
-  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)
+  CreateBCOs bcos -> createBCOs bcos
   LookupClosure str -> lookupClosure str
 #endif
   RtsRevertCAFs -> rts_revertCAFs


=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -38,7 +38,7 @@ For each splice
 1. GHC compiles a splice to byte code, and sends it to the server: in
    a CreateBCOs message:
 
-   CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
+   CreateBCOs :: [ResolvedBCOs] -> Message [HValueRef]
 
 2. The server creates the real byte-code objects in its heap, and
    returns HValueRefs to GHC.  HValueRef is the same as RemoteRef



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53e19e3c3a2641bbe1896a2a3fcc3e62784ad8a8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53e19e3c3a2641bbe1896a2a3fcc3e62784ad8a8
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/20230908/4454e510/attachment-0001.html>


More information about the ghc-commits mailing list