{-# 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
) 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 )
data CostCentreStack
data CostCentre
getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
getCurrentCCS dummy = IO $ \s ->
case getCurrentCCS# dummy s of
(# s', addr #) -> (# s', Ptr addr #)
getCCSOf :: a -> IO (Ptr CostCentreStack)
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 = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 82 "libraries/base/GHC/Stack/CCS.hsc" #-}
ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 86 "libraries/base/GHC/Stack/CCS.hsc" #-}
ccLabel :: Ptr CostCentre -> IO CString
ccLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 90 "libraries/base/GHC/Stack/CCS.hsc" #-}
ccModule :: Ptr CostCentre -> IO CString
ccModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 94 "libraries/base/GHC/Stack/CCS.hsc" #-}
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
{-# LINE 98 "libraries/base/GHC/Stack/CCS.hsc" #-}
currentCallStack :: IO [String]
currentCallStack = ccsToStrings =<< getCurrentCCS ()
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings ccs0 = go ccs0 []
where
go ccs acc
| ccs == nullPtr = return acc
| otherwise = do
cc <- ccsCC ccs
lbl <- GHC.peekCString utf8 =<< ccLabel cc
mdl <- GHC.peekCString utf8 =<< ccModule cc
loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
parent <- ccsParent ccs
if (mdl == "MAIN" && lbl == "MAIN")
then return acc
else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
whoCreated :: a -> IO [String]
whoCreated obj = do
ccs <- getCCSOf obj
ccsToStrings ccs
renderStack :: [String] -> String
renderStack strs =
"CallStack (from -prof):" ++ concatMap ("\n "++) (reverse strs)
data InfoProv
data InfoProvEnt
getIPE :: a -> IO (Ptr InfoProvEnt)
getIPE obj = IO $ \s ->
case whereFrom# obj s of
(# s', addr #) -> (# s', Ptr addr #)
ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv p = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p
{-# LINE 152 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString
ipName p = ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 155 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 156 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
{-# LINE 157 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
{-# LINE 158 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipSrcLoc p = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) p
{-# LINE 159 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipTyDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 160 "libraries/base/GHC/Stack/CCS.hsc" #-}
infoProvToStrings :: Ptr InfoProv -> IO [String]
infoProvToStrings infop = do
name <- GHC.peekCString utf8 =<< ipName infop
desc <- GHC.peekCString utf8 =<< ipDesc infop
ty_desc <- GHC.peekCString utf8 =<< ipTyDesc infop
label <- GHC.peekCString utf8 =<< ipLabel infop
mod <- GHC.peekCString utf8 =<< ipModule infop
loc <- GHC.peekCString utf8 =<< ipSrcLoc infop
return [name, desc, ty_desc, label, mod, loc]
whereFrom :: a -> IO [String]
whereFrom obj = do
ipe <- getIPE obj
if ipe == nullPtr
then return []
else infoProvToStrings (ipeProv ipe)