diff --git a/GHC/Exts/Heap.hs b/GHC/Exts/Heap.hs --- a/GHC/Exts/Heap.hs +++ b/GHC/Exts/Heap.hs @@ -7,6 +7,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnliftedFFITypes #-} {-| Module : GHC.Exts.Heap @@ -24,7 +27,12 @@ , GenClosure(..) , ClosureType(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , HasHeapRep(getClosureData) + , getClosureDataFromHeapRep + , getClosureDataFromHeapRepPrim -- * Info Table types , StgInfoTable(..) @@ -35,6 +43,12 @@ , peekItbl , pokeItbl + -- * Cost Centre (profiling) types + , StgTSOProfInfo(..) + , IndexTable(..) + , CostCentre(..) + , CostCentreStack(..) + -- * Closure inspection , getBoxedClosureData , allClosures @@ -49,16 +63,19 @@ 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 qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI import Control.Monad import Data.Bits -import GHC.Arr +import Foreign import GHC.Exts import GHC.Int import GHC.Word @@ -66,13 +83,27 @@ #include "ghcconfig.h" class HasHeapRep (a :: TYPE rep) where - getClosureData :: a -> IO Closure + -- | Decode a closure to it's heap representation ('GenClosure'). + getClosureData + :: a + -- ^ Closure to decode. + -> IO Closure + -- ^ Heap representation of the closure. + +#if __GLASGOW_HASKELL__ >= 901 +instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where +#else instance HasHeapRep (a :: TYPE 'LiftedRep) where - getClosureData = getClosure +#endif + getClosureData = getClosureDataFromHeapObject +#if __GLASGOW_HASKELL__ >= 901 +instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where +#else instance HasHeapRep (a :: TYPE 'UnliftedRep) where - getClosureData x = getClosure (unsafeCoerce# x) +#endif + getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x) instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where getClosureData x = return $ @@ -102,52 +133,92 @@ getClosureData x = return $ DoubleClosure { ptipe = PDouble, doubleVal = D# x } --- | This returns the raw representation of the given argument. The second --- component of the triple is the raw words of the closure on the heap, and the --- third component is those words that are actually pointers. Once back in the --- Haskell world, the raw words that hold pointers may be outdated after a --- garbage collector run, but the corresponding values in 'Box's will still --- point to the correct value. -getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box]) -getClosureRaw x = do +-- | Get the heap representation of a closure _at this moment_, even if it is +-- unevaluated or an indirection or other exotic stuff. Beware when passing +-- something to this function, the same caveats as for +-- 'GHC.Exts.Heap.Closures.asBox' apply. +-- +-- For most use cases 'getClosureData' is an easier to use alternative. +-- +-- Currently TSO and STACK objects will return `UnsupportedClosure`. This is +-- because it is not memory safe to extract TSO and STACK objects (done via +-- `unpackClosure#`). Other threads may be mutating those objects and interleave +-- with reads in `unpackClosure#`. This is particularly problematic with STACKs +-- where pointer values may be overwritten by non-pointer values as the +-- corresponding haskell thread runs. +getClosureDataFromHeapObject + :: a + -- ^ Heap object to decode. + -> IO Closure + -- ^ Heap representation of the closure. +getClosureDataFromHeapObject x = do case unpackClosure# x of --- This is a hack to cover the bootstrap compiler using the old version of --- 'unpackClosure'. The new 'unpackClosure' return values are not merely --- a reordering, so using the old version would not work. - (# iptr, dat, pointers #) -> do - let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE - end = fromIntegral nelems - 1 - rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ] - pelems = I# (sizeofArray# pointers) - ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers - pure (Ptr iptr, rawWds, ptrList) + (# infoTableAddr, heapRep, pointersArray #) -> do + let infoTablePtr = Ptr infoTableAddr + ptrList = [case indexArray# pointersArray i of + (# ptr #) -> Box ptr + | I# i <- [0..(I# (sizeofArray# pointersArray)) - 1] + ] --- From GHC.Runtime.Heap.Inspect -amap' :: (t -> b) -> Array Int t -> [b] -amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] - where g (I# i#) = case indexArray# arr# i# of - (# e #) -> f e + infoTable <- peekItbl infoTablePtr + case tipe infoTable of + TSO -> pure $ UnsupportedClosure infoTable + STACK -> pure $ UnsupportedClosure infoTable + _ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList --- | This function returns a parsed heap representation of the argument _at --- this moment_, even if it is unevaluated or an indirection or other exotic --- stuff. Beware when passing something to this function, the same caveats as --- for 'asBox' apply. -getClosure :: a -> IO Closure -getClosure x = do - (iptr, wds, pts) <- getClosureRaw x - itbl <- peekItbl iptr - -- The remaining words after the header - let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds - -- For data args in a pointers then non-pointers closure - -- This is incorrect in non pointers-first setups - -- not sure if that happens - npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds + +-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this +-- function can be generated from a heap object using `unpackClosure#`. +getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b) +getClosureDataFromHeapRep heapRep infoTablePtr pts = do + itbl <- peekItbl infoTablePtr + getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts + +getClosureDataFromHeapRepPrim + :: IO (String, String, String) + -- ^ A continuation used to decode the constructor description field, + -- in ghc-debug this code can lead to segfaults because dataConNames + -- will dereference a random part of memory. + -> (Ptr a -> IO (Maybe CostCentreStack)) + -- ^ A continuation which is used to decode a cost centre stack + -- In ghc-debug, this code will need to call back into the debuggee to + -- fetch the representation of the CCS before decoding it. Using + -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as + -- the CCS argument will point outside the copied closure. + -> StgInfoTable + -- ^ The `StgInfoTable` of the closure, extracted from the heap + -- representation. + -> ByteArray# + -- ^ Heap representation of the closure as returned by `unpackClosure#`. + -- This includes all of the object including the header, info table + -- pointer, pointer data, and non-pointer data. The ByteArray# may be + -- pinned or unpinned. + -> [b] + -- ^ Pointers in the payload of the closure, extracted from the heap + -- representation as returned by `collect_pointers()` in `Heap.c`. The type + -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`. + -> IO (GenClosure b) + -- ^ Heap representation of the closure. +getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do + let -- heapRep as a list of words. + rawHeapWords :: [Word] + rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ] + where + nelems = (I# (sizeofByteArray# heapRep)) `div` wORD_SIZE + end = fromIntegral nelems - 1 + + -- Just the payload of rawHeapWords (no header). + payloadWords :: [Word] + payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords + + -- The non-pointer words in the payload. Only valid for closures with a + -- "pointers first" layout. Not valid for bit field layout. + npts :: [Word] + npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF -> do - (p, m, n) <- dataConNames iptr - if m == "GHC.ByteCode.Instr" && n == "BreakInfo" - then pure $ UnsupportedClosure itbl - else pure $ ConstrClosure itbl pts npts p m n + (p, m, n) <- getConDesc + pure $ ConstrClosure itbl pts npts p m n t | t >= THUNK && t <= THUNK_STATIC -> do pure $ ThunkClosure itbl pts npts @@ -164,9 +235,9 @@ unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to AP" -- We expect at least the arity, n_args, and fun fields - unless (length rawWds >= 2) $ + unless (length payloadWords >= 2) $ fail $ "Expected at least 2 raw words to AP" - let splitWord = rawWds !! 0 + let splitWord = payloadWords !! 0 pure $ APClosure itbl #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) @@ -181,9 +252,9 @@ unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to PAP" -- We expect at least the arity, n_args, and fun fields - unless (length rawWds >= 2) $ + unless (length payloadWords >= 2) $ fail "Expected at least 2 raw words to PAP" - let splitWord = rawWds !! 0 + let splitWord = payloadWords !! 0 pure $ PAPClosure itbl #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) @@ -218,10 +289,10 @@ unless (length pts >= 3) $ fail $ "Expected at least 3 ptr argument to BCO, found " ++ show (length pts) - unless (length rawWds >= 4) $ + unless (length payloadWords >= 4) $ fail $ "Expected at least 4 words to BCO, found " - ++ show (length rawWds) - let splitWord = rawWds !! 3 + ++ show (length payloadWords) + let splitWord = payloadWords !! 3 pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) @@ -230,27 +301,30 @@ (fromIntegral splitWord) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (drop 4 rawWds) + (drop 4 payloadWords) ARR_WORDS -> do - unless (length rawWds >= 1) $ + unless (length payloadWords >= 1) $ fail $ "Expected at least 1 words to ARR_WORDS, found " - ++ show (length rawWds) - pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds) + ++ show (length payloadWords) + pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords) t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length rawWds >= 2) $ + unless (length payloadWords >= 2) $ fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " - ++ "found " ++ show (length rawWds) - pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts + ++ "found " ++ show (length payloadWords) + pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length rawWds >= 1) $ + unless (length payloadWords >= 1) $ fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " - ++ "found " ++ show (length rawWds) - pure $ SmallMutArrClosure itbl (rawWds !! 0) pts + ++ "found " ++ show (length payloadWords) + pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts - t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> + t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do + unless (length pts >= 1) $ + fail $ "Expected at least 1 words to MUT_VAR, found " + ++ show (length pts) pure $ MutVarClosure itbl (head pts) t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do @@ -260,13 +334,12 @@ pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) BLOCKING_QUEUE -> - pure $ OtherClosure itbl pts wds + pure $ OtherClosure itbl pts rawHeapWords -- pure $ BlockingQueueClosure itbl -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) - -- pure $ OtherClosure itbl pts wds + -- pure $ OtherClosure itbl pts rawHeapWords -- - WEAK -> pure $ WeakClosure { info = itbl @@ -276,6 +349,45 @@ , 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 decodeCCS 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/GHC/Exts/Heap/Closures.hs b/GHC/Exts/Heap/Closures.hs --- a/GHC/Exts/Heap/Closures.hs +++ b/GHC/Exts/Heap/Closures.hs @@ -12,13 +12,11 @@ Closure , GenClosure(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , allClosures -#if __GLASGOW_HASKELL__ >= 809 - -- The closureSize# primop is unsupported on earlier GHC releases but we - -- build ghc-heap as a boot library so it must be buildable. Drop this once - -- we are guaranteed to bootstsrap with GHC >= 8.9. , closureSize -#endif -- * Boxes , Box(..) @@ -40,6 +38,8 @@ import GHC.Exts.Heap.InfoTableProf () #endif +import GHC.Exts.Heap.ProfInfo.Types + import Data.Bits import Data.Int import Data.Word @@ -100,11 +100,11 @@ -- | This is the representation of a Haskell value on the heap. It reflects -- -- --- 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 +268,39 @@ , 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 @@ -330,8 +363,45 @@ | PAddr | PFloat | PDouble - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) +data WhatNext + = ThreadRunGHC + | ThreadInterpret + | ThreadKilled + | ThreadComplete + | WhatNextUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + +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, Ord) + +data TsoFlags + = TsoLocked + | TsoBlockx + | TsoInterruptible + | TsoStoppedOnBreakpoint + | TsoMarked + | TsoSqueezed + | TsoAllocLimit + | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug + deriving (Eq, Show, Generic, Ord) + -- | For generic code, this function returns all referenced closures. allClosures :: GenClosure b -> [b] allClosures (ConstrClosure {..}) = ptrArgs @@ -355,11 +425,9 @@ allClosures (OtherClosure {..}) = hvalues allClosures _ = [] -#if __GLASGOW_HASKELL__ >= 809 -- | Get the size of the top-level closure in words. -- Includes header and payload. Does not follow pointers. -- -- @since 8.10.1 closureSize :: Box -> Int closureSize (Box x) = I# (closureSize# x) -#endif diff --git a/GHC/Exts/Heap/FFIClosures.hs b/GHC/Exts/Heap/FFIClosures.hs new file mode 100644 --- /dev/null +++ b/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/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc new file mode 100644 --- /dev/null +++ b/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 a -> IO (Maybe CostCentreStack)) -> Ptr tsoPtr -> IO TSOFields +peekTSOFields decodeCCS 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 decodeCCS 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/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc new file mode 100644 --- /dev/null +++ b/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 a -> IO (Maybe CostCentreStack)) -> Ptr tsoPtr -> IO TSOFields +peekTSOFields decodeCCS 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 decodeCCS 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/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs b/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs new file mode 100644 --- /dev/null +++ b/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/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc @@ -0,0 +1,16 @@ +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled( + peekStgTSOProfInfo + , peekTopCCS +) 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 a -> IO (Maybe CostCentreStack)) -> Ptr tsoPtr -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ _ = return Nothing + +peekTopCCS :: Ptr a -> IO (Maybe CostCentreStack) +peekTopCCS _ = return Nothing diff --git a/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc new file mode 100644 --- /dev/null +++ b/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc @@ -0,0 +1,173 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled( + peekStgTSOProfInfo + , peekTopCCS +) 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 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 = (#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 b -> IO (Maybe CostCentreStack)) -> Ptr a -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ _ = return Nothing + +peekTopCCS :: Ptr a -> IO (Maybe CostCentreStack) +peekTopCCS _ = return Nothing +#endif diff --git a/GHC/Exts/Heap/ProfInfo/Types.hs b/GHC/Exts/Heap/ProfInfo/Types.hs new file mode 100644 --- /dev/null +++ b/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 +-- +-- for more details on this data structure. +data StgTSOProfInfo = StgTSOProfInfo { + cccs :: Maybe CostCentreStack +} deriving (Show, Generic, Eq, Ord) + +-- | This is a somewhat faithful representation of CostCentreStack. See +-- +-- 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, Ord) + +-- | This is a somewhat faithful representation of CostCentre. See +-- +-- 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, Ord) + +-- | This is a somewhat faithful representation of IndexTable. See +-- +-- 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, Ord) diff --git a/GHC/Exts/Heap/Utils.hsc b/GHC/Exts/Heap/Utils.hsc --- a/GHC/Exts/Heap/Utils.hsc +++ b/GHC/Exts/Heap/Utils.hsc @@ -11,7 +11,7 @@ import GHC.Exts.Heap.InfoTable import Data.Char -import Data.List +import Data.List (intercalate) import Foreign import GHC.CString import GHC.Exts diff --git a/ghc-heap.cabal b/ghc-heap.cabal --- a/ghc-heap.cabal +++ b/ghc-heap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-heap -version: 9.0.1 +version: 9.2.1 license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org @@ -23,8 +23,9 @@ default-language: Haskell2010 build-depends: base >= 4.9.0 && < 5.0 - , ghc-prim > 0.2 && < 0.8 + , ghc-prim > 0.2 && < 0.9 , rts == 1.0.* + , containers >= 0.6.2.1 && < 0.7 ghc-options: -Wall cmm-sources: cbits/HeapPrim.cmm @@ -39,3 +40,10 @@ GHC.Exts.Heap.InfoTable.Types GHC.Exts.Heap.InfoTableProf GHC.Exts.Heap.Utils + GHC.Exts.Heap.FFIClosures + GHC.Exts.Heap.FFIClosures_ProfilingDisabled + GHC.Exts.Heap.FFIClosures_ProfilingEnabled + GHC.Exts.Heap.ProfInfo.Types + GHC.Exts.Heap.ProfInfo.PeekProfInfo + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled