    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE PolyKinds #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE UnboxedTuples #-}

    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE TypeInType #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE ExplicitForAll #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE UnliftedFFITypes #-}

    {-|
    Module      :  GHC.Exts.Heap
    Copyright   :  (c) 2012 Joachim Breitner
    License     :  BSD3
    Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>

    With this module, you can investigate the heap representation of Haskell
    values, i.e. to investigate sharing and lazy evaluation.
    -}

    module GHC.Exts.Heap (
        -- * Closure types
          Closure
        , GenClosure(..)
        , ClosureType(..)
        , PrimType(..)
        , WhatNext(..)
        , WhyBlocked(..)
        , TsoFlags(..)
        , HasHeapRep(getClosureData)
        , getClosureDataFromHeapRep
        , getClosureDataFromHeapRepPrim

        -- * Info Table types
        , StgInfoTable(..)
        , EntryFunPtr
        , HalfWord
        , ItblCodes
        , itblSize
        , peekItbl
        , pokeItbl

        -- * Cost Centre (profiling) types
        , StgTSOProfInfo(..)
        , IndexTable(..)
        , CostCentre(..)
        , CostCentreStack(..)

         -- * Closure inspection
        , getBoxedClosureData
        , allClosures

        -- * Boxes
        , Box(..)
        , asBox
        , areBoxesEqual
        ) where

    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 qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI

    import Control.Monad
    import Data.Bits
    import Foreign
    import GHC.Exts
    import GHC.Int
    import GHC.Word

    #include "ghcconfig.h"

    class HasHeapRep (a :: TYPE rep) where

        -- | Decode a closure to it's heap representation ('GenClosure').
        getClosureData
            :: a
            -- ^ Closure to decode.
            -> IO Closure
            -- ^ Heap representation of the closure.

    #if __GLASGOW_HASKELL__ >= 901
    instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where
    #else
    instance HasHeapRep (a :: TYPE 'LiftedRep) where
    #endif
        getClosureData :: a -> IO Closure
    getClosureData = forall a. a -> IO Closure
    getClosureDataFromHeapObject

    #if __GLASGOW_HASKELL__ >= 901
    instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where
    #else
    instance HasHeapRep (a :: TYPE 'UnliftedRep) where
    #endif
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall a. a -> IO Closure
    getClosureDataFromHeapObject (unsafeCoerce# :: forall a b. a -> b
    unsafeCoerce# a
    x)

    instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            IntClosure { ptipe :: PrimType
    ptipe = PrimType
    PInt, intVal :: Int
    intVal = Int# -> Int
    I# a
    x }

    instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            WordClosure { ptipe :: PrimType
    ptipe = PrimType
    PWord, wordVal :: Word
    wordVal = Word# -> Word
    W# a
    x }

    instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            Int64Closure { ptipe :: PrimType
    ptipe = PrimType
    PInt64, int64Val :: Int64
    int64Val = Int# -> Int64
    I64# (unsafeCoerce# :: forall a b. a -> b
    unsafeCoerce# a
    x) }

    instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            Word64Closure { ptipe :: PrimType
    ptipe = PrimType
    PWord64, word64Val :: Word64
    word64Val = Word# -> Word64
    W64# (unsafeCoerce# :: forall a b. a -> b
    unsafeCoerce# a
    x) }

    instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            AddrClosure { ptipe :: PrimType
    ptipe = PrimType
    PAddr, addrVal :: Int
    addrVal = Int# -> Int
    I# (unsafeCoerce# :: forall a b. a -> b
    unsafeCoerce# a
    x) }

    instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            FloatClosure { ptipe :: PrimType
    ptipe = PrimType
    PFloat, floatVal :: Float
    floatVal = Float# -> Float
    F# a
    x }

    instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $
            DoubleClosure { ptipe :: PrimType
    ptipe = PrimType
    PDouble, doubleVal :: Double
    doubleVal = Double# -> Double
    D# a
    x }

    -- | 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 :: forall a. a -> IO Closure
    getClosureDataFromHeapObject a
    x = do
        case forall a b. a -> (# Addr#, ByteArray#, Array# b #)
    unpackClosure# a
    x of
            (# Addr#
    infoTableAddr, ByteArray#
    heapRep, Array# Any
    pointersArray #) -> do
                let infoTablePtr :: Ptr StgInfoTable
    infoTablePtr = forall a. Addr# -> Ptr a
    Ptr Addr#
    infoTableAddr
                    ptrList :: [Box]
    ptrList = [case forall a. Array# a -> Int# -> (# a #)
    indexArray# Array# Any
    pointersArray Int#
    i of
                                    (# Any
    ptr #) -> Any -> Box
    Box Any
    ptr
                                | I# Int#
    i <- [Int
    0..(Int# -> Int
    I# (forall a. Array# a -> Int#
    sizeofArray# Array# Any
    pointersArray)) forall a. Num a => a -> a -> a
    - Int
    1]
                                ]

                StgInfoTable
    infoTable <- Ptr StgInfoTable -> IO StgInfoTable
    peekItbl Ptr StgInfoTable
    infoTablePtr
                case StgInfoTable -> ClosureType
    tipe StgInfoTable
    infoTable of
                    ClosureType
    TSO   -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> GenClosure b
    UnsupportedClosure StgInfoTable
    infoTable
                    ClosureType
    STACK -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> GenClosure b
    UnsupportedClosure StgInfoTable
    infoTable
                    ClosureType
    _ -> forall b.
    ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
    getClosureDataFromHeapRep ByteArray#
    heapRep Ptr StgInfoTable
    infoTablePtr [Box]
    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 :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
    getClosureDataFromHeapRep :: forall b.
    ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
    getClosureDataFromHeapRep ByteArray#
    heapRep Ptr StgInfoTable
    infoTablePtr [b]
    pts = do
      StgInfoTable
    itbl <- Ptr StgInfoTable -> IO StgInfoTable
    peekItbl Ptr StgInfoTable
    infoTablePtr
      forall a b.
    IO (String, String, String)
    -> (Ptr a -> IO (Maybe CostCentreStack))
    -> StgInfoTable
    -> ByteArray#
    -> [b]
    -> IO (GenClosure b)
    getClosureDataFromHeapRepPrim (Ptr StgInfoTable -> IO (String, String, String)
    dataConNames Ptr StgInfoTable
    infoTablePtr) forall a. Ptr a -> IO (Maybe CostCentreStack)
    PPI.peekTopCCS StgInfoTable
    itbl ByteArray#
    heapRep [b]
    pts

    getClosureDataFromHeapRepPrim
        :: IO (String, String, String)
        -- ^ A continuation used to decode the constructor description field,
        -- in ghc-debug this code can lead to segfaults because dataConNames
        -- will dereference a random part of memory.
        -> (Ptr a -> IO (Maybe CostCentreStack))
        -- ^ A continuation which is used to decode a cost centre stack
        -- In ghc-debug, this code will need to call back into the debuggee to
        -- fetch the representation of the CCS before decoding it. Using
        -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as
        -- the CCS argument will point outside the copied closure.
        -> StgInfoTable
        -- ^ The `StgInfoTable` of the closure, extracted from the heap
        -- representation.
        -> ByteArray#
        -- ^ Heap representation of the closure as returned by `unpackClosure#`.
        -- This includes all of the object including the header, info table
        -- pointer, pointer data, and non-pointer data. The ByteArray# may be
        -- pinned or unpinned.
        -> [b]
        -- ^ Pointers in the payload of the closure, extracted from the heap
        -- representation as returned by `collect_pointers()` in `Heap.c`. The type
        -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
        -> IO (GenClosure b)
        -- ^ Heap representation of the closure.
    getClosureDataFromHeapRepPrim :: forall a b.
    IO (String, String, String)
    -> (Ptr a -> IO (Maybe CostCentreStack))
    -> StgInfoTable
    -> ByteArray#
    -> [b]
    -> IO (GenClosure b)
    getClosureDataFromHeapRepPrim IO (String, String, String)
    getConDesc Ptr a -> IO (Maybe CostCentreStack)
    decodeCCS StgInfoTable
    itbl ByteArray#
    heapRep [b]
    pts = do
        let -- heapRep as a list of words.
            rawHeapWords :: [Word]
            rawHeapWords :: [Word]
    rawHeapWords = [Word# -> Word
    W# (ByteArray# -> Int# -> Word#
    indexWordArray# ByteArray#
    heapRep Int#
    i) | I# Int#
    i <- [Int
    0.. Int
    end] ]
                where
                nelems :: Int
    nelems = (Int# -> Int
    I# (ByteArray# -> Int#
    sizeofByteArray# ByteArray#
    heapRep)) forall a. Integral a => a -> a -> a
    `div` Int
    wORD_SIZE
                end :: Int
    end = forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    nelems forall a. Num a => a -> a -> a
    - Int
    1

            -- Just the payload of rawHeapWords (no header).
            payloadWords :: [Word]
            payloadWords :: [Word]
    payloadWords = forall a. Int -> [a] -> [a]
    drop (ClosureType -> Int
    closureTypeHeaderSize (StgInfoTable -> ClosureType
    tipe StgInfoTable
    itbl)) [Word]
    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 :: [Word]
    npts = forall a. Int -> [a] -> [a]
    drop (ClosureType -> Int
    closureTypeHeaderSize (StgInfoTable -> ClosureType
    tipe StgInfoTable
    itbl) forall a. Num a => a -> a -> a
    + forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts) [Word]
    rawHeapWords
        case StgInfoTable -> ClosureType
    tipe StgInfoTable
    itbl of
            ClosureType
    t | ClosureType
    t forall a. Ord a => a -> a -> Bool
    >= ClosureType
    CONSTR Bool -> Bool -> Bool
    && ClosureType
    t forall a. Ord a => a -> a -> Bool
    <= ClosureType
    CONSTR_NOCAF -> do
                (String
    p, String
    m, String
    n) <- IO (String, String, String)
    getConDesc
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b.
    StgInfoTable
    -> [b] -> [Word] -> String -> String -> String -> GenClosure b
    ConstrClosure StgInfoTable
    itbl [b]
    pts [Word]
    npts String
    p String
    m String
    n

            ClosureType
    t | ClosureType
    t forall a. Ord a => a -> a -> Bool
    >= ClosureType
    THUNK Bool -> Bool -> Bool
    && ClosureType
    t forall a. Ord a => a -> a -> Bool
    <= ClosureType
    THUNK_STATIC -> do
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
    ThunkClosure StgInfoTable
    itbl [b]
    pts [Word]
    npts

            ClosureType
    THUNK_SELECTOR -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to THUNK_SELECTOR"
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> GenClosure b
    SelectorClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts)

            ClosureType
    t | ClosureType
    t forall a. Ord a => a -> a -> Bool
    >= ClosureType
    FUN Bool -> Bool -> Bool
    && ClosureType
    t forall a. Ord a => a -> a -> Bool
    <= ClosureType
    FUN_STATIC -> do
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
    FunClosure StgInfoTable
    itbl [b]
    pts [Word]
    npts

            ClosureType
    AP -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to AP"
                -- We expect at least the arity, n_args, and fun fields
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    2) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 2 raw words to AP"
                let splitWord :: Word
    splitWord = [Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    0
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b.
    StgInfoTable -> HalfWord -> HalfWord -> b -> [b] -> GenClosure b
    APClosure StgInfoTable
    itbl
    #if defined(WORDS_BIGENDIAN)
                    (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                    (fromIntegral splitWord)
    #else
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall a b. (a -> b) -> a -> b
    $ forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                    (forall a. [a] -> a
    head [b]
    pts) (forall a. [a] -> [a]
    tail [b]
    pts)

            ClosureType
    PAP -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to PAP"
                -- We expect at least the arity, n_args, and fun fields
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    2) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 2 raw words to PAP"
                let splitWord :: Word
    splitWord = [Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    0
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b.
    StgInfoTable -> HalfWord -> HalfWord -> b -> [b] -> GenClosure b
    PAPClosure StgInfoTable
    itbl
    #if defined(WORDS_BIGENDIAN)
                    (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                    (fromIntegral splitWord)
    #else
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall a b. (a -> b) -> a -> b
    $ forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                    (forall a. [a] -> a
    head [b]
    pts) (forall a. [a] -> [a]
    tail [b]
    pts)

            ClosureType
    AP_STACK -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to AP_STACK"
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> [b] -> GenClosure b
    APStackClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts) (forall a. [a] -> [a]
    tail [b]
    pts)

            ClosureType
    IND -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to IND"
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> GenClosure b
    IndClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts)

            ClosureType
    IND_STATIC -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to IND_STATIC"
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> GenClosure b
    IndClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts)

            ClosureType
    BLACKHOLE -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to BLACKHOLE"
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> GenClosure b
    BlackholeClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts)

            ClosureType
    BCO -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    3) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 3 ptr argument to BCO, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    4) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 4 words to BCO, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords)
                let splitWord :: Word
    splitWord = [Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    3
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b.
    StgInfoTable
    -> b -> b -> b -> HalfWord -> HalfWord -> [Word] -> GenClosure b
    BCOClosure StgInfoTable
    itbl ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    0) ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    1) ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    2)
    #if defined(WORDS_BIGENDIAN)
                    (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                    (fromIntegral splitWord)
    #else
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                    (forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall a b. (a -> b) -> a -> b
    $ forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                    (forall a. Int -> [a] -> [a]
    drop Int
    4 [Word]
    payloadWords)

            ClosureType
    ARR_WORDS -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 1 words to ARR_WORDS, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords)
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> Word -> [Word] -> GenClosure b
    ArrWordsClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [Word]
    payloadWords) (forall a. [a] -> [a]
    tail [Word]
    payloadWords)

            ClosureType
    t | ClosureType
    t forall a. Ord a => a -> a -> Bool
    >= ClosureType
    MUT_ARR_PTRS_CLEAN Bool -> Bool -> Bool
    && ClosureType
    t forall a. Ord a => a -> a -> Bool
    <= ClosureType
    MUT_ARR_PTRS_FROZEN_CLEAN -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    2) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 2 words to MUT_ARR_PTRS_* "
                            forall a. [a] -> [a] -> [a]
    ++ String
    "found " forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords)
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> Word -> Word -> [b] -> GenClosure b
    MutArrClosure StgInfoTable
    itbl ([Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    0) ([Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    1) [b]
    pts

            ClosureType
    t | ClosureType
    t forall a. Ord a => a -> a -> Bool
    >= ClosureType
    SMALL_MUT_ARR_PTRS_CLEAN Bool -> Bool -> Bool
    && ClosureType
    t forall a. Ord a => a -> a -> Bool
    <= ClosureType
    SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
                            forall a. [a] -> [a] -> [a]
    ++ String
    "found " forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords)
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> Word -> [b] -> GenClosure b
    SmallMutArrClosure StgInfoTable
    itbl ([Word]
    payloadWords forall a. [a] -> Int -> a
    !! Int
    0) [b]
    pts

            ClosureType
    t | ClosureType
    t forall a. Eq a => a -> a -> Bool
    == ClosureType
    MUT_VAR_CLEAN Bool -> Bool -> Bool
    || ClosureType
    t forall a. Eq a => a -> a -> Bool
    == ClosureType
    MUT_VAR_DIRTY -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    1) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 1 words to MUT_VAR, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> GenClosure b
    MutVarClosure StgInfoTable
    itbl (forall a. [a] -> a
    head [b]
    pts)

            ClosureType
    t | ClosureType
    t forall a. Eq a => a -> a -> Bool
    == ClosureType
    MVAR_CLEAN Bool -> Bool -> Bool
    || ClosureType
    t forall a. Eq a => a -> a -> Bool
    == ClosureType
    MVAR_DIRTY -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts forall a. Ord a => a -> a -> Bool
    >= Int
    3) forall a b. (a -> b) -> a -> b
    $
                    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 3 ptrs to MVAR, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> b -> b -> b -> GenClosure b
    MVarClosure StgInfoTable
    itbl ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    0) ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    1) ([b]
    pts forall a. [a] -> Int -> a
    !! Int
    2)

            ClosureType
    BLOCKING_QUEUE ->
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
    OtherClosure StgInfoTable
    itbl [b]
    pts [Word]
    rawHeapWords
            --    pure $ BlockingQueueClosure itbl
            --        (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)

            --  pure $ OtherClosure itbl pts rawHeapWords
            --
            ClosureType
    WEAK ->
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ WeakClosure
                    { info :: StgInfoTable
    info = StgInfoTable
    itbl
                    , cfinalizers :: b
    cfinalizers = [b]
    pts forall a. [a] -> Int -> a
    !! Int
    0
                    , key :: b
    key = [b]
    pts forall a. [a] -> Int -> a
    !! Int
    1
                    , value :: b
    value = [b]
    pts forall a. [a] -> Int -> a
    !! Int
    2
                    , finalizer :: b
    finalizer = [b]
    pts forall a. [a] -> Int -> a
    !! Int
    3
                    , link :: b
    link = [b]
    pts forall a. [a] -> Int -> a
    !! Int
    4
                    }
            ClosureType
    TSO | [ b
    u_lnk, b
    u_gbl_lnk, b
    tso_stack, b
    u_trec, b
    u_blk_ex, b
    u_bq] <- [b]
    pts
                    -> forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
    withArray [Word]
    rawHeapWords (\Ptr Word
    ptr -> do
                        TSOFields
    fields <- forall a tsoPtr.
    (Ptr a -> IO (Maybe CostCentreStack)) -> Ptr tsoPtr -> IO TSOFields
    FFIClosures.peekTSOFields Ptr a -> IO (Maybe CostCentreStack)
    decodeCCS Ptr Word
    ptr
                        forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ TSOClosure
                            { info :: StgInfoTable
    info = StgInfoTable
    itbl
                            , link :: b
    link = b
    u_lnk
                            , global_link :: b
    global_link = b
    u_gbl_lnk
                            , tsoStack :: b
    tsoStack = b
    tso_stack
                            , trec :: b
    trec = b
    u_trec
                            , blocked_exceptions :: b
    blocked_exceptions = b
    u_blk_ex
                            , bq :: b
    bq = b
    u_bq
                            , what_next :: WhatNext
    what_next = TSOFields -> WhatNext
    FFIClosures.tso_what_next TSOFields
    fields
                            , why_blocked :: WhyBlocked
    why_blocked = TSOFields -> WhyBlocked
    FFIClosures.tso_why_blocked TSOFields
    fields
                            , flags :: [TsoFlags]
    flags = TSOFields -> [TsoFlags]
    FFIClosures.tso_flags TSOFields
    fields
                            , threadId :: Word64
    threadId = TSOFields -> Word64
    FFIClosures.tso_threadId TSOFields
    fields
                            , saved_errno :: HalfWord
    saved_errno = TSOFields -> HalfWord
    FFIClosures.tso_saved_errno TSOFields
    fields
                            , tso_dirty :: HalfWord
    tso_dirty = TSOFields -> HalfWord
    FFIClosures.tso_dirty TSOFields
    fields
                            , alloc_limit :: Int64
    alloc_limit = TSOFields -> Int64
    FFIClosures.tso_alloc_limit TSOFields
    fields
                            , tot_stack_size :: HalfWord
    tot_stack_size = TSOFields -> HalfWord
    FFIClosures.tso_tot_stack_size TSOFields
    fields
                            , prof :: Maybe StgTSOProfInfo
    prof = TSOFields -> Maybe StgTSOProfInfo
    FFIClosures.tso_prof TSOFields
    fields
                            })
                | Bool
    otherwise
                    -> forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected 6 ptr arguments to TSO, found "
                            forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
            ClosureType
    STACK
                | [] <- [b]
    pts
                -> forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
    withArray [Word]
    rawHeapWords (\Ptr Word
    ptr -> do
                                StackFields
    fields <- forall a. Ptr a -> IO StackFields
    FFIClosures.peekStackFields Ptr Word
    ptr
                                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ StackClosure
                                    { info :: StgInfoTable
    info = StgInfoTable
    itbl
                                    , stack_size :: HalfWord
    stack_size = StackFields -> HalfWord
    FFIClosures.stack_size StackFields
    fields
                                    , stack_dirty :: Word8
    stack_dirty = StackFields -> Word8
    FFIClosures.stack_dirty StackFields
    fields
    #if __GLASGOW_HASKELL__ >= 811
                                    , stack_marking :: Word8
    stack_marking = StackFields -> Word8
    FFIClosures.stack_marking StackFields
    fields
    #endif
                                    })
                | Bool
    otherwise
                    -> forall (m :: * -> *) a. MonadFail m => String -> m a
    fail forall a b. (a -> b) -> a -> b
    $ String
    "Expected 0 ptr argument to STACK, found "
                        forall a. [a] -> [a] -> [a]
    ++ forall a. Show a => a -> String
    show (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)

            ClosureType
    _ ->
                forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall b. StgInfoTable -> GenClosure b
    UnsupportedClosure StgInfoTable
    itbl

    -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
    getBoxedClosureData :: Box -> IO Closure
    getBoxedClosureData :: Box -> IO Closure
    getBoxedClosureData (Box Any
    a) = forall a. HasHeapRep a => a -> IO Closure
    getClosureData Any
    a