Commit a496f82d authored by Simon Marlow's avatar Simon Marlow

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.
parent 85daac59
......@@ -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@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
......
......@@ -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]
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment