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

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

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

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

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

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

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

     -- * Closure inspection
    , getBoxedClosureData
    , allClosures

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

import Prelude
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Constants
import GHC.Exts.Heap.ProfInfo.Types
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils
import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI

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

#include "ghcconfig.h"

class HasHeapRep (a :: TYPE rep) where

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

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

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

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

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

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

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

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

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

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

-- | Get the heap representation of a closure _at this moment_, even if it is
-- unevaluated or an indirection or other exotic stuff. Beware when passing
-- something to this function, the same caveats as for
-- 'GHC.Exts.Heap.Closures.asBox' apply.
--
-- For most use cases 'getClosureData' is an easier to use alternative.
--
-- Currently TSO and STACK objects will return `UnsupportedClosure`. This is
-- because it is not memory safe to extract TSO and STACK objects (done via
-- `unpackClosure#`). Other threads may be mutating those objects and interleave
-- with reads in `unpackClosure#`. This is particularly problematic with STACKs
-- where pointer values may be overwritten by non-pointer values as the
-- corresponding haskell thread runs.
getClosureDataFromHeapObject
    :: a
    -- ^ Heap object to decode.
    -> IO Closure
    -- ^ Heap representation of the closure.
getClosureDataFromHeapObject :: forall a. a -> IO Closure
getClosureDataFromHeapObject a
x = do
    case forall a b. a -> (# Addr#, ByteArray#, Array# b #)
unpackClosure# a
x of
        (# Addr#
infoTableAddr, ByteArray#
heapRep, Array# Any
pointersArray #) -> do
            let infoTablePtr :: Ptr StgInfoTable
infoTablePtr = forall a. Addr# -> Ptr a
Ptr Addr#
infoTableAddr
                ptrList :: [Box]
ptrList = [case forall a. Array# a -> Int# -> (# a #)
indexArray# Array# Any
pointersArray Int#
i of
                                (# Any
ptr #) -> Any -> Box
Box Any
ptr
                            | I# Int#
i <- [Int
0..(Int# -> Int
I# (forall a. Array# a -> Int#
sizeofArray# Array# Any
pointersArray)) forall a. Num a => a -> a -> a
- Int
1]
                            ]

            StgInfoTable
infoTable <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
infoTablePtr
            case StgInfoTable -> ClosureType
tipe StgInfoTable
infoTable of
                ClosureType
TSO   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. StgInfoTable -> GenClosure b
UnsupportedClosure StgInfoTable
infoTable
                ClosureType
STACK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. StgInfoTable -> GenClosure b
UnsupportedClosure StgInfoTable
infoTable
                ClosureType
_ -> forall b.
ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
getClosureDataFromHeapRep ByteArray#
heapRep Ptr StgInfoTable
infoTablePtr [Box]
ptrList


-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
-- function can be generated from a heap object using `unpackClosure#`.
getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
getClosureDataFromHeapRep :: forall b.
ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
getClosureDataFromHeapRep ByteArray#
heapRep Ptr StgInfoTable
infoTablePtr [b]
pts = do
  StgInfoTable
itbl <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
infoTablePtr
  forall a b.
IO (String, String, String)
-> (Ptr a -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
getClosureDataFromHeapRepPrim (Ptr StgInfoTable -> IO (String, String, String)
dataConNames Ptr StgInfoTable
infoTablePtr) forall a. Ptr a -> IO (Maybe CostCentreStack)
PPI.peekTopCCS StgInfoTable
itbl ByteArray#
heapRep [b]
pts

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

        -- Just the payload of rawHeapWords (no header).
        payloadWords :: [Word]
        payloadWords :: [Word]
payloadWords = forall a. Int -> [a] -> [a]
drop (ClosureType -> Int
closureTypeHeaderSize (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl)) [Word]
rawHeapWords

        -- The non-pointer words in the payload. Only valid for closures with a
        -- "pointers first" layout. Not valid for bit field layout.
        npts :: [Word]
        npts :: [Word]
npts = forall a. Int -> [a] -> [a]
drop (ClosureType -> Int
closureTypeHeaderSize (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl) forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
pts) [Word]
rawHeapWords
    case StgInfoTable -> ClosureType
tipe StgInfoTable
itbl of
        ClosureType
t | ClosureType
t forall a. Ord a => a -> a -> Bool
>= ClosureType
CONSTR Bool -> Bool -> Bool
&& ClosureType
t forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_NOCAF -> do
            (String
p, String
m, String
n) <- IO (String, String, String)
getConDesc
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b.
StgInfoTable
-> [b] -> [Word] -> String -> String -> String -> GenClosure b
ConstrClosure StgInfoTable
itbl [b]
pts [Word]
npts String
p String
m String
n

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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