[Git][ghc/ghc][wip/ghc-debug] ghc-heap: expose decoding from heap representation and support partial TSO/STACK decoding
David Eichmann
gitlab at gitlab.haskell.org
Fri Oct 16 15:34:07 UTC 2020
David Eichmann pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
616060eb by David Eichmann at 2020-10-16T16:25:49+01:00
ghc-heap: expose decoding from heap representation and support partial TSO/STACK decoding
Co-authored-by: Sven Tennie <sven.tennie at gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
20 changed files:
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- + libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/create_tso.c
- + libraries/ghc-heap/tests/create_tso.h
- + libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
- + libraries/ghc-heap/tests/parse_tso_flags.hs
- + libraries/ghc-heap/tests/tso_and_stack_closures.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
Changes:
=====================================
libraries/ghc-heap/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,11 @@ module GHC.Exts.Heap (
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
+ , WhatNext(..)
+ , WhyBlocked(..)
+ , TsoFlags(..)
, HasHeapRep(getClosureData)
+ , getClosureDataFromHeapRep
-- * Info Table types
, StgInfoTable(..)
@@ -35,6 +42,12 @@ module GHC.Exts.Heap (
, peekItbl
, pokeItbl
+ -- * Cost Centre (profiling) types
+ , StgTSOProfInfo(..)
+ , IndexTable(..)
+ , CostCentre(..)
+ , CostCentreStack(..)
+
-- * Closure inspection
, getBoxedClosureData
, allClosures
@@ -49,16 +62,18 @@ 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
-import GHC.Arr
+import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
@@ -66,13 +81,19 @@ import GHC.Word
#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.
instance HasHeapRep (a :: TYPE 'LiftedRep) where
- getClosureData = getClosure
+ getClosureData = getClosureDataFromHeapObject
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
- getClosureData x = getClosure (unsafeCoerce# x)
+ getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x)
instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
getClosureData x = return $
@@ -102,49 +123,87 @@ instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
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)
-
--- 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
-
--- | 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
+#if MIN_VERSION_ghc_prim(0,5,3)
+ (# infoTableAddr, heapRep, pointersArray #) -> do
+#else
+ -- 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.
+ (# infoTableAddr, pointersArray, heapRep #) -> do
+#endif
+ let infoTablePtr = Ptr infoTableAddr
+ ptrList = [case indexArray# pointersArray i of
+ (# ptr #) -> Box ptr
+ | I# i <- [0..(I# (sizeofArray# pointersArray)) - 1]
+ ]
+
+ infoTable <- peekItbl infoTablePtr
+ case tipe infoTable of
+ TSO -> pure $ UnsupportedClosure infoTable
+ STACK -> pure $ UnsupportedClosure infoTable
+ _ -> getClosureDataFromHeapRep False heapRep infoTablePtr ptrList
+
+-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
+-- function can be generated from a heap object using `unpackClosure#`.
+getClosureDataFromHeapRep
+ :: Bool
+ -- ^ True to support decoding of stack pointers. If False and the closure is
+ -- a STACK, then `UnsupportedClosure` is returned.
+ -> 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.
+ -> Ptr StgInfoTable
+ -- ^ Pointer to the `StgInfoTable` of the closure, extracted from the heap
+ -- representation. The info table must not be movable by GC i.e. must be in
+ -- pinned or off-heap memory.
+ -> [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.
+getClosureDataFromHeapRep decodeStackClosures heapRep infoTablePtr pts = do
+ itbl <- peekItbl infoTablePtr
+ 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
+ (p, m, n) <- dataConNames infoTablePtr
if m == "GHC.ByteCode.Instr" && n == "BreakInfo"
then pure $ UnsupportedClosure itbl
else pure $ ConstrClosure itbl pts npts p m n
@@ -164,9 +223,9 @@ getClosure x = do
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 +240,9 @@ getClosure x = do
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 +277,10 @@ getClosure x = do
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 +289,30 @@ getClosure x = do
(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 +322,12 @@ getClosure x = do
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 +337,47 @@ getClosure x = 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
+ -> if decodeStackClosures
+ then 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
+ })
+ else pure $ UnsupportedClosure itbl
+ | otherwise
+ -> fail $ "Expected 0 ptr argument to STACK, found "
+ ++ show (length pts)
_ ->
pure $ UnsupportedClosure itbl
=====================================
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 at .
+ | 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__ >= 810
+ , 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
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Exts.Heap.FFIClosures (module Reexport) where
+
+#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
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
=====================================
@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
+
+-- Manually undefining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.FFIClosures_ProfilingEnabled.
+#undef PROFILING
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+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__ >= 810
+ (#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__ >= 810
+ 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__ >= 810
+ 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__ >= 810
+ stack_marking = marking',
+#endif
+ stack_sp = sp'
+ }
+
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
=====================================
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.FFIClosures_ProfilingEnabled where
+
+-- Manually defining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.FFIClosures_ProfilingDisabled.
+#define PROFILING
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+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__ >= 810
+ (#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__ >= 810
+ 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__ >= 810
+ 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__ >= 810
+ stack_marking = marking',
+#endif
+ stack_sp = sp'
+ }
=====================================
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
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
=====================================
@@ -0,0 +1,167 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled(
+ peekStgTSOProfInfo
+) where
+
+#if __GLASGOW_HASKELL__ >= 811
+
+-- Manually defining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled.
+#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
=====================================
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)
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -25,6 +25,7 @@ library
build-depends: base >= 4.9.0 && < 5.0
, ghc-prim > 0.2 && < 0.8
, rts == 1.0.*
+ , containers >= 0.6.2.1 && < 0.7
ghc-options: -Wall
cmm-sources: cbits/HeapPrim.cmm
@@ -39,3 +40,9 @@ library
GHC.Exts.Heap.InfoTable.Types
GHC.Exts.Heap.InfoTableProf
GHC.Exts.Heap.Utils
+ GHC.Exts.Heap.FFIClosures
+ GHC.Exts.Heap.FFIClosures_ProfilingEnabled
+ GHC.Exts.Heap.FFIClosures_ProfilingDisabled
+ GHC.Exts.Heap.ProfInfo.Types
+ GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+ GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash #-}
+module TestUtils where
+
+import Foreign (Ptr)
+import GHC.Exts (Addr#)
+import GHC.Ptr (Ptr(Ptr))
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+ | a /= b = error (show a ++ " /= " ++ show b)
+ | otherwise = return ()
+
+unpackAddr# :: Ptr () -> Addr#
+unpackAddr# (Ptr addr) = addr
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -36,3 +36,26 @@ test('closure_size_noopt',
],
compile_and_run, [''])
+test('tso_and_stack_closures',
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+ only_ways(['profthreaded']),
+ extra_ways(['profthreaded']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+
+test('list_threads_and_misc_roots',
+ [extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h','TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '-threaded'])
+
+test('parse_tso_flags',
+ [extra_files(['TestUtils.hs']),
+ only_ways(['normal']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run, [''])
=====================================
libraries/ghc-heap/tests/create_tso.c
=====================================
@@ -0,0 +1,80 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+// Must be called from a safe FFI call.
+void create_and_unpack_tso_and_stack
+ // TSO
+ ( StgTSO ** outTso
+ , StgInfoTable ** outTsoInfoTablePtr
+ , int * outTsoHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outTsoHeapRep // Array of words
+ , int * outTsoPointersSize // Size of outPointers (in words)
+ , StgClosure *** outTsoPointers // Array of all pointers of the TSO
+ // Stack
+ , StgTSO ** outStack
+ , StgInfoTable ** outStackInfoTablePtr
+ , int * outStackHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outStackHeapRep // Array of words
+ , int * outStackPointersSize // Size of outPointers (in words)
+ , StgClosure *** outStackPointers // Array of all pointers of the TSO
+ )
+{
+ // Pause RTS
+ Capability * cap = rts_pause();
+
+ // Create TSO/Stack
+ HaskellObj trueClosure = rts_mkBool(cap, 1);
+ *outTso = createGenThread(cap, 500U, trueClosure);
+
+ // Unpack TSO
+ unpack_closure(
+ (StgClosure*)(*outTso),
+ outTsoInfoTablePtr,
+ outTsoHeapRepSize,
+ outTsoHeapRep,
+ outTsoPointersSize,
+ outTsoPointers);
+
+ // Unpack STACK
+ *outStack = (*outTsoPointers)[2];
+ unpack_closure(
+ (StgClosure*)(*outStack),
+ outStackInfoTablePtr,
+ outStackHeapRepSize,
+ outStackHeapRep,
+ outStackPointersSize,
+ outStackPointers);
+
+ // Resume RTS
+ rts_resume(cap);
+}
+
+// Assumed the rts is paused
+void unpack_closure
+ ( StgClosure * inClosure
+ , StgInfoTable ** outInfoTablePtr
+ , int * outHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outHeapRep // Array of words
+ , int * outPointersSize // Size of outPointers (in words)
+ , StgClosure *** outPointers // Array of all pointers of the TSO
+ )
+{
+ *outInfoTablePtr = get_itbl(inClosure);
+
+ // Copy TSO pointers.
+ StgWord closureSizeW = heap_view_closureSize(inClosure);
+ int closureSizeB = sizeof(StgWord) * closureSizeW;
+ StgClosure ** pointers = malloc(closureSizeB);
+ *outPointersSize = collect_pointers(inClosure, closureSizeW, pointers);
+ *outPointers = pointers;
+
+ // Copy the heap rep.
+ StgWord * heapRep = malloc(closureSizeB);
+ for (int i = 0; i < closureSizeW; i++)
+ {
+ heapRep[i] = ((StgWord*)inClosure)[i];
+ }
+
+ *outHeapRepSize = closureSizeB;
+ *outHeapRep = heapRep;
+}
=====================================
libraries/ghc-heap/tests/create_tso.h
=====================================
@@ -0,0 +1,19 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+void create_and_unpack_tso_and_stack
+ // TSO
+ ( StgTSO ** outTso
+ , StgInfoTable ** outTsoInfoTablePtr
+ , int * outTsoHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outTsoHeapRep // Array of words
+ , int * outTsoPointersSize // Size of outPointers (in words)
+ , StgClosure *** outTsoPointers // Array of all pointers of the TSO
+ // Stack
+ , StgTSO ** outStack
+ , StgInfoTable ** outStackInfoTablePtr
+ , int * outStackHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outStackHeapRep // Array of words
+ , int * outStackPointersSize // Size of outPointers (in words)
+ , StgClosure *** outStackPointers // Array of all pointers of the TSO
+ );
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -0,0 +1,6 @@
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h check_tso_and_misc_roots"
+ check_tso_and_misc_roots :: IO ()
+
+main :: IO ()
+main = check_tso_and_misc_roots
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
=====================================
@@ -0,0 +1,52 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "list_threads_and_misc_roots_c.h"
+
+static int tsoCount = 0;
+static StgTSO** tsos;
+
+static int miscRootsCount = 0;
+static StgClosure** miscRoots;
+
+void collectTSOsCallback(void *user, StgTSO* tso){
+ tsoCount++;
+ tsos = realloc(tsos, sizeof(StgTSO*) * tsoCount);
+ tsos[tsoCount - 1] = tso;
+}
+
+void collectMiscRootsCallback(void *user, StgClosure* closure){
+ miscRootsCount++;
+ miscRoots = realloc(miscRoots, sizeof(StgClosure*) * miscRootsCount);
+ miscRoots[miscRootsCount - 1] = closure;
+}
+
+void check_tso_and_misc_roots(void) {
+ Capability * cap = rts_pause();
+ rts_listThreads(&collectTSOsCallback, NULL);
+ rts_listMiscRoots(&collectMiscRootsCallback, NULL);
+
+ for (int i = 0; i < tsoCount; i++)
+ {
+ StgTSO *tso = UNTAG_CLOSURE(tsos[i]);
+ if (get_itbl(tso)->type != TSO)
+ {
+ printf("tso returned a non-TSO type %zu at index %i\n",
+ tso->header.info->type,
+ i);
+ exit(1);
+ }
+ }
+
+ for (int i = 0; i < miscRootsCount; i++)
+ {
+ StgClosure *root = UNTAG_CLOSURE(miscRoots[i]);
+ printf("get_itbl(root) = %p\n", get_itbl(root)); fflush(stdout);
+ if (get_itbl(root)->type == TSO)
+ {
+ printf("rts_listThreads returned a TSO type at index %i (TSO=%zu)\n", i, TSO); fflush(stdout);
+ exit(1);
+ }
+ }
+
+ rts_resume(cap);
+}
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
=====================================
@@ -0,0 +1,4 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+void check_tso_and_misc_roots(void);
=====================================
libraries/ghc-heap/tests/parse_tso_flags.hs
=====================================
@@ -0,0 +1,17 @@
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.FFIClosures
+import TestUtils
+
+main :: IO()
+main = do
+ assertEqual (parseTsoFlags 0) []
+ assertEqual (parseTsoFlags 1) [TsoFlagsUnknownValue 1]
+ assertEqual (parseTsoFlags 2) [TsoLocked]
+ assertEqual (parseTsoFlags 4) [TsoBlockx]
+ assertEqual (parseTsoFlags 8) [TsoInterruptible]
+ assertEqual (parseTsoFlags 16) [TsoStoppedOnBreakpoint]
+ assertEqual (parseTsoFlags 64) [TsoMarked]
+ assertEqual (parseTsoFlags 128) [TsoSqueezed]
+ assertEqual (parseTsoFlags 256) [TsoAllocLimit]
+
+ assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx]
=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -0,0 +1,168 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Monad (forM_, unless)
+import Data.List (find)
+import Data.Word
+import Foreign
+import Foreign.C.Types
+import GHC.IO ( IO(..) )
+import GHC.Exts
+import GHC.Exts.Heap
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
+import GHC.Word
+
+import TestUtils
+
+main :: IO ()
+main = do
+ (tso, stack) <- {-# SCC "MyCostCentre" #-} createAndUnpackTSOAndSTACKClosure
+ assertEqual (getClosureType tso) TSO
+ assertEqual (what_next tso) ThreadRunGHC
+ assertEqual (why_blocked tso) NotBlocked
+ assertEqual (saved_errno tso) 0
+ forM_ (flags tso) $ \flag -> case flag of
+ TsoFlagsUnknownValue _ -> error $ "Unknown flag: " ++ show flag
+ _ | flag `elem`
+ [ TsoLocked
+ , TsoBlockx
+ , TsoStoppedOnBreakpoint
+ , TsoSqueezed
+ ] -> error $ "Unexpected flag: " ++ show flag
+ _ -> return ()
+
+ assertEqual (getClosureType stack) STACK
+
+#if defined(PROFILING)
+ let costCentre = ccs_cc <$> (cccs =<< prof tso)
+ case costCentre of
+ Nothing -> error $ "No CostCentre found in TSO: " ++ show tso
+ Just _ -> case findMyCostCentre (linkedCostCentres costCentre) of
+ Just myCostCentre -> do
+ assertEqual (cc_label myCostCentre) "MyCostCentre"
+ assertEqual (cc_module myCostCentre) "Main"
+ assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:23:48-80")
+ assertEqual (cc_is_caf myCostCentre) False
+ Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre)
+#endif
+
+linkedCostCentres :: Maybe CostCentre -> [CostCentre]
+linkedCostCentres Nothing = []
+linkedCostCentres (Just cc) = cc : linkedCostCentres (cc_link cc)
+
+findMyCostCentre:: [CostCentre] -> Maybe CostCentre
+findMyCostCentre ccs = find (\cc -> cc_label cc == "MyCostCentre") ccs
+
+getClosureType :: GenClosure b -> ClosureType
+getClosureType = tipe . info
+
+type StgTso = Any
+type StgStack = Any
+data MBA a = MBA (MutableByteArray# a)
+data BA = BA ByteArray#
+
+foreign import ccall safe "create_tso.h create_and_unpack_tso_and_stack"
+ c_create_and_unpack_tso_and_stack
+ :: Ptr (Ptr StgTso)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> Ptr (Ptr StgStack)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> IO ()
+
+createAndUnpackTSOAndSTACKClosure
+ :: IO ( GenClosure (Ptr Any)
+ , GenClosure (Ptr Any)
+ )
+createAndUnpackTSOAndSTACKClosure = do
+
+ alloca $ \ptrPtrTso -> do
+ alloca $ \ptrPtrTsoInfoTable -> do
+ alloca $ \ptrTsoHeapRepSize -> do
+ alloca $ \ptrPtrTsoHeapRep -> do
+ alloca $ \ptrTsoPointersSize -> do
+ alloca $ \ptrPtrPtrTsoPointers -> do
+
+ alloca $ \ptrPtrStack -> do
+ alloca $ \ptrPtrStackInfoTable -> do
+ alloca $ \ptrStackHeapRepSize -> do
+ alloca $ \ptrPtrStackHeapRep -> do
+ alloca $ \ptrStackPointersSize -> do
+ alloca $ \ptrPtrPtrStackPointers -> do
+
+ c_create_and_unpack_tso_and_stack
+
+ ptrPtrTso
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ ptrPtrStack
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ let fromHeapRep
+ ptrPtrClosureInfoTable
+ ptrClosureHeapRepSize
+ ptrPtrClosureHeapRep
+ ptrClosurePointersSize
+ ptrPtrPtrClosurePointers = do
+ ptrInfoTable :: Ptr StgInfoTable <- peek ptrPtrClosureInfoTable
+
+ heapRepSize :: Int <- fromIntegral <$> peek ptrClosureHeapRepSize
+ let I# heapRepSize# = heapRepSize
+ ptrHeapRep :: Ptr Word8 <- peek ptrPtrClosureHeapRep
+ MBA mutHeapRepBA <- IO $ \s -> let
+ (# s', mba# #) = newByteArray# heapRepSize# s
+ in (# s', MBA mba# #)
+ forM_ [0..heapRepSize-1] $ \i@(I# i#) -> do
+ W8# w <- peekElemOff ptrHeapRep i
+ IO (\s -> (# writeWord8Array# mutHeapRepBA i# w s, () #))
+ BA heapRep <- IO $ \s -> let
+ (# s', ba# #) = unsafeFreezeByteArray# mutHeapRepBA s
+ in (# s', BA ba# #)
+
+ pointersSize :: Int <- fromIntegral <$> peek ptrClosurePointersSize
+ ptrPtrPointers :: Ptr (Ptr Any) <- peek ptrPtrPtrClosurePointers
+ ptrPtrPointers :: [Ptr Any] <- sequence
+ [ peekElemOff ptrPtrPointers i
+ | i <- [0..pointersSize-1]
+ ]
+
+ getClosureDataFromHeapRep
+ True
+ heapRep
+ ptrInfoTable
+ ptrPtrPointers
+
+ tso <- fromHeapRep
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ stack <- fromHeapRep
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ return (tso, stack)
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
- GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-}
+ GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
+ CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
-- |
@@ -29,7 +30,7 @@ import GHCi.TH.Binary () -- For Binary instances
import GHCi.BreakArray
import GHC.LanguageExtensions
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
import GHC.ForeignSrcLang
import GHC.Fingerprint
import Control.Concurrent
@@ -110,7 +111,7 @@ data Message a where
-> Int -- constr tag
-> Int -- pointer tag
-> ByteString -- constructor desccription
- -> Message (RemotePtr StgInfoTable)
+ -> Message (RemotePtr Heap.StgInfoTable)
-- | Evaluate a statement
EvalStmt
@@ -211,7 +212,7 @@ data Message a where
-- type reconstruction.
GetClosure
:: HValueRef
- -> Message (GenClosure HValueRef)
+ -> Message (Heap.GenClosure HValueRef)
-- | Evaluate something. This is used to support :force in GHCi.
Seq
@@ -449,10 +450,20 @@ instance Binary (FunPtr a) where
get = castPtrToFunPtr <$> get
-- Binary instances to support the GetClosure message
-instance Binary StgInfoTable
-instance Binary ClosureType
-instance Binary PrimType
-instance Binary a => Binary (GenClosure a)
+#if MIN_VERSION_ghc_heap(8,11,0)
+instance Binary Heap.StgTSOProfInfo
+instance Binary Heap.CostCentreStack
+instance Binary Heap.CostCentre
+instance Binary Heap.IndexTable
+instance Binary Heap.WhatNext
+instance Binary Heap.WhyBlocked
+instance Binary Heap.TsoFlags
+#endif
+
+instance Binary Heap.StgInfoTable
+instance Binary Heap.ClosureType
+instance Binary Heap.PrimType
+instance Binary a => Binary (Heap.GenClosure a)
data Msg = forall a . (Binary a, Show a) => Msg (Message a)
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -32,7 +32,7 @@ import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
import GHC.Stack
import Foreign hiding (void)
import Foreign.C
@@ -93,8 +93,8 @@ run m = case m of
toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
StartTH -> startTH
GetClosure ref -> do
- clos <- getClosureData =<< localRef ref
- mapM (\(Box x) -> mkRemoteRef (HValue x)) clos
+ clos <- Heap.getClosureData =<< localRef ref
+ mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
Seq ref -> doSeq ref
ResumeSeq ref -> resumeSeq ref
_other -> error "GHCi.Run.run"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/616060eb6f35a9de4aaf4ab43ba41fa661e3ab27
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/616060eb6f35a9de4aaf4ab43ba41fa661e3ab27
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201016/0a5b5f3c/attachment-0001.html>
More information about the ghc-commits
mailing list