{-# OPTIONS_GHC -optc-DPROFILING #-}
{-# LINE 1 "libraries/base/GHC/Stack/CCS.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
module GHC.Stack.CCS (
currentCallStack,
whoCreated,
whereFrom,
CostCentreStack,
CostCentre,
getCurrentCCS,
getCCSOf,
clearCCS,
ccsCC,
ccsParent,
ccLabel,
ccModule,
ccSrcSpan,
ccsToStrings,
renderStack,
ipeProv,
peekInfoProv,
InfoProv(..),
InfoProvEnt,
) where
import Foreign
import Foreign.C
import GHC.Base
import GHC.Ptr
import GHC.Foreign as GHC
import GHC.IO.Encoding
import GHC.List ( concatMap, reverse )
import GHC.Show (Show)
data CostCentreStack
data CostCentre
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 ->
case dummy -> 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 #)
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 ->
case a -> 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 #)
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
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 87 "libraries/base/GHC/Stack/CCS.hsc" #-}
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 91 "libraries/base/GHC/Stack/CCS.hsc" #-}
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 95 "libraries/base/GHC/Stack/CCS.hsc" #-}
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 99 "libraries/base/GHC/Stack/CCS.hsc" #-}
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 103 "libraries/base/GHC/Stack/CCS.hsc" #-}
currentCallStack :: 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 ()
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings Ptr CostCentreStack
ccs0 = Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
ccs0 []
where
go :: 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 = do
Ptr 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
else Ptr 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)
whoCreated :: a -> IO [String]
whoCreated :: forall a. a -> IO [String]
whoCreated a
obj = do
Ptr 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)
data InfoProv = InfoProv {
InfoProv -> String
ipName :: String,
InfoProv -> String
ipDesc :: String,
InfoProv -> String
ipTyDesc :: String,
InfoProv -> String
ipLabel :: String,
InfoProv -> String
ipMod :: String,
InfoProv -> String
ipLoc :: String
} deriving (InfoProv -> InfoProv -> Bool
(InfoProv -> InfoProv -> Bool)
-> (InfoProv -> InfoProv -> Bool) -> Eq InfoProv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InfoProv -> InfoProv -> Bool
== :: InfoProv -> InfoProv -> Bool
$c/= :: InfoProv -> InfoProv -> Bool
/= :: InfoProv -> InfoProv -> Bool
Eq, Int -> InfoProv -> String -> String
[InfoProv] -> String -> String
InfoProv -> String
(Int -> InfoProv -> String -> String)
-> (InfoProv -> String)
-> ([InfoProv] -> String -> String)
-> Show InfoProv
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> InfoProv -> String -> String
showsPrec :: Int -> InfoProv -> String -> String
$cshow :: InfoProv -> String
show :: InfoProv -> String
$cshowList :: [InfoProv] -> String -> String
showList :: [InfoProv] -> String -> String
Show)
data InfoProvEnt
getIPE :: a -> IO (Ptr InfoProvEnt)
getIPE :: forall a. a -> IO (Ptr InfoProvEnt)
getIPE a
obj = (State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #))
-> IO (Ptr InfoProvEnt)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #))
-> IO (Ptr InfoProvEnt))
-> (State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #))
-> IO (Ptr InfoProvEnt)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case a -> State# RealWorld -> (# State# RealWorld, Addr# #)
forall a d. a -> State# d -> (# State# d, Addr# #)
whereFrom# a
obj State# RealWorld
s of
(# State# RealWorld
s', Addr#
addr #) -> (# State# RealWorld
s', Addr# -> Ptr InfoProvEnt
forall a. Addr# -> Ptr a
Ptr Addr#
addr #)
ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv Ptr InfoProvEnt
p = ((\Ptr InfoProvEnt
hsc_ptr -> Ptr InfoProvEnt
hsc_ptr Ptr InfoProvEnt -> Int -> Ptr InfoProv
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8)) Ptr InfoProvEnt
p
{-# LINE 164 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString
peekIpName :: Ptr InfoProv -> IO CString
peekIpName Ptr InfoProv
p = ((\Ptr InfoProv
hsc_ptr -> Ptr InfoProv -> Int -> IO CString
forall b. Ptr b -> Int -> IO CString
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr InfoProv
hsc_ptr Int
0)) Ptr InfoProv
p
{-# LINE 167 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 168 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
{-# LINE 169 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
{-# LINE 170 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpSrcLoc p = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) p
{-# LINE 171 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekIpTyDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 172 "libraries/base/GHC/Stack/CCS.hsc" #-}
peekInfoProv :: Ptr InfoProv -> IO InfoProv
peekInfoProv :: Ptr InfoProv -> IO InfoProv
peekInfoProv Ptr InfoProv
infop = do
String
name <- 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 InfoProv -> IO CString
peekIpName Ptr InfoProv
infop
String
desc <- 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 InfoProv -> IO CString
peekIpDesc Ptr InfoProv
infop
String
tyDesc <- 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 InfoProv -> IO CString
peekIpTyDesc Ptr InfoProv
infop
String
label <- 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 InfoProv -> IO CString
peekIpLabel Ptr InfoProv
infop
String
mod <- 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 InfoProv -> IO CString
peekIpModule Ptr InfoProv
infop
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 InfoProv -> IO CString
peekIpSrcLoc Ptr InfoProv
infop
InfoProv -> IO InfoProv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InfoProv {
ipName :: String
ipName = String
name,
ipDesc :: String
ipDesc = String
desc,
ipTyDesc :: String
ipTyDesc = String
tyDesc,
ipLabel :: String
ipLabel = String
label,
ipMod :: String
ipMod = String
mod,
ipLoc :: String
ipLoc = String
loc
}
whereFrom :: a -> IO (Maybe InfoProv)
whereFrom :: forall a. a -> IO (Maybe InfoProv)
whereFrom a
obj = do
Ptr InfoProvEnt
ipe <- a -> IO (Ptr InfoProvEnt)
forall a. a -> IO (Ptr InfoProvEnt)
getIPE a
obj
if Ptr InfoProvEnt
ipe Ptr InfoProvEnt -> Ptr InfoProvEnt -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr InfoProvEnt
forall a. Ptr a
nullPtr
then Maybe InfoProv -> IO (Maybe InfoProv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InfoProv
forall a. Maybe a
Nothing
else do
InfoProv
infoProv <- Ptr InfoProv -> IO InfoProv
peekInfoProv (Ptr InfoProvEnt -> Ptr InfoProv
ipeProv Ptr InfoProvEnt
ipe)
Maybe InfoProv -> IO (Maybe InfoProv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InfoProv -> IO (Maybe InfoProv))
-> Maybe InfoProv -> IO (Maybe InfoProv)
forall a b. (a -> b) -> a -> b
$ InfoProv -> Maybe InfoProv
forall a. a -> Maybe a
Just InfoProv
infoProv