    {-# LANGUAGE CPP #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE UnboxedTuples #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE PolyKinds #-}
    {-# LANGUAGE DataKinds #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# 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 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 = a -> IO Closure
    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 = ZonkAny 1 -> IO Closure
    forall a. a -> IO Closure
    getClosureDataFromHeapObject (a -> ZonkAny 1
    forall a b. a -> b
    unsafeCoerce# a
    x)

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

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

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

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

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

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

    instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
        getClosureData :: a -> IO Closure
    getClosureData a
    x = Closure -> IO Closure
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Closure -> IO Closure) -> Closure -> IO Closure
    forall a b. (a -> b) -> a -> b
    $
            DoubleClosure { ptipe :: PrimType
    ptipe = PrimType
    PDouble, doubleVal :: Double
    doubleVal = Double# -> Double
    D# a
    Double#
    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 a -> (# Addr#, ByteArray#, Array# Any #)
    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 = Addr# -> Ptr StgInfoTable
    forall a. Addr# -> Ptr a
    Ptr Addr#
    infoTableAddr
                    ptrList :: [Box]
    ptrList = [case Array# Any -> Int# -> (# Any #)
    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# (Array# Any -> Int#
    forall a. Array# a -> Int#
    sizeofArray# Array# Any
    pointersArray) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]
                                ]

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

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

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

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

            ClosureType
    THUNK_SELECTOR -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to THUNK_SELECTOR"
                b
    hd : [b]
    _ -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> GenClosure b
    forall b. StgInfoTable -> b -> GenClosure b
    SelectorClosure StgInfoTable
    itbl b
    hd

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

            ClosureType
    AP -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to AP"
                b
    hd : [b]
    tl -> case [Word]
    payloadWords of
                    -- We expect at least the arity, n_args, and fun fields
                    Word
    splitWord : Word
    _ : [Word]
    _ ->
                        GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> HalfWord -> HalfWord -> b -> [b] -> GenClosure 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
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word -> HalfWord) -> Word -> HalfWord
    forall a b. (a -> b) -> a -> b
    $ Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                            b
    hd [b]
    tl
                    [Word]
    _ -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 2 raw words to AP"

            ClosureType
    PAP -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to PAP"
                b
    hd : [b]
    tl -> case [Word]
    payloadWords of
                    -- We expect at least the arity, n_args, and fun fields
                    Word
    splitWord : Word
    _ : [Word]
    _ ->
                        GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> HalfWord -> HalfWord -> b -> [b] -> GenClosure 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
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word -> HalfWord) -> Word -> HalfWord
    forall a b. (a -> b) -> a -> b
    $ Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                            b
    hd [b]
    tl
                    [Word]
    _ -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 2 raw words to PAP"

            ClosureType
    AP_STACK -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to AP_STACK"
                b
    hd : [b]
    tl -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> [b] -> GenClosure b
    forall b. StgInfoTable -> b -> [b] -> GenClosure b
    APStackClosure StgInfoTable
    itbl b
    hd [b]
    tl

            ClosureType
    IND -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to IND"
                b
    hd : [b]
    _ -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> GenClosure b
    forall b. StgInfoTable -> b -> GenClosure b
    IndClosure StgInfoTable
    itbl b
    hd

            ClosureType
    IND_STATIC -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to IND_STATIC"
                b
    hd : [b]
    _ -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> GenClosure b
    forall b. StgInfoTable -> b -> GenClosure b
    IndClosure StgInfoTable
    itbl b
    hd

            ClosureType
    BLACKHOLE -> case [b]
    pts of
                [] -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expected at least 1 ptr argument to BLACKHOLE"
                b
    hd : [b]
    _ -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> GenClosure b
    forall b. StgInfoTable -> b -> GenClosure b
    BlackholeClosure StgInfoTable
    itbl b
    hd

            ClosureType
    BCO -> case [b]
    pts of
                b
    pts0 : b
    pts1 : b
    pts2 : [b]
    _ -> case [Word]
    payloadWords of
                    Word
    _ : Word
    _ : Word
    _ : Word
    splitWord : [Word]
    payloadRest ->
                        GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable
    -> b -> b -> b -> HalfWord -> HalfWord -> [Word] -> GenClosure b
    forall b.
    StgInfoTable
    -> b -> b -> b -> HalfWord -> HalfWord -> [Word] -> GenClosure b
    BCOClosure StgInfoTable
    itbl b
    pts0 b
    pts1 b
    pts2
    #if defined(WORDS_BIGENDIAN)
                            (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
                            (fromIntegral splitWord)
    #else
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    splitWord)
                            (Word -> HalfWord
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word -> HalfWord) -> Word -> HalfWord
    forall a b. (a -> b) -> a -> b
    $ Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    shiftR Word
    splitWord (Int
    wORD_SIZE_IN_BITS Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2))
    #endif
                            [Word]
    payloadRest
                    [Word]
    _ -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 4 words to BCO, found "
                                String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([Word] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Word]
    payloadWords)
                [b]
    _ -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 3 ptr argument to BCO, found "
                            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)

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

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

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

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

            ClosureType
    t | ClosureType
    t ClosureType -> ClosureType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClosureType
    MVAR_CLEAN Bool -> Bool -> Bool
    || ClosureType
    t ClosureType -> ClosureType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClosureType
    MVAR_DIRTY -> case [b]
    pts of
                b
    pts0 : b
    pts1 : b
    pts2 : [b]
    _ -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> b -> b -> GenClosure b
    forall b. StgInfoTable -> b -> b -> b -> GenClosure b
    MVarClosure StgInfoTable
    itbl b
    pts0 b
    pts1 b
    pts2
                [b]
    _ -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 3 ptrs to MVAR, found "
                            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)

            ClosureType
    BLOCKING_QUEUE
              | [b
    _link, b
    bh, b
    _owner, b
    msg] <- [b]
    pts ->
                GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> b -> b -> b -> b -> GenClosure b
    forall b. StgInfoTable -> b -> b -> b -> b -> GenClosure b
    BlockingQueueClosure StgInfoTable
    itbl b
    _link b
    bh b
    _owner b
    msg

            ClosureType
    WEAK -> case [b]
    pts of
                b
    pts0 : b
    pts1 : b
    pts2 : b
    pts3 : [b]
    rest -> GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ WeakClosure
                    { info :: StgInfoTable
    info = StgInfoTable
    itbl
                    , cfinalizers :: b
    cfinalizers = b
    pts0
                    , key :: b
    key = b
    pts1
                    , value :: b
    value = b
    pts2
                    , finalizer :: b
    finalizer = b
    pts3
                    , weakLink :: Maybe b
    weakLink = case [b]
    rest of
                               []  -> Maybe b
    forall a. Maybe a
    Nothing
                               [b
    p] -> b -> Maybe b
    forall a. a -> Maybe a
    Just b
    p
                               [b]
    _   -> String -> Maybe b
    forall a. HasCallStack => String -> a
    error (String -> Maybe b) -> String -> Maybe b
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected 4 or 5 words in WEAK, but found more: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
                    }
                [b]
    _ -> String -> IO (GenClosure b)
    forall a. HasCallStack => String -> a
    error (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected 4 or 5 words in WEAK, but found less: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
            ClosureType
    TSO | ( b
    u_lnk : b
    u_gbl_lnk : b
    tso_stack : b
    u_trec : b
    u_blk_ex : b
    u_bq : [b]
    other)  <- [b]
    pts
                    -> [Word] -> (Ptr Word -> IO (GenClosure b)) -> IO (GenClosure b)
    forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
    withArray [Word]
    rawHeapWords (\Ptr Word
    ptr -> do
                        fields <- (Ptr a -> IO (Maybe CostCentreStack)) -> Ptr Word -> IO TSOFields
    forall a tsoPtr.
    (Ptr a -> IO (Maybe CostCentreStack)) -> Ptr tsoPtr -> IO TSOFields
    FFIClosures.peekTSOFields Ptr a -> IO (Maybe CostCentreStack)
    decodeCCS Ptr Word
    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
                            , thread_label = case other of
                                              [b
    tl] -> b -> Maybe b
    forall a. a -> Maybe a
    Just b
    tl
                                              [] -> Maybe b
    forall a. Maybe a
    Nothing
                                              [b]
    _ -> String -> Maybe b
    forall a. HasCallStack => String -> a
    error (String -> Maybe b) -> String -> Maybe b
    forall a b. (a -> b) -> a -> b
    $ String
    "thead_label:Expected 0 or 1 extra arguments"
                            , 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
                            })
                | Bool
    otherwise
                    -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected at least 6 ptr arguments to TSO, found "
                            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)
            ClosureType
    STACK
                | [] <- [b]
    pts
                -> [Word] -> (Ptr Word -> IO (GenClosure b)) -> IO (GenClosure b)
    forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
    withArray [Word]
    rawHeapWords (\Ptr Word
    ptr -> do
                                fields <- Ptr Word -> IO StackFields
    forall a. Ptr a -> IO StackFields
    FFIClosures.peekStackFields Ptr Word
    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
                                    })
                | Bool
    otherwise
                    -> String -> IO (GenClosure b)
    forall a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ String
    "Expected 0 ptr argument to STACK, found "
                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    pts)

            ClosureType
    _ ->
                GenClosure b -> IO (GenClosure b)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (GenClosure b -> IO (GenClosure b))
    -> GenClosure b -> IO (GenClosure b)
    forall a b. (a -> b) -> a -> b
    $ StgInfoTable -> GenClosure 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) = Any -> IO Closure
    forall a. HasHeapRep a => a -> IO Closure
    getClosureData Any
    a