{-# 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