diff options
Diffstat (limited to 'libraries/ghc-heap/GHC')
9 files changed, 683 insertions, 4 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 7ecdaac9bc..2dfe788406 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -27,6 +27,9 @@ module GHC.Exts.Heap ( , GenClosure(..) , ClosureType(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , HasHeapRep(getClosureData) , getClosureDataFromHeapRep , getClosureDataFromHeapRepPrim @@ -40,6 +43,12 @@ module GHC.Exts.Heap ( , peekItbl , pokeItbl + -- * Cost Centre (profiling) types + , StgTSOProfInfo(..) + , IndexTable(..) + , CostCentre(..) + , CostCentreStack(..) + -- * Closure inspection , getBoxedClosureData , allClosures @@ -54,12 +63,14 @@ import Prelude import GHC.Exts.Heap.Closures import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Constants +import GHC.Exts.Heap.ProfInfo.Types #if defined(PROFILING) import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable #endif import GHC.Exts.Heap.Utils +import qualified GHC.Exts.Heap.FFIClosures as FFIClosures import Control.Monad import Data.Bits @@ -330,6 +341,45 @@ getClosureDataFromHeapRepPrim getConDesc itbl heapRep pts = do , finalizer = pts !! 3 , link = pts !! 4 } + TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts + -> withArray rawHeapWords (\ptr -> do + fields <- FFIClosures.peekTSOFields ptr + pure $ TSOClosure + { info = itbl + , link = u_lnk + , global_link = u_gbl_lnk + , tsoStack = tso_stack + , trec = u_trec + , blocked_exceptions = u_blk_ex + , bq = u_bq + , what_next = FFIClosures.tso_what_next fields + , why_blocked = FFIClosures.tso_why_blocked fields + , flags = FFIClosures.tso_flags fields + , threadId = FFIClosures.tso_threadId fields + , saved_errno = FFIClosures.tso_saved_errno fields + , tso_dirty = FFIClosures.tso_dirty fields + , alloc_limit = FFIClosures.tso_alloc_limit fields + , tot_stack_size = FFIClosures.tso_tot_stack_size fields + , prof = FFIClosures.tso_prof fields + }) + | otherwise + -> fail $ "Expected 6 ptr arguments to TSO, found " + ++ show (length pts) + STACK + | [] <- pts + -> withArray rawHeapWords (\ptr -> do + fields <- FFIClosures.peekStackFields ptr + pure $ StackClosure + { info = itbl + , stack_size = FFIClosures.stack_size fields + , stack_dirty = FFIClosures.stack_dirty fields +#if __GLASGOW_HASKELL__ >= 811 + , stack_marking = FFIClosures.stack_marking fields +#endif + }) + | otherwise + -> fail $ "Expected 0 ptr argument to STACK, found " + ++ show (length pts) _ -> pure $ UnsupportedClosure itbl diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index 8a959fc2a0..3c5d5f1c32 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -12,6 +12,9 @@ module GHC.Exts.Heap.Closures ( Closure , GenClosure(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , allClosures #if __GLASGOW_HASKELL__ >= 809 -- The closureSize# primop is unsupported on earlier GHC releases but we @@ -40,6 +43,8 @@ import GHC.Exts.Heap.InfoTable import GHC.Exts.Heap.InfoTableProf () #endif +import GHC.Exts.Heap.ProfInfo.Types + import Data.Bits import Data.Int import Data.Word @@ -100,11 +105,11 @@ type Closure = GenClosure Box -- | This is the representation of a Haskell value on the heap. It reflects -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h> -- --- The data type is parametrized by the type to store references in. Usually --- this is a 'Box' with the type synonym 'Closure'. +-- The data type is parametrized by `b`: the type to store references in. +-- Usually this is a 'Box' with the type synonym 'Closure'. -- --- All Heap objects have the same basic layout. A header containing a pointer --- to the info table and a payload with various fields. The @info@ field below +-- All Heap objects have the same basic layout. A header containing a pointer to +-- the info table and a payload with various fields. The @info@ field below -- always refers to the info table pointed to by the header. The remaining -- fields are the payload. -- @@ -268,6 +273,39 @@ data GenClosure b , link :: !b -- ^ next weak pointer for the capability, can be NULL. } + -- | Representation of StgTSO: A Thread State Object. The values for + -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@. + | TSOClosure + { info :: !StgInfoTable + -- pointers + , link :: !b + , global_link :: !b + , tsoStack :: !b -- ^ stackobj from StgTSO + , trec :: !b + , blocked_exceptions :: !b + , bq :: !b + -- values + , what_next :: !WhatNext + , why_blocked :: !WhyBlocked + , flags :: ![TsoFlags] + , threadId :: !Word64 + , saved_errno :: !Word32 + , tso_dirty :: !Word32 -- ^ non-zero => dirty + , alloc_limit :: !Int64 + , tot_stack_size :: !Word32 + , prof :: !(Maybe StgTSOProfInfo) + } + + -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'. + | StackClosure + { info :: !StgInfoTable + , stack_size :: !Word32 -- ^ stack size in *words* + , stack_dirty :: !Word8 -- ^ non-zero => dirty +#if __GLASGOW_HASKELL__ >= 811 + , stack_marking :: !Word8 +#endif + } + ------------------------------------------------------------ -- Unboxed unlifted closures @@ -332,6 +370,43 @@ data PrimType | PDouble deriving (Eq, Show, Generic) +data WhatNext + = ThreadRunGHC + | ThreadInterpret + | ThreadKilled + | ThreadComplete + | WhatNextUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + +data WhyBlocked + = NotBlocked + | BlockedOnMVar + | BlockedOnMVarRead + | BlockedOnBlackHole + | BlockedOnRead + | BlockedOnWrite + | BlockedOnDelay + | BlockedOnSTM + | BlockedOnDoProc + | BlockedOnCCall + | BlockedOnCCall_Interruptible + | BlockedOnMsgThrowTo + | ThreadMigrating + | BlockedOnIOCompletion + | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + +data TsoFlags + = TsoLocked + | TsoBlockx + | TsoInterruptible + | TsoStoppedOnBreakpoint + | TsoMarked + | TsoSqueezed + | TsoAllocLimit + | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + -- | For generic code, this function returns all referenced closures. allClosures :: GenClosure b -> [b] allClosures (ConstrClosure {..}) = ptrArgs diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs new file mode 100644 index 0000000000..14004b0b1f --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.FFIClosures (module Reexport) where + +-- NOTE [hsc and CPP workaround] +-- +-- # Problem +-- +-- Often, .hsc files are used to get the correct offsets of C struct fields. +-- Those structs may be affected by CPP directives e.g. profiled vs not profiled +-- closure headers is affected by the PROFILED cpp define. Since we are building +-- multiple variants of the RTS, we must support all possible offsets e.g. by +-- running hsc2hs with cpp defines corresponding to each RTS flavour. The +-- problem is that GHC's build system runs hsc2hs *only once* per .hsc file +-- without properly setting cpp defines. This results in the same (probably +-- incorrect) offsets into our C structs. +-- +-- +-- # Workaround +-- +-- To work around this issue, we create multiple .hsc files each manually +-- defining thir cpp defines (see e.g. FFIClosures_ProfilingDisabled.hsc and +-- FFIClosures_ProfilingEnabled.hsc). Then we rely on cpp defines working +-- correctly in .hs files and use CPP to switch on which .hsc module to +-- re-export (see below). In each case we import the desired .hsc module as +-- `Reexport` and we import `()` (i.e. nothing) from all other .hsc variants +-- just so that the build system sees all .hsc file as dependencies. +-- +-- +-- # Future Work +-- +-- * Duplication of the code in the .hsc files could be reduced simply by +-- placing the code in a single .hsc.in file and `#include`ing it from each +-- .hsc file. The .hsc files would only be responsible for setting the correct +-- cpp defines. This currently doesn't work as hadrian doesn't know to copy +-- the .hsc.in file to the build directory. +-- * The correct solution would be for the build system to run `hsc2hs` with the +-- correct cpp defines once per RTS flavour. +-- + +#if defined(PROFILING) +import GHC.Exts.Heap.FFIClosures_ProfilingEnabled as Reexport +import GHC.Exts.Heap.FFIClosures_ProfilingDisabled () +#else +import GHC.Exts.Heap.FFIClosures_ProfilingDisabled as Reexport +import GHC.Exts.Heap.FFIClosures_ProfilingEnabled () +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc new file mode 100644 index 0000000000..eabb098a15 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where + +-- See [hsc and CPP workaround] + +#undef PROFILING +#include "Rts.h" + +import Prelude +import Foreign +import GHC.Exts +import GHC.Exts.Heap.ProfInfo.PeekProfInfo +import GHC.Exts.Heap.ProfInfo.Types +import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..)) + +data TSOFields = TSOFields { + tso_what_next :: WhatNext, + tso_why_blocked :: WhyBlocked, + tso_flags :: [TsoFlags], +-- Unfortunately block_info is a union without clear discriminator. +-- block_info :: TDB, + tso_threadId :: Word64, + tso_saved_errno :: Word32, + tso_dirty:: Word32, + tso_alloc_limit :: Int64, + tso_tot_stack_size :: Word32, + tso_prof :: Maybe StgTSOProfInfo +} + +-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@) +peekTSOFields :: Ptr tsoPtr -> IO TSOFields +peekTSOFields ptr = do + what_next' <- (#peek struct StgTSO_, what_next) ptr + why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr + flags' <- (#peek struct StgTSO_, flags) ptr + threadId' <- (#peek struct StgTSO_, id) ptr + saved_errno' <- (#peek struct StgTSO_, saved_errno) ptr + dirty' <- (#peek struct StgTSO_, dirty) ptr + alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr + tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr + tso_prof' <- peekStgTSOProfInfo ptr + + return TSOFields { + tso_what_next = parseWhatNext what_next', + tso_why_blocked = parseWhyBlocked why_blocked', + tso_flags = parseTsoFlags flags', + tso_threadId = threadId', + tso_saved_errno = saved_errno', + tso_dirty = dirty', + tso_alloc_limit = alloc_limit', + tso_tot_stack_size = tot_stack_size', + tso_prof = tso_prof' + } + +parseWhatNext :: Word16 -> WhatNext +parseWhatNext w = case w of + (#const ThreadRunGHC) -> ThreadRunGHC + (#const ThreadInterpret) -> ThreadInterpret + (#const ThreadKilled) -> ThreadKilled + (#const ThreadComplete) -> ThreadComplete + _ -> WhatNextUnknownValue w + +parseWhyBlocked :: Word16 -> WhyBlocked +parseWhyBlocked w = case w of + (#const NotBlocked) -> NotBlocked + (#const BlockedOnMVar) -> BlockedOnMVar + (#const BlockedOnMVarRead) -> BlockedOnMVarRead + (#const BlockedOnBlackHole) -> BlockedOnBlackHole + (#const BlockedOnRead) -> BlockedOnRead + (#const BlockedOnWrite) -> BlockedOnWrite + (#const BlockedOnDelay) -> BlockedOnDelay + (#const BlockedOnSTM) -> BlockedOnSTM + (#const BlockedOnDoProc) -> BlockedOnDoProc + (#const BlockedOnCCall) -> BlockedOnCCall + (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible + (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo + (#const ThreadMigrating) -> ThreadMigrating +#if __GLASGOW_HASKELL__ >= 811 + (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion +#endif + _ -> WhyBlockedUnknownValue w + +parseTsoFlags :: Word32 -> [TsoFlags] +parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w) + | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w) + | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w) + | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w) + | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) + | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) + | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +parseTsoFlags 0 = [] +parseTsoFlags w = [TsoFlagsUnknownValue w] + +isSet :: Word32 -> Word32 -> Bool +isSet bitMask w = w .&. bitMask /= 0 + +unset :: Word32 -> Word32 -> Word32 +unset bitMask w = w `xor` bitMask + +data StackFields = StackFields { + stack_size :: Word32, + stack_dirty :: Word8, +#if __GLASGOW_HASKELL__ >= 811 + stack_marking :: Word8, +#endif + stack_sp :: Addr## +} + +-- | Get non-closure fields from @StgStack_@ (@TSO.h@) +peekStackFields :: Ptr a -> IO StackFields +peekStackFields ptr = do + stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32 + dirty' <- (#peek struct StgStack_, dirty) ptr +#if __GLASGOW_HASKELL__ >= 811 + marking' <- (#peek struct StgStack_, marking) ptr +#endif + Ptr sp' <- (#peek struct StgStack_, sp) ptr + + -- TODO decode the stack. + + return StackFields { + stack_size = stack_size', + stack_dirty = dirty', +#if __GLASGOW_HASKELL__ >= 811 + stack_marking = marking', +#endif + stack_sp = sp' + } + diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc new file mode 100644 index 0000000000..124940d1cd --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.FFIClosures_ProfilingEnabled where + +-- See [hsc and CPP workaround] + +#define PROFILING +#include "Rts.h" + +import Prelude +import Foreign +import GHC.Exts +import GHC.Exts.Heap.ProfInfo.PeekProfInfo +import GHC.Exts.Heap.ProfInfo.Types +import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..)) + +data TSOFields = TSOFields { + tso_what_next :: WhatNext, + tso_why_blocked :: WhyBlocked, + tso_flags :: [TsoFlags], +-- Unfortunately block_info is a union without clear discriminator. +-- block_info :: TDB, + tso_threadId :: Word64, + tso_saved_errno :: Word32, + tso_dirty:: Word32, + tso_alloc_limit :: Int64, + tso_tot_stack_size :: Word32, + tso_prof :: Maybe StgTSOProfInfo +} + +-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@) +peekTSOFields :: Ptr tsoPtr -> IO TSOFields +peekTSOFields ptr = do + what_next' <- (#peek struct StgTSO_, what_next) ptr + why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr + flags' <- (#peek struct StgTSO_, flags) ptr + threadId' <- (#peek struct StgTSO_, id) ptr + saved_errno' <- (#peek struct StgTSO_, saved_errno) ptr + dirty' <- (#peek struct StgTSO_, dirty) ptr + alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr + tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr + tso_prof' <- peekStgTSOProfInfo ptr + + return TSOFields { + tso_what_next = parseWhatNext what_next', + tso_why_blocked = parseWhyBlocked why_blocked', + tso_flags = parseTsoFlags flags', + tso_threadId = threadId', + tso_saved_errno = saved_errno', + tso_dirty = dirty', + tso_alloc_limit = alloc_limit', + tso_tot_stack_size = tot_stack_size', + tso_prof = tso_prof' + } + +parseWhatNext :: Word16 -> WhatNext +parseWhatNext w = case w of + (#const ThreadRunGHC) -> ThreadRunGHC + (#const ThreadInterpret) -> ThreadInterpret + (#const ThreadKilled) -> ThreadKilled + (#const ThreadComplete) -> ThreadComplete + _ -> WhatNextUnknownValue w + +parseWhyBlocked :: Word16 -> WhyBlocked +parseWhyBlocked w = case w of + (#const NotBlocked) -> NotBlocked + (#const BlockedOnMVar) -> BlockedOnMVar + (#const BlockedOnMVarRead) -> BlockedOnMVarRead + (#const BlockedOnBlackHole) -> BlockedOnBlackHole + (#const BlockedOnRead) -> BlockedOnRead + (#const BlockedOnWrite) -> BlockedOnWrite + (#const BlockedOnDelay) -> BlockedOnDelay + (#const BlockedOnSTM) -> BlockedOnSTM + (#const BlockedOnDoProc) -> BlockedOnDoProc + (#const BlockedOnCCall) -> BlockedOnCCall + (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible + (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo + (#const ThreadMigrating) -> ThreadMigrating +#if __GLASGOW_HASKELL__ >= 811 + (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion +#endif + _ -> WhyBlockedUnknownValue w + +parseTsoFlags :: Word32 -> [TsoFlags] +parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w) + | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w) + | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w) + | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w) + | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w) + | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w) + | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w) +parseTsoFlags 0 = [] +parseTsoFlags w = [TsoFlagsUnknownValue w] + +isSet :: Word32 -> Word32 -> Bool +isSet bitMask w = w .&. bitMask /= 0 + +unset :: Word32 -> Word32 -> Word32 +unset bitMask w = w `xor` bitMask + +data StackFields = StackFields { + stack_size :: Word32, + stack_dirty :: Word8, +#if __GLASGOW_HASKELL__ >= 811 + stack_marking :: Word8, +#endif + stack_sp :: Addr## +} + +-- | Get non-closure fields from @StgStack_@ (@TSO.h@) +peekStackFields :: Ptr a -> IO StackFields +peekStackFields ptr = do + stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32 + dirty' <- (#peek struct StgStack_, dirty) ptr +#if __GLASGOW_HASKELL__ >= 811 + marking' <- (#peek struct StgStack_, marking) ptr +#endif + Ptr sp' <- (#peek struct StgStack_, sp) ptr + + -- TODO decode the stack. + + return StackFields { + stack_size = stack_size', + stack_dirty = dirty', +#if __GLASGOW_HASKELL__ >= 811 + stack_marking = marking', +#endif + stack_sp = sp' + } diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs new file mode 100644 index 0000000000..48dce2b8cb --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.ProfInfo.PeekProfInfo (module Reexport) where + +-- See [hsc and CPP workaround] + +#if defined(PROFILING) +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled as Reexport +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled () +#else +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled as Reexport +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled () +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc new file mode 100644 index 0000000000..0f574b4f03 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc @@ -0,0 +1,12 @@ +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled( + peekStgTSOProfInfo +) where + +import Prelude +import Foreign +import GHC.Exts.Heap.ProfInfo.Types + +-- | This implementation is used when PROFILING is undefined. +-- It always returns 'Nothing', because there is no profiling info available. +peekStgTSOProfInfo :: Ptr tsoPtr -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ = return Nothing diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc new file mode 100644 index 0000000000..363d73d79a --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled( + peekStgTSOProfInfo +) where + +#if __GLASGOW_HASKELL__ >= 811 + +-- See [hsc and CPP workaround] + +#define PROFILING + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +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 + +-- Use Int based containers for pointers (addresses) for better performance. +-- These will be queried a lot! +type AddressSet = IntSet +type AddressMap = IntMap + +peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo tsoPtr = do + cccs_ptr <- peekByteOff tsoPtr cccsOffset + costCenterCacheRef <- newIORef IntMap.empty + cccs' <- peekCostCentreStack IntSet.empty costCenterCacheRef cccs_ptr + + return $ Just StgTSOProfInfo { + cccs = cccs' + } + +cccsOffset :: Int +cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader) + +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' <- (#peek struct CostCentreStack_, ccsID) ptr + ccs_cc_ptr <- (#peek struct CostCentreStack_, cc) ptr + ccs_cc' <- peekCostCentre costCenterCacheRef ccs_cc_ptr + ccs_prevStack_ptr <- (#peek struct CostCentreStack_, prevStack) ptr + let loopBreakers' = (IntSet.insert ptrAsInt loopBreakers) + ccs_prevStack' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_prevStack_ptr + ccs_indexTable_ptr <- (#peek struct CostCentreStack_, indexTable) ptr + ccs_indexTable' <- peekIndexTable loopBreakers' costCenterCacheRef ccs_indexTable_ptr + ccs_root_ptr <- (#peek struct CostCentreStack_, root) ptr + ccs_root' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_root_ptr + ccs_depth' <- (#peek struct CostCentreStack_, depth) ptr + ccs_scc_count' <- (#peek struct CostCentreStack_, scc_count) ptr + ccs_selected' <- (#peek struct CostCentreStack_, selected) ptr + ccs_time_ticks' <- (#peek struct CostCentreStack_, time_ticks) ptr + ccs_mem_alloc' <- (#peek struct CostCentreStack_, mem_alloc) ptr + ccs_inherited_alloc' <- (#peek struct CostCentreStack_, inherited_alloc) ptr + ccs_inherited_ticks' <- (#peek struct CostCentreStack_, inherited_ticks) 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' <- (#peek struct CostCentre_, ccID) ptr + cc_label_ptr <- (#peek struct CostCentre_, label) ptr + cc_label' <- peekCString cc_label_ptr + cc_module_ptr <- (#peek struct CostCentre_, module) ptr + cc_module' <- peekCString cc_module_ptr + cc_srcloc_ptr <- (#peek struct CostCentre_, srcloc) ptr + cc_srcloc' <- do + if cc_srcloc_ptr == nullPtr then + return Nothing + else + fmap Just (peekCString cc_srcloc_ptr) + cc_mem_alloc' <- (#peek struct CostCentre_, mem_alloc) ptr + cc_time_ticks' <- (#peek struct CostCentre_, time_ticks) ptr + cc_is_caf' <- (#peek struct CostCentre_, is_caf) ptr + cc_link_ptr <- (#peek struct CostCentre_, link) 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 <- (#peek struct IndexTable_, cc) ptr + it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr + it_ccs_ptr <- (#peek struct IndexTable_, ccs) ptr + it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr + it_next_ptr <- (#peek struct IndexTable_, next) ptr + it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr + it_back_edge' <- (#peek struct IndexTable_, back_edge) ptr + + return $ Just IndexTable { + it_cc = it_cc', + it_ccs = it_ccs', + it_next = it_next', + it_back_edge = it_back_edge' + } + +-- | casts a @Ptr@ to an @Int@ +ptrToInt :: Ptr a -> Int +ptrToInt (Ptr a##) = I## (addr2Int## a##) + +#else +import Prelude +import Foreign + +import GHC.Exts.Heap.ProfInfo.Types + +peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ = return Nothing +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs new file mode 100644 index 0000000000..b6915b374d --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} + +module GHC.Exts.Heap.ProfInfo.Types where + +import Prelude +import Data.Word +import GHC.Generics + +-- | This is a somewhat faithful representation of StgTSOProfInfo. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/TSO.h> +-- for more details on this data structure. +data StgTSOProfInfo = StgTSOProfInfo { + cccs :: Maybe CostCentreStack +} deriving (Show, Generic) + +-- | This is a somewhat faithful representation of CostCentreStack. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentreStack = CostCentreStack { + ccs_ccsID :: Int, + ccs_cc :: CostCentre, + ccs_prevStack :: Maybe CostCentreStack, + ccs_indexTable :: Maybe IndexTable, + ccs_root :: Maybe CostCentreStack, + ccs_depth :: Word, + ccs_scc_count :: Word64, + ccs_selected :: Word, + ccs_time_ticks :: Word, + ccs_mem_alloc :: Word64, + ccs_inherited_alloc :: Word64, + ccs_inherited_ticks :: Word +} deriving (Show, Generic, Eq) + +-- | This is a somewhat faithful representation of CostCentre. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentre = CostCentre { + cc_ccID :: Int, + cc_label :: String, + cc_module :: String, + cc_srcloc :: Maybe String, + cc_mem_alloc :: Word64, + cc_time_ticks :: Word, + cc_is_caf :: Bool, + cc_link :: Maybe CostCentre +} deriving (Show, Generic, Eq) + +-- | This is a somewhat faithful representation of IndexTable. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data IndexTable = IndexTable { + it_cc :: CostCentre, + it_ccs :: Maybe CostCentreStack, + it_next :: Maybe IndexTable, + it_back_edge :: Bool +} deriving (Show, Generic, Eq) |