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 = getClosureDataFromHeapObject
#if __GLASGOW_HASKELL__ >= 901
instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where
#else
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
#endif
getClosureData x = getClosureDataFromHeapObject (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 }
getClosureDataFromHeapObject
:: a
-> IO Closure
getClosureDataFromHeapObject x = do
case unpackClosure# x of
(# infoTableAddr, heapRep, pointersArray #) -> do
let infoTablePtr = Ptr infoTableAddr
ptrList = [case indexArray# pointersArray i of
(# ptr #) -> Box ptr
| I# i <- [0..(I# (sizeofArray# pointersArray)) 1]
]
infoTable <- peekItbl infoTablePtr
case tipe infoTable of
TSO -> pure $ UnsupportedClosure infoTable
STACK -> pure $ UnsupportedClosure infoTable
_ -> getClosureDataFromHeapRep heapRep infoTablePtr ptrList
getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
getClosureDataFromHeapRep heapRep infoTablePtr pts = do
itbl <- peekItbl infoTablePtr
getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts
getClosureDataFromHeapRepPrim
:: IO (String, String, String)
-> (Ptr a -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
let
rawHeapWords :: [Word]
rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
where
nelems = (I# (sizeofByteArray# heapRep)) `div` wORD_SIZE
end = fromIntegral nelems 1
payloadWords :: [Word]
payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords
npts :: [Word]
npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords
case tipe itbl of
t | t >= CONSTR && t <= CONSTR_NOCAF -> do
(p, m, n) <- getConDesc
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 payloadWords >= 2) $
fail $ "Expected at least 2 raw words to AP"
let splitWord = payloadWords !! 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 payloadWords >= 2) $
fail "Expected at least 2 raw words to PAP"
let splitWord = payloadWords !! 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 payloadWords >= 4) $
fail $ "Expected at least 4 words to BCO, found "
++ show (length payloadWords)
let splitWord = payloadWords !! 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 payloadWords)
ARR_WORDS -> do
unless (length payloadWords >= 1) $
fail $ "Expected at least 1 words to ARR_WORDS, found "
++ show (length payloadWords)
pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
unless (length payloadWords >= 2) $
fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
++ "found " ++ show (length payloadWords)
pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
unless (length payloadWords >= 1) $
fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
++ "found " ++ show (length payloadWords)
pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
unless (length pts >= 1) $
fail $ "Expected at least 1 words to MUT_VAR, found "
++ show (length pts)
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 rawHeapWords
WEAK ->
pure $ WeakClosure
{ info = itbl
, cfinalizers = pts !! 0
, key = pts !! 1
, value = pts !! 2
, finalizer = pts !! 3
, link = pts !! 4
}
TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
-> withArray rawHeapWords (\ptr -> do
fields <- FFIClosures.peekTSOFields decodeCCS ptr
pure $ TSOClosure
{ info = itbl
, link = u_lnk
, global_link = u_gbl_lnk
, tsoStack = tso_stack
, trec = u_trec
, blocked_exceptions = u_blk_ex
, bq = u_bq
, what_next = FFIClosures.tso_what_next fields
, why_blocked = FFIClosures.tso_why_blocked fields
, flags = FFIClosures.tso_flags fields
, threadId = FFIClosures.tso_threadId fields
, saved_errno = FFIClosures.tso_saved_errno fields
, tso_dirty = FFIClosures.tso_dirty fields
, alloc_limit = FFIClosures.tso_alloc_limit fields
, tot_stack_size = FFIClosures.tso_tot_stack_size fields
, prof = FFIClosures.tso_prof fields
})
| otherwise
-> fail $ "Expected 6 ptr arguments to TSO, found "
++ show (length pts)
STACK
| [] <- pts
-> withArray rawHeapWords (\ptr -> do
fields <- FFIClosures.peekStackFields ptr
pure $ StackClosure
{ info = itbl
, stack_size = FFIClosures.stack_size fields
, stack_dirty = FFIClosures.stack_dirty fields
#if __GLASGOW_HASKELL__ >= 811
, stack_marking = FFIClosures.stack_marking fields
#endif
})
| otherwise
-> fail $ "Expected 0 ptr argument to STACK, found "
++ show (length pts)
_ ->
pure $ UnsupportedClosure itbl
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a