[commit: ghc] master: Remote GHCi: parallelise BCO serialization (c996db5)
git at git.haskell.org
git at git.haskell.org
Tue Feb 2 08:21:35 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/c996db5b1802ebeb93420785127f7fd55b7ec0c0/ghc
>---------------------------------------------------------------
commit c996db5b1802ebeb93420785127f7fd55b7ec0c0
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
>---------------------------------------------------------------
c996db5b1802ebeb93420785127f7fd55b7ec0c0
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 2e2cd35..80aeccf 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
@@ -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 =
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 c0a335c..b8af6a7 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,
@@ -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
+
{-
************************************************************************
* *
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