ghc-heap: expose decoding from heap representation and support partial TSO/STACK decodingwip/ghc-debug

Co-authored-by: Sven Tennie <sven.tennie@gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>
Co-authored-by: Ben Gamari <bgamari.foss@gmail.com>

20 files changed, 1169 insertions, 80 deletions

diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index c1f2376729..b11ade6246 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 8a959fc2a0..d264b382ce 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -12,6 +12,9 @@ module GHC.Exts.Heap.Closures (
       Closure
     , GenClosure(..)
     , PrimType(..)
+    , WhatNext(..)
+    , WhyBlocked(..)
+    , TsoFlags(..)
     , allClosures
 #if __GLASGOW_HASKELL__ >= 809
     -- The closureSize# primop is unsupported on earlier GHC releases but we
@@ -40,6 +43,8 @@ import GHC.Exts.Heap.InfoTable
 import GHC.Exts.Heap.InfoTableProf ()
 #endif
 
+import GHC.Exts.Heap.ProfInfo.Types
+
 import Data.Bits
 import Data.Int
 import Data.Word
@@ -100,11 +105,11 @@ type Closure = GenClosure Box
 -- | This is the representation of a Haskell value on the heap. It reflects
 -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h>
 --
--- The data type is parametrized by the type to store references in. Usually
--- this is a 'Box' with the type synonym 'Closure'.
+-- The data type is parametrized by `b`: the type to store references in.
+-- Usually this is a 'Box' with the type synonym 'Closure'.
 --
--- All Heap objects have the same basic layout. A header containing a pointer
--- to the info table and a payload with various fields. The @info@ field below
+-- All Heap objects have the same basic layout. A header containing a pointer to
+-- the info table and a payload with various fields. The @info@ field below
 -- always refers to the info table pointed to by the header. The remaining
 -- fields are the payload.
 --
@@ -268,6 +273,39 @@ data GenClosure b
         , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
         }
 
