ghc-heap: partial TSO/STACK decoding

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>

16 files changed, 998 insertions, 4 deletions

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