[commit: ghc] ghc-8.0: Remote GHCi: create cost centre stacks in batches (2c48f1c)
git at git.haskell.org
git at git.haskell.org
Tue Feb 2 16:43:02 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/2c48f1cfb554522ac1438149860e63929ae9553e/ghc
>---------------------------------------------------------------
commit 2c48f1cfb554522ac1438149860e63929ae9553e
Author: Simon Marlow <marlowsd at gmail.com>
Date: Thu Jan 21 09:46:13 2016 +0000
Remote GHCi: create cost centre stacks in batches
Towards optimising the binary serialisation that
-fexternal-interpreter does, this saves quite a bit of time when using
-fexternal-interpreter with -prof.
(cherry picked from commit a496f82d5684f3025a60877600e82f0b29736e85)
>---------------------------------------------------------------
2c48f1cfb554522ac1438149860e63929ae9553e
compiler/deSugar/Coverage.hs | 22 +++++++---------------
compiler/ghci/GHCi.hs | 11 +++++------
libraries/ghci/GHCi/Message.hs | 16 +++++++---------
libraries/ghci/GHCi/Run.hs | 19 +++++++++++--------
4 files changed, 30 insertions(+), 38 deletions(-)
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index edf0017..9fc1734 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -158,26 +158,18 @@ mkCCSArray
:: HscEnv -> Module -> Int -> [MixEntry_]
-> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
mkCCSArray hsc_env modul count entries = do
- if interpreterProfiled (hsc_dflags hsc_env)
+ if interpreterProfiled dflags
then do
- let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
- c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0)
- -- NB. null-terminate the string
- costcentres <-
- mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries
+ let module_str = moduleNameString (moduleName modul)
+ costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
return (listArray (0,count-1) costcentres)
else do
return (listArray (0,-1) [])
where
- mkCostCentre
- :: HscEnv
- -> RemotePtr CChar
- -> MixEntry_
- -> IO (RemotePtr GHC.Stack.CCS.CostCentre)
- mkCostCentre hsc_env at HscEnv{..} c_module (srcspan, decl_path, _, _) = do
- let name = concat (intersperse "." decl_path)
- src = showSDoc hsc_dflags (ppr srcspan)
- GHCi.mkCostCentre hsc_env c_module name src
+ dflags = hsc_dflags hsc_env
+ mk_one (srcspan, decl_path, _, _) = (name, src)
+ where name = concat (intersperse "." decl_path)
+ src = showSDoc dflags (ppr srcspan)
#endif
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index 08285a8..c54090c 100644
--- a/compiler/ghci/GHCi.hs
+++ b/compiler/ghci/GHCi.hs
@@ -13,7 +13,7 @@ module GHCi
, evalString
, evalStringToIOString
, mallocData
- , mkCostCentre
+ , mkCostCentres
, costCentreStackInfo
, newBreakArray
, enableBreakpoint
@@ -65,7 +65,6 @@ import Data.Binary
import Data.ByteString (ByteString)
import Data.IORef
import Foreign
-import Foreign.C
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
import Data.Maybe
@@ -253,10 +252,10 @@ evalStringToIOString hsc_env fhv str = do
mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
-mkCostCentre
- :: HscEnv -> RemotePtr CChar -> String -> String -> IO (RemotePtr CostCentre)
-mkCostCentre hsc_env c_module name src =
- iservCmd hsc_env (MkCostCentre c_module name src)
+mkCostCentres
+ :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres hsc_env mod ccs =
+ iservCmd hsc_env (MkCostCentres mod ccs)
costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index a22767a..bdb1a9f 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -32,7 +32,6 @@ import qualified Data.ByteString.Lazy as LB
import Data.Dynamic
import Data.IORef
import Data.Map (Map)
-import Foreign.C
import GHC.Generics
import GHC.Stack.CCS
import qualified Language.Haskell.TH as TH
@@ -122,12 +121,11 @@ data Message a where
:: HValueRef {- IO a -}
-> Message (EvalResult ())
- -- | Create a CostCentre
- MkCostCentre
- :: RemotePtr CChar -- module, RemotePtr so it can be shared
- -> String -- name
- -> String -- SrcSpan
- -> Message (RemotePtr CostCentre)
+ -- | Create a set of CostCentres with the same module name
+ MkCostCentres
+ :: String -- module, RemotePtr so it can be shared
+ -> [(String,String)] -- (name, SrcSpan)
+ -> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
CostCentreStackInfo
@@ -334,7 +332,7 @@ getMessage = do
21 -> Msg <$> (EvalString <$> get)
22 -> Msg <$> (EvalStringToString <$> get <*> get)
23 -> Msg <$> (EvalIO <$> get)
- 24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get)
+ 24 -> Msg <$> (MkCostCentres <$> get <*> get)
25 -> Msg <$> (CostCentreStackInfo <$> get)
26 -> Msg <$> (NewBreakArray <$> get)
27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
@@ -389,7 +387,7 @@ putMessage m = case m of
EvalString val -> putWord8 21 >> put val
EvalStringToString str val -> putWord8 22 >> put str >> put val
EvalIO val -> putWord8 23 >> put val
- MkCostCentre mod name src -> putWord8 24 >> put mod >> put name >> put src
+ MkCostCentres mod ccs -> putWord8 24 >> put mod >> put ccs
CostCentreStackInfo ptr -> putWord8 25 >> put ptr
NewBreakArray sz -> putWord8 26 >> put sz
EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 5951d9b..780ff3e 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -59,8 +59,7 @@ run m = case m of
EvalString r -> evalString r
EvalStringToString r s -> evalStringToString r s
EvalIO r -> evalIO r
- MkCostCentre mod name src ->
- toRemotePtr <$> mkCostCentre (fromRemotePtr mod) name src
+ MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
EnableBreakpoint ref ix b -> do
@@ -324,17 +323,21 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
copyBytes ptr cstr len
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CostCentre)
+mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
-mkCostCentre c_module decl_path srcspan = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
- c_mkCostCentre c_name c_module c_srcspan
+mkCostCentres mod ccs = do
+ c_module <- newCString mod
+ mapM (mk_one c_module) ccs
+ where
+ mk_one c_module (decl_path,srcspan) = do
+ c_name <- newCString decl_path
+ c_srcspan <- newCString srcspan
+ toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
-mkCostCentre _ _ _ = return nullPtr
+mkCostCentres _ _ = return []
#endif
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
More information about the ghc-commits
mailing list