    {-# 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)
        , getClosureInfoTbl
        , getClosureInfoTbl_maybe
        , getClosurePtrArgs
        , getClosurePtrArgs_maybe
        , 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.InfoTable () -- See Note [No way-dependent imports]
    import GHC.Exts.Heap.InfoTableProf
    #else
    import GHC.Exts.Heap.InfoTable
    import GHC.Exts.Heap.InfoTableProf () -- See Note [No way-dependent imports]

    {-
    Note [No way-dependent imports]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    `ghc -M` currently assumes that the imports for a module are the same
    in every way.  This is arguably a bug, but breaking this assumption by
    importing different things in different ways can cause trouble.  For
    example, this module in the profiling way imports and uses
    GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the
    vanilla way, there were intermittent build failures due to this module
    being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf
    in the profiling way. (#15197)
    -}
    #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.

    instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where
        getClosureData :: a -> IO Closure
    getClosureData = a -> IO Closure
    forall a. a -> IO Closure
    getClosureDataFromHeapObject

    instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where
        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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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
                                    , stack_marking = FFIClosures.stack_marking fields
                                    })
                | Bool
    otherwise
                    -> String -> IO (GenClosure b)
    forall a. HasCallStack => String -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    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