+  -- | Representation of StgTSO: A Thread State Object. The values for
+  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.
+  | TSOClosure
+      { info                :: !StgInfoTable
+      -- pointers
+      , link                :: !b
+      , global_link         :: !b
+      , tsoStack            :: !b -- ^ stackobj from StgTSO
+      , trec                :: !b
+      , blocked_exceptions  :: !b
+      , bq                  :: !b
+      -- values
+      , what_next           :: !WhatNext
+      , why_blocked         :: !WhyBlocked
+      , flags               :: ![TsoFlags]
+      , threadId            :: !Word64
+      , saved_errno         :: !Word32
+      , tso_dirty           :: !Word32 -- ^ non-zero => dirty
+      , alloc_limit         :: !Int64
+      , tot_stack_size      :: !Word32
+      , prof                :: !(Maybe StgTSOProfInfo)
+      }
+
+  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.
+  | StackClosure
+      { info            :: !StgInfoTable
+      , stack_size      :: !Word32 -- ^ stack size in *words*
+      , stack_dirty     :: !Word8 -- ^ non-zero => dirty
+#if __GLASGOW_HASKELL__ >= 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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs
new file mode 100644
index 0000000000..9765da0e5a
--- /dev/null
+++ b/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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
new file mode 100644
index 0000000000..57fcd3796e
--- /dev/null
+++ b/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'
+    }
+
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
new file mode 100644
index 0000000000..6a7b6444f3
--- /dev/null
+++ b/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'
+    }
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
new file mode 100644
index 0000000000..0f574b4f03
--- /dev/null
+++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
@@ -0,0 +1,12 @@
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled(
+    peekStgTSOProfInfo
+) where
+
+import Prelude
+import Foreign
+import GHC.Exts.Heap.ProfInfo.Types
+
+-- | This implementation is used when PROFILING is undefined.
+-- It always returns 'Nothing', because there is no profiling info available.
+peekStgTSOProfInfo :: Ptr tsoPtr -> IO (Maybe StgTSOProfInfo)
+peekStgTSOProfInfo _ = return Nothing
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
new file mode 100644
index 0000000000..e839db061e
--- /dev/null
+++ b/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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
new file mode 100644
index 0000000000..b6915b374d
--- /dev/null
+++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module GHC.Exts.Heap.ProfInfo.Types where
+
+import Prelude
+import Data.Word
+import GHC.Generics
+
+-- | This is a somewhat faithful representation of StgTSOProfInfo. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/TSO.h>
+-- for more details on this data structure.
+data StgTSOProfInfo = StgTSOProfInfo {
+    cccs :: Maybe CostCentreStack
+} deriving (Show, Generic)
+
+-- | This is a somewhat faithful representation of CostCentreStack. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>
+-- for more details on this data structure.
+data CostCentreStack = CostCentreStack {
+    ccs_ccsID :: Int,
+    ccs_cc :: CostCentre,
+    ccs_prevStack :: Maybe CostCentreStack,
+    ccs_indexTable :: Maybe IndexTable,
+    ccs_root :: Maybe CostCentreStack,
+    ccs_depth :: Word,
+    ccs_scc_count :: Word64,
+    ccs_selected :: Word,
+    ccs_time_ticks :: Word,
+    ccs_mem_alloc :: Word64,
+    ccs_inherited_alloc :: Word64,
+    ccs_inherited_ticks :: Word
+} deriving (Show, Generic, Eq)
+
+-- | This is a somewhat faithful representation of CostCentre. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>
+-- for more details on this data structure.
+data CostCentre = CostCentre {
+    cc_ccID :: Int,
+    cc_label :: String,
+    cc_module :: String,
+    cc_srcloc :: Maybe String,
+    cc_mem_alloc :: Word64,
+    cc_time_ticks :: Word,
+    cc_is_caf :: Bool,
+    cc_link :: Maybe CostCentre
+} deriving (Show, Generic, Eq)
+
+-- | This is a somewhat faithful representation of IndexTable. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h>
+-- for more details on this data structure.
+data IndexTable = IndexTable {
+    it_cc :: CostCentre,
+    it_ccs :: Maybe CostCentreStack,
+    it_next :: Maybe IndexTable,
+    it_back_edge :: Bool
+} deriving (Show, Generic, Eq)
diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in
index a80d9f7ad3..c6f780a053 100644
--- a/libraries/ghc-heap/ghc-heap.cabal.in
+++ b/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
diff --git a/libraries/ghc-heap/tests/TestUtils.hs b/libraries/ghc-heap/tests/TestUtils.hs
new file mode 100644
index 0000000000..702532f645
--- /dev/null
+++ b/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
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index 89e6f47ecb..1531fcffa8 100644
--- a/libraries/ghc-heap/tests/all.T
+++ b/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, [''])
diff --git a/libraries/ghc-heap/tests/create_tso.c b/libraries/ghc-heap/tests/create_tso.c
new file mode 100644
index 0000000000..083c6e4874
--- /dev/null
+++ b/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;
+}
diff --git a/libraries/ghc-heap/tests/create_tso.h b/libraries/ghc-heap/tests/create_tso.h
new file mode 100644
index 0000000000..40e4e59d9f
--- /dev/null
+++ b/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
+    );
diff --git a/libraries/ghc-heap/tests/list_threads_and_misc_roots.hs b/libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
new file mode 100644
index 0000000000..ae687327c7
--- /dev/null
+++ b/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
diff --git a/libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c b/libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
new file mode 100644
index 0000000000..b93af32b7e
--- /dev/null
+++ b/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);
+}
diff --git a/libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h b/libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
new file mode 100644
index 0000000000..8a5ede76b9
--- /dev/null
+++ b/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);
diff --git a/libraries/ghc-heap/tests/parse_tso_flags.hs b/libraries/ghc-heap/tests/parse_tso_flags.hs
new file mode 100644
index 0000000000..51802a32be
--- /dev/null
+++ b/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]
diff --git a/libraries/ghc-heap/tests/tso_and_stack_closures.hs b/libraries/ghc-heap/tests/tso_and_stack_closures.hs
new file mode 100644
index 0000000000..4066cb3341
--- /dev/null
+++ b/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)
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index ad94776a9f..d21686a326 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/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)
 
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 0a99845966..858c312b34 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/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"