Commit a496f82d authored by Simon Marlow's avatar Simon Marlow
Browse files

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 ...@@ -158,26 +158,18 @@ mkCCSArray
:: HscEnv -> Module -> Int -> [MixEntry_] :: HscEnv -> Module -> Int -> [MixEntry_]
-> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
mkCCSArray hsc_env modul count entries = do mkCCSArray hsc_env modul count entries = do
if interpreterProfiled (hsc_dflags hsc_env) if interpreterProfiled dflags
then do then do
let module_bs = fastStringToByteString (moduleNameFS (moduleName modul)) let module_str = moduleNameString (moduleName modul)
c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0) costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
-- NB. null-terminate the string
costcentres <-
mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries
return (listArray (0,count-1) costcentres) return (listArray (0,count-1) costcentres)
else do else do
return (listArray (0,-1) []) return (listArray (0,-1) [])
where where
mkCostCentre dflags = hsc_dflags hsc_env
:: HscEnv mk_one (srcspan, decl_path, _, _) = (name, src)
-> RemotePtr CChar where name = concat (intersperse "." decl_path)
-> MixEntry_ src = showSDoc dflags (ppr srcspan)
-> 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
#endif #endif
......
...@@ -13,7 +13,7 @@ module GHCi ...@@ -13,7 +13,7 @@ module GHCi
, evalString , evalString
, evalStringToIOString , evalStringToIOString
, mallocData , mallocData
, mkCostCentre , mkCostCentres
, costCentreStackInfo , costCentreStackInfo
, newBreakArray , newBreakArray
, enableBreakpoint , enableBreakpoint
...@@ -65,7 +65,6 @@ import Data.Binary ...@@ -65,7 +65,6 @@ import Data.Binary
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.IORef import Data.IORef
import Foreign import Foreign
import Foreign.C
import GHC.Stack.CCS (CostCentre,CostCentreStack) import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit import System.Exit
import Data.Maybe import Data.Maybe
...@@ -253,10 +252,10 @@ evalStringToIOString hsc_env fhv str = do ...@@ -253,10 +252,10 @@ evalStringToIOString hsc_env fhv str = do
mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
mkCostCentre mkCostCentres
:: HscEnv -> RemotePtr CChar -> String -> String -> IO (RemotePtr CostCentre) :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
mkCostCentre hsc_env c_module name src = mkCostCentres hsc_env mod ccs =
iservCmd hsc_env (MkCostCentre c_module name src) iservCmd hsc_env (MkCostCentres mod ccs)
costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
......
...@@ -32,7 +32,6 @@ import qualified Data.ByteString.Lazy as LB ...@@ -32,7 +32,6 @@ import qualified Data.ByteString.Lazy as LB
import Data.Dynamic import Data.Dynamic
import Data.IORef import Data.IORef
import Data.Map (Map) import Data.Map (Map)
import Foreign.C
import GHC.Generics import GHC.Generics
import GHC.Stack.CCS import GHC.Stack.CCS
import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH as TH
...@@ -122,12 +121,11 @@ data Message a where ...@@ -122,12 +121,11 @@ data Message a where
:: HValueRef {- IO a -} :: HValueRef {- IO a -}
-> Message (EvalResult ()) -> Message (EvalResult ())
-- | Create a CostCentre -- | Create a set of CostCentres with the same module name
MkCostCentre MkCostCentres
:: RemotePtr CChar -- module, RemotePtr so it can be shared :: String -- module, RemotePtr so it can be shared
-> String -- name -> [(String,String)] -- (name, SrcSpan)
-> String -- SrcSpan -> Message [RemotePtr CostCentre]
-> Message (RemotePtr CostCentre)
-- | Show a 'CostCentreStack' as a @[String]@ -- | Show a 'CostCentreStack' as a @[String]@
CostCentreStackInfo CostCentreStackInfo
...@@ -334,7 +332,7 @@ getMessage = do ...@@ -334,7 +332,7 @@ getMessage = do
21 -> Msg <$> (EvalString <$> get) 21 -> Msg <$> (EvalString <$> get)
22 -> Msg <$> (EvalStringToString <$> get <*> get) 22 -> Msg <$> (EvalStringToString <$> get <*> get)
23 -> Msg <$> (EvalIO <$> get) 23 -> Msg <$> (EvalIO <$> get)
24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get) 24 -> Msg <$> (MkCostCentres <$> get <*> get)
25 -> Msg <$> (CostCentreStackInfo <$> get) 25 -> Msg <$> (CostCentreStackInfo <$> get)
26 -> Msg <$> (NewBreakArray <$> get) 26 -> Msg <$> (NewBreakArray <$> get)
27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get) 27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
...@@ -389,7 +387,7 @@ putMessage m = case m of ...@@ -389,7 +387,7 @@ putMessage m = case m of
EvalString val -> putWord8 21 >> put val EvalString val -> putWord8 21 >> put val
EvalStringToString str val -> putWord8 22 >> put str >> put val EvalStringToString str val -> putWord8 22 >> put str >> put val
EvalIO val -> putWord8 23 >> 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 CostCentreStackInfo ptr -> putWord8 25 >> put ptr
NewBreakArray sz -> putWord8 26 >> put sz NewBreakArray sz -> putWord8 26 >> put sz
EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b
......
...@@ -59,8 +59,7 @@ run m = case m of ...@@ -59,8 +59,7 @@ run m = case m of
EvalString r -> evalString r EvalString r -> evalString r
EvalStringToString r s -> evalStringToString r s EvalStringToString r s -> evalStringToString r s
EvalIO r -> evalIO r EvalIO r -> evalIO r
MkCostCentre mod name src -> MkCostCentres mod ccs -> mkCostCentres mod ccs
toRemotePtr <$> mkCostCentre (fromRemotePtr mod) name src
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
EnableBreakpoint ref ix b -> do EnableBreakpoint ref ix b -> do
...@@ -324,17 +323,21 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do ...@@ -324,17 +323,21 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
copyBytes ptr cstr len copyBytes ptr cstr len
return (castRemotePtr (toRemotePtr ptr)) return (castRemotePtr (toRemotePtr ptr))
mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CostCentre) mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING) #if defined(PROFILING)
mkCostCentre c_module decl_path srcspan = do 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_name <- newCString decl_path
c_srcspan <- newCString srcspan c_srcspan <- newCString srcspan
c_mkCostCentre c_name c_module c_srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
foreign import ccall unsafe "mkCostCentre" foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else #else
mkCostCentre _ _ _ = return nullPtr mkCostCentres _ _ = return []
#endif #endif
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) 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