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

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}

{-|
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(..)
    , HasHeapRep(getClosureData)

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

     -- * 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
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils

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

#include "ghcconfig.h"

class HasHeapRep (a :: TYPE rep) where
    getClosureData :: a -> IO Closure

instance HasHeapRep (a :: TYPE 'LiftedRep) where
    getClosureData :: a -> IO Closure
getClosureData = a -> IO Closure
forall a. a -> IO Closure
getClosure

instance HasHeapRep (a :: TYPE 'UnliftedRep) where
    getClosureData :: a -> IO Closure
getClosureData a
x = Any -> IO Closure
forall a. a -> IO Closure
getClosure (a -> Any
unsafeCoerce# a
x)

instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
    getClosureData :: a -> IO Closure
getClosureData a
x = Closure -> IO Closure
forall (m :: * -> *) a. Monad m => a -> m a
return (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$
        IntClosure :: forall b. PrimType -> Int -> GenClosure 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 (m :: * -> *) a. Monad m => a -> m a
return (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$
        WordClosure :: forall b. PrimType -> Word -> GenClosure 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 (m :: * -> *) a. Monad m => a -> m a
return (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$
        Int64Closure :: forall b. PrimType -> Int64 -> GenClosure b
Int64Closure { ptipe :: PrimType
ptipe = PrimType
PInt64, int64Val :: Int64
int64Val = Int# -> Int64
I64# (a -> Int#
unsafeCoerce# a
x) }

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

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

instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
    getClosureData :: a -> IO Closure
getClosureData a
x = Closure -> IO Closure
forall (m :: * -> *) a. Monad m => a -> m a
return (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$
        FloatClosure :: forall b. PrimType -> Float -> GenClosure 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 (m :: * -> *) a. Monad m => a -> m a
return (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$
        DoubleClosure :: forall b. PrimType -> Double -> GenClosure b
DoubleClosure { ptipe :: PrimType
ptipe = PrimType
PDouble, doubleVal :: Double
doubleVal = Double# -> Double
D# a
Double#
x }

-- | This returns the raw representation of the given argument. The second
-- component of the triple is the raw words of the closure on the heap, and the
-- third component is those words that are actually pointers. Once back in the
-- Haskell world, the raw words that hold pointers may be outdated after a
-- garbage collector run, but the corresponding values in 'Box's will still
-- point to the correct value.
getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw :: forall a. a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw a
x = do
    case a -> (# Addr#, ByteArray#, Array# Any #)
forall a b. a -> (# Addr#, ByteArray#, Array# b #)
unpackClosure# a
x of
-- This is a hack to cover the bootstrap compiler using the old version of
-- 'unpackClosure'. The new 'unpackClosure' return values are not merely
-- a reordering, so using the old version would not work.
        (# Addr#
iptr, ByteArray#
dat, Array# Any
pointers #) -> do
            let nelems :: Int
nelems = (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
dat)) 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
                rawWds :: [Word]
rawWds = [Word# -> Word
W# (ByteArray# -> Int# -> Word#
indexWordArray# ByteArray#
dat Int#
i) | I# Int#
i <- [Int
0.. Int
end] ]
                pelems :: Int
pelems = Int# -> Int
I# (Array# Any -> Int#
forall a. Array# a -> Int#
sizeofArray# Array# Any
pointers)
                ptrList :: [Box]
ptrList = (Any -> Box) -> Array Int Any -> [Box]
forall t b. (t -> b) -> Array Int t -> [b]
amap' Any -> Box
Box (Array Int Any -> [Box]) -> Array Int Any -> [Box]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Array# Any -> Array Int Any
forall i e. i -> i -> Int -> Array# e -> Array i e
Array Int
0 (Int
pelems Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
pelems Array# Any
pointers
            (Ptr StgInfoTable, [Word], [Box])
-> IO (Ptr StgInfoTable, [Word], [Box])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Addr# -> Ptr StgInfoTable
forall a. Addr# -> Ptr a
Ptr Addr#
iptr, [Word]
rawWds, [Box]
ptrList)

-- From GHC.Runtime.Heap.Inspect
amap' :: (t -> b) -> Array Int t -> [b]
amap' :: forall t b. (t -> b) -> Array Int t -> [b]
amap' t -> b
f (Array Int
i0 Int
i Int
_ Array# t
arr#) = (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Int -> b
g [Int
0 .. Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i0]
    where g :: Int -> b
g (I# Int#
i#) = case Array# t -> Int# -> (# t #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# t
arr# Int#
i# of
                          (# t
e #) -> t -> b
f t
e

-- | This function returns a parsed heap representation of the argument _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 'asBox' apply.
getClosure :: a -> IO Closure
getClosure :: forall a. a -> IO Closure
getClosure a
x = do
    (Ptr StgInfoTable
iptr, [Word]
wds, [Box]
pts) <- a -> IO (Ptr StgInfoTable, [Word], [Box])
forall a. a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw a
x
    StgInfoTable
itbl <- Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
iptr
    -- The remaining words after the header
    let rawWds :: [Word]
rawWds = Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
drop (ClosureType -> Int
closureTypeHeaderSize (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl)) [Word]
wds
    -- For data args in a pointers then non-pointers closure
    -- This is incorrect in non pointers-first setups
    -- not sure if that happens
        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
+ [Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts) [Word]
wds
    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) <- Ptr StgInfoTable -> IO (String, String, String)
dataConNames Ptr StgInfoTable
iptr
            if String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.ByteCode.Instr" Bool -> Bool -> Bool
&& String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BreakInfo"
              then Closure -> IO Closure
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
itbl
              else Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable
-> [Box] -> [Word] -> String -> String -> String -> Closure
forall b.
StgInfoTable
-> [b] -> [Word] -> String -> String -> String -> GenClosure b
ConstrClosure StgInfoTable
itbl [Box]
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
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> [Box] -> [Word] -> Closure
forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
ThunkClosure StgInfoTable
itbl [Box]
pts [Word]
npts

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

        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
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> [Box] -> [Word] -> Closure
forall b. StgInfoTable -> [b] -> [Word] -> GenClosure b
FunClosure StgInfoTable
itbl [Box]
pts [Word]
npts

        ClosureType
AP -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected at least 2 raw words to AP"
            let splitWord :: Word
splitWord = [Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
0
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> HalfWord -> HalfWord -> Box -> [Box] -> Closure
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
                ([Box] -> Box
forall a. [a] -> a
head [Box]
pts) ([Box] -> [Box]
forall a. [a] -> [a]
tail [Box]
pts)

        ClosureType
PAP -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 2 raw words to PAP"
            let splitWord :: Word
splitWord = [Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
0
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> HalfWord -> HalfWord -> Box -> [Box] -> Closure
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
                ([Box] -> Box
forall a. [a] -> a
head [Box]
pts) ([Box] -> [Box]
forall a. [a] -> [a]
tail [Box]
pts)

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

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

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

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

        ClosureType
BCO -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds)
            let splitWord :: Word
splitWord = [Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
3
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable
-> Box -> Box -> Box -> HalfWord -> HalfWord -> [Word] -> Closure
forall b.
StgInfoTable
-> b -> b -> b -> HalfWord -> HalfWord -> [Word] -> GenClosure b
BCOClosure StgInfoTable
itbl ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
0) ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
1) ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
2)
#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
                (Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
drop Int
4 [Word]
rawWds)

        ClosureType
ARR_WORDS -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds)
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Word -> [Word] -> Closure
forall b. StgInfoTable -> Word -> [Word] -> GenClosure b
ArrWordsClosure StgInfoTable
itbl ([Word] -> Word
forall a. [a] -> a
head [Word]
rawWds) ([Word] -> [Word]
forall a. [a] -> [a]
tail [Word]
rawWds)

        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 -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds)
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Word -> Word -> [Box] -> Closure
forall b. StgInfoTable -> Word -> Word -> [b] -> GenClosure b
MutArrClosure StgInfoTable
itbl ([Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
0) ([Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
1) [Box]
pts

        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 -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
rawWds)
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Word -> [Box] -> Closure
forall b. StgInfoTable -> Word -> [b] -> GenClosure b
SmallMutArrClosure StgInfoTable
itbl ([Word]
rawWds [Word] -> Int -> Word
forall a. [a] -> Int -> a
!! Int
0) [Box]
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 ->
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Box -> Closure
forall b. StgInfoTable -> b -> GenClosure b
MutVarClosure StgInfoTable
itbl ([Box] -> Box
forall a. [a] -> a
head [Box]
pts)

        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 -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
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 ([Box] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Box]
pts)
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Box -> Box -> Box -> Closure
forall b. StgInfoTable -> b -> b -> b -> GenClosure b
MVarClosure StgInfoTable
itbl ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
0) ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
1) ([Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
2)

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

        --  pure $ OtherClosure itbl pts wds
        --

        ClosureType
WEAK ->
            Closure -> IO Closure
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> Closure -> IO Closure
forall a b. (a -> b) -> a -> b
$ WeakClosure :: forall b. StgInfoTable -> b -> b -> b -> b -> b -> GenClosure b
WeakClosure
                { info :: StgInfoTable
info = StgInfoTable
itbl
                , cfinalizers :: Box
cfinalizers = [Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
0
                , key :: Box
key = [Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
1
                , value :: Box
value = [Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
2
                , finalizer :: Box
finalizer = [Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
3
                , link :: Box
link = [Box]
pts [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
4
                }

        ClosureType
_ ->
            Closure -> IO Closure
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
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