{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnliftedFFITypes #-}
module GHC.Exts.Heap (
Closure
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
, getClosureDataFromHeapRep
, getClosureDataFromHeapRepPrim
, StgInfoTable(..)
, EntryFunPtr
, HalfWord
, ItblCodes
, itblSize
, peekItbl
, pokeItbl
, StgTSOProfInfo(..)
, IndexTable(..)
, CostCentre(..)
, CostCentreStack(..)
, getBoxedClosureData
, allClosures
, 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
getClosureData
:: a
-> IO 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 }
getClosureDataFromHeapObject
:: a
-> IO 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
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)
-> (Ptr a -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
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
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
payloadWords :: [Word]
payloadWords :: [Word]
payloadWords = Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
drop (ClosureType -> Int
closureTypeHeaderSize (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl)) [Word]
rawHeapWords
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 -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to THUNK_SELECTOR"
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
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
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 -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to AP"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 2 raw words to AP"
let splitWord :: Word
splitWord = [Word]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
0
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts) ([b] -> [b]
forall a. HasCallStack => [a] -> [a]
tail [b]
pts)
ClosureType
PAP -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to PAP"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 2 raw words to PAP"
let splitWord :: Word
splitWord = [Word]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
0
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts) ([b] -> [b]
forall a. HasCallStack => [a] -> [a]
tail [b]
pts)
ClosureType
AP_STACK -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to AP_STACK"
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts) ([b] -> [b]
forall a. HasCallStack => [a] -> [a]
tail [b]
pts)
ClosureType
IND -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to IND"
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts)
ClosureType
IND_STATIC -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to IND_STATIC"
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts)
ClosureType
BLACKHOLE -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected at least 1 ptr argument to BLACKHOLE"
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
pts)
ClosureType
BCO -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
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 ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
pts)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords)
let splitWord :: Word
splitWord = [Word]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
3
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]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) ([b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) ([b]
pts [b] -> Int -> b
forall a. HasCallStack => [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]
payloadWords)
ClosureType
ARR_WORDS -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords)
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] -> Word
forall a. HasCallStack => [a] -> a
head [Word]
payloadWords) ([Word] -> [Word]
forall a. HasCallStack => [a] -> [a]
tail [Word]
payloadWords)
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords)
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]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) ([Word]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) [b]
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords 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 a. String -> IO a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
payloadWords)
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]
payloadWords [Word] -> Int -> Word
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) [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 -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
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 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)
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] -> b
forall a. HasCallStack => [a] -> a
head [b]
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 ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
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 a. String -> IO a
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 ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
pts)
GenClosure b -> IO (GenClosure b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenClosure b -> IO (GenClosure b))
-> GenClosure b -> IO (GenClosure b)
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> b -> b -> b -> GenClosure b
forall b. StgInfoTable -> b -> b -> b -> GenClosure b
MVarClosure StgInfoTable
itbl ([b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
0) ([b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) ([b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
2)
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 -> 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
$ WeakClosure
{ info :: StgInfoTable
info = StgInfoTable
itbl
, cfinalizers :: b
cfinalizers = [b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
0
, key :: b
key = [b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
1
, value :: b
value = [b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
2
, finalizer :: b
finalizer = [b]
pts [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
3
, weakLink :: Maybe b
weakLink = case Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
4 [b]
pts 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, 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
TSO | [ b
u_lnk, b
u_gbl_lnk, b
tso_stack, b
u_trec, b
u_blk_ex, b
u_bq] <- [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
, 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 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
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