module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled(
peekStgTSOProfInfo
, peekTopCCS
) where
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Foreign
import Foreign.C.String
import GHC.Exts
import GHC.Exts.Heap.ProfInfo.Types
import Prelude
type AddressSet = IntSet
type AddressMap = IntMap
peekStgTSOProfInfo :: (Ptr b -> IO (Maybe CostCentreStack)) -> Ptr a -> IO (Maybe StgTSOProfInfo)
peekStgTSOProfInfo decodeCCS tsoPtr = do
cccs_ptr <- peekByteOff tsoPtr cccsOffset
cccs' <- decodeCCS cccs_ptr
return $ Just StgTSOProfInfo {
cccs = cccs'
}
peekTopCCS :: Ptr b -> IO (Maybe CostCentreStack)
peekTopCCS cccs_ptr = do
costCenterCacheRef <- newIORef IntMap.empty
peekCostCentreStack IntSet.empty costCenterCacheRef cccs_ptr
cccsOffset :: Int
cccsOffset = (112) + ((24))
peekCostCentreStack
:: AddressSet
-> IORef (AddressMap CostCentre)
-> Ptr costCentreStack
-> IO (Maybe CostCentreStack)
peekCostCentreStack _ _ ptr | ptr == nullPtr = return Nothing
peekCostCentreStack loopBreakers _ ptr | IntSet.member (ptrToInt ptr) loopBreakers = return Nothing
peekCostCentreStack loopBreakers costCenterCacheRef ptr = do
ccs_ccsID' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
ccs_cc_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
ccs_cc' <- peekCostCentre costCenterCacheRef ccs_cc_ptr
ccs_prevStack_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
let loopBreakers' = (IntSet.insert ptrAsInt loopBreakers)
ccs_prevStack' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_prevStack_ptr
ccs_indexTable_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
ccs_indexTable' <- peekIndexTable loopBreakers' costCenterCacheRef ccs_indexTable_ptr
ccs_root_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) ptr
ccs_root' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_root_ptr
ccs_depth' <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr
ccs_scc_count' <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) ptr
ccs_selected' <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) ptr
ccs_time_ticks' <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) ptr
ccs_mem_alloc' <- ((\hsc_ptr -> peekByteOff hsc_ptr 72)) ptr
ccs_inherited_alloc' <- ((\hsc_ptr -> peekByteOff hsc_ptr 80)) ptr
ccs_inherited_ticks' <- ((\hsc_ptr -> peekByteOff hsc_ptr 88)) ptr
return $ Just CostCentreStack {
ccs_ccsID = ccs_ccsID',
ccs_cc = ccs_cc',
ccs_prevStack = ccs_prevStack',
ccs_indexTable = ccs_indexTable',
ccs_root = ccs_root',
ccs_depth = ccs_depth',
ccs_scc_count = ccs_scc_count',
ccs_selected = ccs_selected',
ccs_time_ticks = ccs_time_ticks',
ccs_mem_alloc = ccs_mem_alloc',
ccs_inherited_alloc = ccs_inherited_alloc',
ccs_inherited_ticks = ccs_inherited_ticks'
}
where
ptrAsInt = ptrToInt ptr
peekCostCentre :: IORef (AddressMap CostCentre) -> Ptr costCentre -> IO CostCentre
peekCostCentre costCenterCacheRef ptr = do
costCenterCache <- readIORef costCenterCacheRef
case IntMap.lookup ptrAsInt costCenterCache of
(Just a) -> return a
Nothing -> do
cc_ccID' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
cc_label_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
cc_label' <- peekCString cc_label_ptr
cc_module_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
cc_module' <- peekCString cc_module_ptr
cc_srcloc_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
cc_srcloc' <- do
if cc_srcloc_ptr == nullPtr then
return Nothing
else
fmap Just (peekCString cc_srcloc_ptr)
cc_mem_alloc' <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) ptr
cc_time_ticks' <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) ptr
cc_is_caf' <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) ptr
cc_link_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) ptr
cc_link' <- if cc_link_ptr == nullPtr then
return Nothing
else
fmap Just (peekCostCentre costCenterCacheRef cc_link_ptr)
let result = CostCentre {
cc_ccID = cc_ccID',
cc_label = cc_label',
cc_module = cc_module',
cc_srcloc = cc_srcloc',
cc_mem_alloc = cc_mem_alloc',
cc_time_ticks = cc_time_ticks',
cc_is_caf = cc_is_caf',
cc_link = cc_link'
}
writeIORef costCenterCacheRef (IntMap.insert ptrAsInt result costCenterCache)
return result
where
ptrAsInt = ptrToInt ptr
peekIndexTable :: AddressSet -> IORef (AddressMap CostCentre) -> Ptr indexTable -> IO (Maybe IndexTable)
peekIndexTable _ _ ptr | ptr == nullPtr = return Nothing
peekIndexTable loopBreakers costCenterCacheRef ptr = do
it_cc_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr
it_ccs_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr
it_next_ptr <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr
it_back_edge' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
return $ Just IndexTable {
it_cc = it_cc',
it_ccs = it_ccs',
it_next = it_next',
it_back_edge = it_back_edge'
}
ptrToInt :: Ptr a -> Int
ptrToInt (Ptr a#) = I# (addr2Int# a#)