[commit: ghc] ghc-8.0: Remote GHCi: parallelise BCO serialization (e2715ce)

git at git.haskell.org git at git.haskell.org
Tue Feb 2 16:43:13 UTC 2016


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/e2715ce6f2662a856fc68aeca9005cf30d2ebf35/ghc

>---------------------------------------------------------------

commit e2715ce6f2662a856fc68aeca9005cf30d2ebf35
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Mon Feb 1 16:39:50 2016 +0000

    Remote GHCi: parallelise BCO serialization
    
    Summary:
    Serialization of BCOs is slow, but we can parallelise it when using
    ghci -j<n>.  It parallelises nicely, saving multiple seconds off the
    link time in a large example I have.
    
    Test Plan:
    * validate
    * `ghci -fexternal-interpreter` in `nofib/real/anna`
    
    Reviewers: niteria, bgamari, ezyang, austin, hvr, erikd
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1877
    
    GHC Trac Issues: #11100
    
    (cherry picked from commit c996db5b1802ebeb93420785127f7fd55b7ec0c0)


>---------------------------------------------------------------

e2715ce6f2662a856fc68aeca9005cf30d2ebf35
 compiler/ghci/GHCi.hs          | 39 ++++++++++++++++++++++++++++++++++++++-
 compiler/ghci/Linker.hs        |  4 ++--
 compiler/utils/Util.hs         |  8 ++++++++
 libraries/ghci/GHCi/Message.hs |  3 +--
 libraries/ghci/GHCi/Run.hs     |  4 +++-
 5 files changed, 52 insertions(+), 6 deletions(-)

diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index c54090c..9a33c68 100644
--- a/compiler/ghci/GHCi.hs
+++ b/compiler/ghci/GHCi.hs
@@ -13,6 +13,7 @@ module GHCi
   , evalString
   , evalStringToIOString
   , mallocData
+  , createBCOs
   , mkCostCentres
   , costCentreStackInfo
   , newBreakArray
@@ -47,6 +48,7 @@ module GHCi
 import GHCi.Message
 import GHCi.Run
 import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
 import GHCi.BreakArray (BreakArray)
 import HscTypes
 import UniqFM
@@ -57,14 +59,17 @@ import Outputable
 import Exception
 import BasicTypes
 import FastString
+import Util
 
 import Control.Concurrent
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Binary
+import Data.Binary.Put
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
 import Data.IORef
-import Foreign
+import Foreign hiding (void)
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Exit
 import Data.Maybe
@@ -75,6 +80,7 @@ import GHC.IO.Handle.FD (fdToHandle)
 import System.Posix as Posix
 #endif
 import System.Process
+import GHC.Conc
 
 {- Note [Remote GHCi]
 
@@ -257,6 +263,37 @@ mkCostCentres
 mkCostCentres hsc_env mod ccs =
   iservCmd hsc_env (MkCostCentres mod ccs)
 
+-- | Create a set of BCOs that may be mutually recursive.
+createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
+createBCOs hsc_env rbcos = do
+  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
+              Nothing -> liftIO getNumProcessors
+              Just n  -> return n
+  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
+  -- (-j<n>) parallelise the serialization.
+  if (n_jobs == 1)
+    then
+      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
+
+    else do
+      old_caps <- getNumCapabilities
+      if old_caps == n_jobs
+         then void $ evaluate puts
+         else bracket_ (setNumCapabilities n_jobs)
+                       (setNumCapabilities old_caps)
+                       (void $ evaluate puts)
+      iservCmd hsc_env (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
 
 costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
 costCentreStackInfo hsc_env ccs =
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 982b4fc..2b471ee 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -499,7 +499,7 @@ linkExpr hsc_env span root_ul_bco
    ; let nobreakarray = error "no break array"
          bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
    ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
-   ; [root_hvref] <- iservCmd hsc_env (CreateBCOs [resolved])
+   ; [root_hvref] <- createBCOs hsc_env [resolved]
    ; fhv <- mkFinalizedHValue hsc_env root_hvref
    ; return (pls, fhv)
    }}}
@@ -971,7 +971,7 @@ linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
         bco_ix = mkNameEnv (zip names [0..])
     resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
                          | (breakarray, bco) <- flat ]
-    hvrefs <- iservCmd hsc_env (CreateBCOs resolved)
+    hvrefs <- createBCOs hsc_env resolved
     return (zip names hvrefs)
 
 -- | Useful to apply to the result of 'linkSomeBCOs'
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 75c0c79..e565e40 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -35,6 +35,8 @@ module Util (
 
         isIn, isn'tIn,
 
+        chunkList,
+
         -- * Tuples
         fstOf3, sndOf3, thdOf3,
         firstM, first3M,
@@ -506,6 +508,12 @@ isn'tIn msg x ys
       | otherwise = x /= y && notElem100 (i + 1) x ys
 # endif /* DEBUG */
 
+
+-- | 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
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 50d4a16..b8f9fcc 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -14,7 +14,6 @@ module GHCi.Message
   ) where
 
 import GHCi.RemoteTypes
-import GHCi.ResolvedBCO
 import GHCi.InfoTable (StgInfoTable)
 import GHCi.FFI
 import GHCi.TH.Binary ()
@@ -66,7 +65,7 @@ data Message a where
   -- Interpreter -------------------------------------------
 
   -- | Create a set of BCO objects, and return HValueRefs to them
-  CreateBCOs :: [ResolvedBCO] -> Message [HValueRef]
+  CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
 
   -- | Release 'HValueRef's
   FreeHValueRefs :: [HValueRef] -> Message ()
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 3faced4..a2ea4e2 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -23,6 +23,8 @@ import Control.Concurrent
 import Control.DeepSeq
 import Control.Exception
 import Control.Monad
+import Data.Binary
+import Data.Binary.Get
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Unsafe as B
 import GHC.Exts
@@ -51,7 +53,7 @@ run m = case m of
   RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
   ResolveObjs -> resolveObjs
   FindSystemLibrary str -> findSystemLibrary str
-  CreateBCOs bco -> createBCOs bco
+  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)
   FreeHValueRefs rs -> mapM_ freeRemoteRef rs
   EvalStmt opts r -> evalStmt opts r
   ResumeStmt opts r -> resumeStmt opts r



More information about the ghc-commits mailing list