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.

2 files changed, 18 insertions, 17 deletions

diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index a22767a3f7..bdb1a9f653 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 5951d9bf20..780ff3e6da 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)