summaryrefslogtreecommitdiff
path: root/libraries
diff options
context:
space:
mode:
Diffstat (limited to 'libraries')
-rw-r--r--libraries/base/GHC/Stack.hs1
-rw-r--r--libraries/base/GHC/Stack/CCS.hsc4
-rw-r--r--libraries/ghci/GHCi/Message.hs91
-rw-r--r--libraries/ghci/GHCi/Run.hs26
4 files changed, 82 insertions, 40 deletions
diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index 8f57239a84..d7c5c94193 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -33,6 +33,7 @@ module GHC.Stack (
CostCentre,
getCurrentCCS,
getCCSOf,
+ clearCCS,
ccsCC,
ccsParent,
ccLabel,
diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc
index b62c80a473..d40d92dc91 100644
--- a/libraries/base/GHC/Stack/CCS.hsc
+++ b/libraries/base/GHC/Stack/CCS.hsc
@@ -26,6 +26,7 @@ module GHC.Stack.CCS (
CostCentre,
getCurrentCCS,
getCCSOf,
+ clearCCS,
ccsCC,
ccsParent,
ccLabel,
@@ -60,6 +61,9 @@ getCCSOf obj = IO $ \s ->
case getCCSOf## obj s of
(## s', addr ##) -> (## s', Ptr addr ##)
+clearCCS :: IO a -> IO a
+clearCCS (IO m) = IO $ \s -> clearCCS## m s
+
ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC p = (# peek CostCentreStack, cc) p
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 0d28c68db1..5406854f31 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -114,6 +114,18 @@ data Message a where
:: HValueRef {- IO a -}
-> Message (EvalResult ())
+ -- | Create a CostCentre
+ MkCostCentre
+ :: RemotePtr -- module, RemotePtr so it can be shared
+ -> String -- name
+ -> String -- SrcSpan
+ -> Message RemotePtr
+
+ -- | Show a 'CostCentreStack' as a @[String]@
+ CostCentreStackInfo
+ :: RemotePtr {- from EvalBreak -}
+ -> Message [String]
+
-- Template Haskell -------------------------------------------
-- | Start a new TH module, return a state token that should be
@@ -191,6 +203,7 @@ data EvalStatus a
HValueRef{- AP_STACK -}
HValueRef{- BreakInfo -}
HValueRef{- ResumeContext -}
+ RemotePtr -- Cost centre stack
deriving (Generic, Show)
instance Binary a => Binary (EvalStatus a)
@@ -264,24 +277,26 @@ getMessage = do
21 -> Msg <$> (EvalString <$> get)
22 -> Msg <$> (EvalStringToString <$> get <*> get)
23 -> Msg <$> (EvalIO <$> get)
- 24 -> Msg <$> return StartTH
- 25 -> Msg <$> FinishTH <$> get
- 26 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
- 27 -> Msg <$> NewName <$> get
- 28 -> Msg <$> (Report <$> get <*> get)
- 29 -> Msg <$> (LookupName <$> get <*> get)
- 30 -> Msg <$> Reify <$> get
- 31 -> Msg <$> ReifyFixity <$> get
- 32 -> Msg <$> (ReifyInstances <$> get <*> get)
- 33 -> Msg <$> ReifyRoles <$> get
- 34 -> Msg <$> (ReifyAnnotations <$> get <*> get)
- 35 -> Msg <$> ReifyModule <$> get
- 36 -> Msg <$> AddDependentFile <$> get
- 37 -> Msg <$> AddTopDecls <$> get
- 38 -> Msg <$> (IsExtEnabled <$> get)
- 39 -> Msg <$> return ExtsEnabled
- 40 -> Msg <$> return QDone
- 41 -> Msg <$> QException <$> get
+ 24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get)
+ 25 -> Msg <$> (CostCentreStackInfo <$> get)
+ 26 -> Msg <$> return StartTH
+ 27 -> Msg <$> FinishTH <$> get
+ 28 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+ 29 -> Msg <$> NewName <$> get
+ 30 -> Msg <$> (Report <$> get <*> get)
+ 31 -> Msg <$> (LookupName <$> get <*> get)
+ 32 -> Msg <$> Reify <$> get
+ 33 -> Msg <$> ReifyFixity <$> get
+ 34 -> Msg <$> (ReifyInstances <$> get <*> get)
+ 35 -> Msg <$> ReifyRoles <$> get
+ 36 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+ 37 -> Msg <$> ReifyModule <$> get
+ 38 -> Msg <$> AddDependentFile <$> get
+ 39 -> Msg <$> AddTopDecls <$> get
+ 40 -> Msg <$> (IsExtEnabled <$> get)
+ 41 -> Msg <$> return ExtsEnabled
+ 42 -> Msg <$> return QDone
+ 43 -> Msg <$> QException <$> get
_ -> Msg <$> QFail <$> get
putMessage :: Message a -> Put
@@ -310,25 +325,27 @@ 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
- StartTH -> putWord8 24
- FinishTH val -> putWord8 25 >> put val
- RunTH st q loc ty -> putWord8 26 >> put st >> put q >> put loc >> put ty
- NewName a -> putWord8 27 >> put a
- Report a b -> putWord8 28 >> put a >> put b
- LookupName a b -> putWord8 29 >> put a >> put b
- Reify a -> putWord8 30 >> put a
- ReifyFixity a -> putWord8 31 >> put a
- ReifyInstances a b -> putWord8 32 >> put a >> put b
- ReifyRoles a -> putWord8 33 >> put a
- ReifyAnnotations a b -> putWord8 34 >> put a >> put b
- ReifyModule a -> putWord8 35 >> put a
- AddDependentFile a -> putWord8 36 >> put a
- AddTopDecls a -> putWord8 37 >> put a
- IsExtEnabled a -> putWord8 38 >> put a
- ExtsEnabled -> putWord8 39
- QDone -> putWord8 40
- QException a -> putWord8 41 >> put a
- QFail a -> putWord8 42 >> put a
+ MkCostCentre name mod src -> putWord8 24 >> put name >> put mod >> put src
+ CostCentreStackInfo ptr -> putWord8 25 >> put ptr
+ StartTH -> putWord8 26
+ FinishTH val -> putWord8 27 >> put val
+ RunTH st q loc ty -> putWord8 28 >> put st >> put q >> put loc >> put ty
+ NewName a -> putWord8 29 >> put a
+ Report a b -> putWord8 30 >> put a >> put b
+ LookupName a b -> putWord8 31 >> put a >> put b
+ Reify a -> putWord8 32 >> put a
+ ReifyFixity a -> putWord8 33 >> put a
+ ReifyInstances a b -> putWord8 34 >> put a >> put b
+ ReifyRoles a -> putWord8 35 >> put a
+ ReifyAnnotations a b -> putWord8 36 >> put a >> put b
+ ReifyModule a -> putWord8 37 >> put a
+ AddDependentFile a -> putWord8 38 >> put a
+ AddTopDecls a -> putWord8 39 >> put a
+ IsExtEnabled a -> putWord8 40 >> put a
+ ExtsEnabled -> putWord8 41
+ QDone -> putWord8 42
+ QException a -> putWord8 43 >> put a
+ QFail a -> putWord8 44 >> put a
-- -----------------------------------------------------------------------------
-- Reading/writing messages
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index fc142a2043..8934437a10 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables #-}
+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -24,6 +24,7 @@ import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
+import GHC.Stack
import Foreign
import Foreign.C
import GHC.Conc.Sync
@@ -56,6 +57,9 @@ run m = case m of
EvalString r -> evalString r
EvalStringToString r s -> evalStringToString r s
EvalIO r -> evalIO r
+ MkCostCentre name mod src ->
+ toRemotePtr <$> mkCostCentre (fromRemotePtr name) mod src
+ CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
MallocData bs -> mkString bs
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
@@ -112,7 +116,7 @@ sandboxIO opts io = do
breakMVar <- newEmptyMVar
statusMVar <- newEmptyMVar
withBreakAction opts breakMVar statusMVar $ do
- let runIt = measureAlloc $ tryEval $ rethrow opts io
+ let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
if useSandboxThread opts
then do
tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
@@ -237,7 +241,8 @@ withBreakAction opts breakMVar statusMVar act
resume_r <- mkHValueRef (unsafeCoerce resume)
apStack_r <- mkHValueRef apStack
info_r <- mkHValueRef info
- putMVar statusMVar (EvalBreak is_exception apStack_r info_r resume_r)
+ ccs <- toRemotePtr <$> getCCSOf apStack
+ putMVar statusMVar $ EvalBreak is_exception apStack_r info_r resume_r ccs
takeMVar breakMVar
resetBreakAction stablePtr = do
@@ -305,3 +310,18 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
ptr <- mallocBytes len
copyBytes ptr cstr len
return (toRemotePtr ptr)
+
+data CCostCentre
+
+mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CCostCentre)
+#if defined(PROFILING)
+mkCostCentre c_module srcspan decl_path = do
+ c_name <- newCString decl_path
+ c_srcspan <- newCString srcspan
+ c_mkCostCentre c_name c_module c_srcspan
+
+foreign import ccall unsafe "mkCostCentre"
+ c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CCostCentre)
+#else
+mkCostCentre _ _ _ = return nullPtr
+#endif
View Lorry Controller Status