{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnliftedFFITypes #-}

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

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

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

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

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

     -- * Closure inspection
    , getBoxedClosureData
    , allClosures

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

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

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

#include "ghcconfig.h"

class HasHeapRep (a :: TYPE rep) where

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

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

#if __GLASGOW_HASKELL__ >= 901
instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where
#else
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
#endif
    getClosureData :: a -> IO Closure
getClosureData a
x = Any -> IO Closure
forall a. a -> IO Closure
getClosureDataFromHeapObject (a -> Any
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 :: Int
addrVal = Int# -> Int
I# (a -> Int#
forall a b. a -> b
unsafeCoerce# a
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]
                            ]

            StgInfoTable
infoTable <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
infoTablePtr
            case StgInfoTable -> ClosureType
tipe StgInfoTable
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
  StgInfoTable
itbl <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
infoTablePtr
  IO (String, String, String)
-> (Ptr Any -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
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) Ptr Any -> IO (Maybe CostCentreStack)
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) 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
            (String
p, String
m, String
n) <- IO (String, String, String)
getConDesc
            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] -> String -> String -> String -> GenClosure 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 ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
>= ClosureType
THUNK Bool -> Bool -> Bool
&& ClosureType
t ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
THUNK_STATIC -> do
            GenClosure b -> IO (GenClosure b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenClosure b -> IO (GenClosure b))
-> GenClosure b -> IO (GenClosure b)
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> [b] -> [Word] -> GenClosure b
forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
ThunkClosure StgInfoTable
itbl [b]
pts [Word]
npts

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        ClosureType
BLOCKING_QUEUE ->
            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
OtherClosure StgInfoTable
itbl [b]
pts [Word]
rawHeapWords

        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
                    TSOFields
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
                    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
$ 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
                        , thread_label :: Maybe b
thread_label = case [b]
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 :: 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
                -> String -> IO (GenClosure b)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
forall a b. (a -> b) -> a -> b
$ String
"Expected at least 6 ptr arguments to TSO, found "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
pts)
        ClosureType
STACK
            | [] <- [b]
pts
            -> [Word] -> (Ptr Word -> IO (GenClosure b)) -> IO (GenClosure b)
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word]
rawHeapWords (\Ptr Word
ptr -> do
                            StackFields
fields <- Ptr Word -> IO StackFields
forall a. Ptr a -> IO StackFields
FFIClosures.peekStackFields Ptr Word
ptr
                            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
$ 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
                -> String -> IO (GenClosure b)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (GenClosure b)) -> String -> IO (GenClosure b)
forall a b. (a -> b) -> a -> b
$ String
"Expected 0 ptr argument to STACK, found "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
pts)

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

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