module GHC.Exts.Heap (
Closure
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
, HasHeapRep(getClosureData)
, StgInfoTable(..)
, EntryFunPtr
, HalfWord
, ItblCodes
, itblSize
, peekItbl
, pokeItbl
, getBoxedClosureData
, allClosures
, 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 = getClosure
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
getClosureData x = getClosure (unsafeCoerce# x)
instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
getClosureData x = return $
IntClosure { ptipe = PInt, intVal = I# x }
instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
getClosureData x = return $
WordClosure { ptipe = PWord, wordVal = W# x }
instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
getClosureData x = return $
Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
getClosureData x = return $
Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
getClosureData x = return $
AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
getClosureData x = return $
FloatClosure { ptipe = PFloat, floatVal = F# x }
instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
getClosureData x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
getClosureRaw x = do
case unpackClosure# x of
#if MIN_VERSION_ghc_prim(0,5,3)
(# iptr, dat, pointers #) -> do
#else
(# iptr, pointers, dat #) -> do
#endif
let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
end = fromIntegral nelems 1
rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
pelems = I# (sizeofArray# pointers)
ptrList = amap' Box $ Array 0 (pelems 1) pelems pointers
pure (Ptr iptr, rawWds, ptrList)
amap' :: (t -> b) -> Array Int t -> [b]
amap' f (Array i0 i _ arr#) = map g [0 .. i i0]
where g (I# i#) = case indexArray# arr# i# of
(# e #) -> f e
getClosure :: a -> IO Closure
getClosure x = do
(iptr, wds, pts) <- getClosureRaw x
itbl <- peekItbl iptr
let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
case tipe itbl of
t | t >= CONSTR && t <= CONSTR_NOCAF -> do
(p, m, n) <- dataConNames iptr
if m == "ByteCodeInstr" && n == "BreakInfo"
then pure $ UnsupportedClosure itbl
else pure $ ConstrClosure itbl pts npts p m n
t | t >= THUNK && t <= THUNK_STATIC -> do
pure $ ThunkClosure itbl pts npts
THUNK_SELECTOR -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
pure $ SelectorClosure itbl (head pts)
t | t >= FUN && t <= FUN_STATIC -> do
pure $ FunClosure itbl pts npts
AP -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to AP"
unless (length rawWds >= 2) $
fail $ "Expected at least 2 raw words to AP"
let splitWord = rawWds !! 0
pure $ APClosure itbl
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(fromIntegral splitWord)
#else
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
(head pts) (tail pts)
PAP -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to PAP"
unless (length rawWds >= 2) $
fail "Expected at least 2 raw words to PAP"
let splitWord = rawWds !! 0
pure $ PAPClosure itbl
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(fromIntegral splitWord)
#else
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
(head pts) (tail pts)
AP_STACK -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to AP_STACK"
pure $ APStackClosure itbl (head pts) (tail pts)
IND -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to IND"
pure $ IndClosure itbl (head pts)
IND_STATIC -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to IND_STATIC"
pure $ IndClosure itbl (head pts)
BLACKHOLE -> do
unless (length pts >= 1) $
fail "Expected at least 1 ptr argument to BLACKHOLE"
pure $ BlackholeClosure itbl (head pts)
BCO -> do
unless (length pts >= 3) $
fail $ "Expected at least 3 ptr argument to BCO, found "
++ show (length pts)
unless (length rawWds >= 4) $
fail $ "Expected at least 4 words to BCO, found "
++ show (length rawWds)
let splitWord = rawWds !! 3
pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
#if defined(WORDS_BIGENDIAN)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
(fromIntegral splitWord)
#else
(fromIntegral splitWord)
(fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
#endif
(drop 4 rawWds)
ARR_WORDS -> do
unless (length rawWds >= 1) $
fail $ "Expected at least 1 words to ARR_WORDS, found "
++ show (length rawWds)
pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)
t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
unless (length rawWds >= 2) $
fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
++ "found " ++ show (length rawWds)
pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
pure $ MutVarClosure itbl (head pts)
t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
unless (length pts >= 3) $
fail $ "Expected at least 3 ptrs to MVAR, found "
++ show (length pts)
pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
BLOCKING_QUEUE ->
pure $ OtherClosure itbl pts wds
_ ->
pure $ UnsupportedClosure itbl
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a