Remote GHCi: parallelise BCO serialization
authorSimon Marlow <marlowsd@gmail.com>
Mon, 1 Feb 2016 16:39:50 +0000 (16:39 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Tue, 2 Feb 2016 08:04:11 +0000 (08:04 +0000)
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

compiler/ghci/GHCi.hs
compiler/ghci/Linker.hs
compiler/utils/Util.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Run.hs

index 2e2cd35..80aeccf 100644 (file)
@@ -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
@@ -76,6 +81,7 @@ import GHC.IO.Handle.FD (fdToHandle)
 import System.Posix as Posix
 #endif
 import System.Process
+import GHC.Conc
 
 {- Note [Remote GHCi]
 
@@ -258,6 +264,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 =
index 982b4fc..2b471ee 100644 (file)
@@ -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'
index c0a335c..b8af6a7 100644 (file)
@@ -35,6 +35,8 @@ module Util (
 
         isIn, isn'tIn,
 
+        chunkList,
+
         -- * Tuples
         fstOf3, sndOf3, thdOf3,
         firstM, first3M,
@@ -503,6 +505,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
+
 {-
 ************************************************************************
 *                                                                      *
index 50d4a16..b8f9fcc 100644 (file)
@@ -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 ()
index 3faced4..a2ea4e2 100644 (file)
@@ -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