{-# OPTIONS_GHC -optc-DPROFILING #-}{-# LINE 1 "libraries/base/GHC/Stack/CCS.hsc" #-}{-# LANGUAGE Trustworthy #-}------------------------------------------------------------------------------- |-- Module : GHC.Stack.CCS-- Copyright : (c) The University of Glasgow 2011-- License : see libraries/base/LICENSE---- Maintainer : cvs-ghc@haskell.org-- Stability : internal-- Portability : non-portable (GHC Extensions)---- Access to GHC's call-stack simulation---- @since 4.5.0.0-----------------------------------------------------------------------------{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}moduleGHC.Stack.CCS(-- * Call stackscurrentCallStack ,whoCreated ,-- * InternalsCostCentreStack ,CostCentre ,getCurrentCCS ,getCCSOf ,clearCCS ,ccsCC ,ccsParent ,ccLabel ,ccModule ,ccSrcSpan ,ccsToStrings ,renderStack ,)whereimportForeign importForeign.C importGHC.Base importGHC.Ptr importGHC.Foreign asGHCimportGHC.IO.Encoding importGHC.List (concatMap ,reverse )-- | A cost-centre stack from GHC's cost-center profiler.dataCostCentreStack -- | A cost-centre from GHC's cost-center profiler.dataCostCentre -- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current-- program was not compiled with profiling support). Takes a dummy argument-- which can be used to avoid the call to @getCurrentCCS@ being floated out by-- the simplifier, which would result in an uninformative stack ("CAF").getCurrentCCS ::dummy ->IO (Ptr CostCentreStack )getCurrentCCS :: forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS dummy
dummy =(State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
-> IO (Ptr CostCentreStack)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
 -> IO (Ptr CostCentreStack))
-> (State# RealWorld
 -> (# State# RealWorld, Ptr CostCentreStack #))
-> IO (Ptr CostCentreStack)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->casedummy -> State# RealWorld -> (# State# RealWorld, Addr# #)
forall a d. a -> State# d -> (# State# d, Addr# #)
getCurrentCCS# dummy
dummy State# RealWorld
s of(#State# RealWorld
s' ,Addr#
addr #)->(#State# RealWorld
s' ,Addr# -> Ptr CostCentreStack
forall a. Addr# -> Ptr a
Ptr Addr#
addr #)-- | Get the 'CostCentreStack' associated with the given value.getCCSOf ::a ->IO (Ptr CostCentreStack )getCCSOf :: forall dummy. dummy -> IO (Ptr CostCentreStack)
getCCSOf a
obj =(State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
-> IO (Ptr CostCentreStack)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
 -> IO (Ptr CostCentreStack))
-> (State# RealWorld
 -> (# State# RealWorld, Ptr CostCentreStack #))
-> IO (Ptr CostCentreStack)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->casea -> State# RealWorld -> (# State# RealWorld, Addr# #)
forall a d. a -> State# d -> (# State# d, Addr# #)
getCCSOf# a
obj State# RealWorld
s of(#State# RealWorld
s' ,Addr#
addr #)->(#State# RealWorld
s' ,Addr# -> Ptr CostCentreStack
forall a. Addr# -> Ptr a
Ptr Addr#
addr #)-- | Run a computation with an empty cost-center stack. For example, this is-- used by the interpreter to run an interpreted computation without the call-- stack showing that it was invoked from GHC.clearCCS ::IO a ->IO a clearCCS :: forall a. IO a -> IO a
clearCCS (IO State# RealWorld -> (# State# RealWorld, a #)
m )=(State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
forall d a.
(State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
clearCCS# State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s -- | Get the 'CostCentre' at the head of a 'CostCentreStack'.{-# LINE 95 "libraries/base/GHC/Stack/CCS.hsc" #-}ccsCC ::Ptr CostCentreStack ->IO (Ptr CostCentre )ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC Ptr CostCentreStack
p =((\Ptr CostCentreStack
hsc_ptr ->Ptr CostCentreStack -> Int -> IO (Ptr CostCentre)
forall b. Ptr b -> Int -> IO (Ptr CostCentre)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentreStack
hsc_ptr Int
8))Ptr CostCentreStack
p {-# LINE 97 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the tail of a 'CostCentreStack'.ccsParent ::Ptr CostCentreStack ->IO (Ptr CostCentreStack )ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent Ptr CostCentreStack
p =((\Ptr CostCentreStack
hsc_ptr ->Ptr CostCentreStack -> Int -> IO (Ptr CostCentreStack)
forall b. Ptr b -> Int -> IO (Ptr CostCentreStack)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentreStack
hsc_ptr Int
16))Ptr CostCentreStack
p {-# LINE 101 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the label of a 'CostCentre'.ccLabel ::Ptr CostCentre ->IO CString ccLabel :: Ptr CostCentre -> IO CString
ccLabel Ptr CostCentre
p =((\Ptr CostCentre
hsc_ptr ->Ptr CostCentre -> Int -> IO CString
forall b. Ptr b -> Int -> IO CString
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
8))Ptr CostCentre
p {-# LINE 105 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the module of a 'CostCentre'.ccModule ::Ptr CostCentre ->IO CString ccModule :: Ptr CostCentre -> IO CString
ccModule Ptr CostCentre
p =((\Ptr CostCentre
hsc_ptr ->Ptr CostCentre -> Int -> IO CString
forall b. Ptr b -> Int -> IO CString
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
16))Ptr CostCentre
p {-# LINE 109 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the source span of a 'CostCentre'.ccSrcSpan ::Ptr CostCentre ->IO CString ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan Ptr CostCentre
p =((\Ptr CostCentre
hsc_ptr ->Ptr CostCentre -> Int -> IO CString
forall b. Ptr b -> Int -> IO CString
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
24))Ptr CostCentre
p {-# LINE 113 "libraries/base/GHC/Stack/CCS.hsc" #-}{-# LINE 114 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Returns a @[String]@ representing the current call stack. This-- can be useful for debugging.---- The implementation uses the call-stack simulation maintained by the-- profiler, so it only works if the program was compiled with @-prof@-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).-- Otherwise, the list returned is likely to be empty or-- uninformative.---- @since 4.5.0.0currentCallStack ::IO [String ]currentCallStack :: IO [String]
currentCallStack =Ptr CostCentreStack -> IO [String]
ccsToStrings (Ptr CostCentreStack -> IO [String])
-> IO (Ptr CostCentreStack) -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< () -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS ()-- | Format a 'CostCentreStack' as a list of lines.ccsToStrings ::Ptr CostCentreStack ->IO [String ]ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings Ptr CostCentreStack
ccs0 =Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
ccs0 []wherego :: Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
ccs [String]
acc |Ptr CostCentreStack
ccs Ptr CostCentreStack -> Ptr CostCentreStack -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CostCentreStack
forall a. Ptr a
nullPtr =[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
acc |Bool
otherwise =doPtr CostCentre
cc <-Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC Ptr CostCentreStack
ccs String
lbl <-TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccLabel Ptr CostCentre
cc String
mdl <-TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccModule Ptr CostCentre
cc String
loc <-TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccSrcSpan Ptr CostCentre
cc Ptr CostCentreStack
parent <-Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent Ptr CostCentreStack
ccs if(String
mdl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"MAIN"Bool -> Bool -> Bool
&& String
lbl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"MAIN")then[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
acc elsePtr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
parent ((String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
: String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
: String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc )-- | Get the stack trace attached to an object.---- @since 4.5.0.0whoCreated ::a ->IO [String ]whoCreated :: forall a. a -> IO [String]
whoCreated a
obj =doPtr CostCentreStack
ccs <-a -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
getCCSOf a
obj Ptr CostCentreStack -> IO [String]
ccsToStrings Ptr CostCentreStack
ccs renderStack ::[String ]->String renderStack :: [String] -> String
renderStack [String]
strs =String
"CallStack (from -prof):"String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> String
forall a b. (a -> [b]) -> [a] -> [b]
concatMap (String
"\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++ )([String] -> [String]
forall a. [a] -> [a]
reverse [String]
strs )