[commit: ghc] master: Remote GHCi: create cost centre stacks in batches (a496f82)

git at git.haskell.org git at git.haskell.org
Wed Jan 27 15:19:55 UTC 2016


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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a496f82d5684f3025a60877600e82f0b29736e85/ghc

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

commit a496f82d5684f3025a60877600e82f0b29736e85
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.


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

a496f82d5684f3025a60877600e82f0b29736e85
 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 9b7c873..56eb96d 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