{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
-- | Low-level functions for decoding a closure representation from the raw
-- bytes
module GHC.Debug.Decode ( decodeClosure
                        , decodeInfoTable
                        ) where

import GHC.Ptr (plusPtr, castPtr)
import GHC.Exts hiding (closureSize#) -- (Addr#, unsafeCoerce#, Any, Word#, ByteArray#)
import GHC.Word
import GHC.IO.Unsafe
import Foreign.Storable

import qualified Data.ByteString.Internal as BSI
import Data.ByteString.Short.Internal (ShortByteString(..), toShort)
import qualified Data.ByteString.Lazy as BSL

import GHC.Exts.Heap (GenClosure)
import GHC.Exts.Heap hiding (GenClosure(..), Closure)
import qualified GHC.Exts.Heap.InfoTable as Itbl
import qualified GHC.Exts.Heap.InfoTableProf as ItblProf

import GHC.Debug.Types.Ptr
import GHC.Debug.Types.Closures
import GHC.Debug.Decode.Convert
import Foreign.Marshal.Alloc    (allocaBytes)
import Foreign.ForeignPtr       (withForeignPtr)
import Data.Binary.Get as B
import Data.Binary
import Control.Monad
import Data.Void
import Control.DeepSeq

import qualified Data.ByteString as B

foreign import prim "unpackClosurePtrzh" unpackClosurePtr# ::
              Addr# -> (# ByteArray# #)

foreign import prim "closureSizezh" closureSize# ::
              Addr# -> (# Word# #)

getClosureRaw :: StgInfoTable -> Ptr a -> BSI.ByteString -> IO (GenClosure Word, Size)
getClosureRaw :: forall a.
StgInfoTable -> Ptr a -> ByteString -> IO (GenClosure Word, Size)
getClosureRaw StgInfoTable
itb (Ptr Addr#
closurePtr) ByteString
datString = do
  let !(# ByteArray#
pointers #) = Addr# -> (# ByteArray# #)
unpackClosurePtr# Addr#
closurePtr
      !(# Word#
raw_size_wh #) = Addr# -> (# Word# #)
closureSize# Addr#
closurePtr
      raw_size :: Int
raw_size = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word# -> Word
W# Word#
raw_size_wh) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
  -- Not strictly necessary to take the size of the raw string but its
  -- a good sanity check. In particular it helps with stack decoding.
  let !(SBS ByteArray#
datArr) = (ByteString -> ShortByteString
toShort (Int -> ByteString -> ByteString
B.take Int
raw_size ByteString
datString))
  let nelems_ptrs :: Int
nelems_ptrs = (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
pointers)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      end_ptrs :: Int
end_ptrs = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems_ptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      rawPtrs :: [Word]
rawPtrs = [Word] -> [Word]
forall a. NFData a => a -> a
force [Word# -> Word
W# (ByteArray# -> Int# -> Word#
indexWordArray# ByteArray#
pointers Int#
i) | I# Int#
i <- [Int
0.. Int
end_ptrs] ]
  GenClosure Word
gen_closure <- IO (String, String, String)
-> (Ptr Any -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [Word]
-> IO (GenClosure Word)
forall a b.
IO (String, String, String)
-> (Ptr a -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
getClosureDataFromHeapRepPrim ((String, String, String) -> IO (String, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"", String
"", String
""))
                                               (\Ptr Any
_ -> Maybe CostCentreStack -> IO (Maybe CostCentreStack)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CostCentreStack
forall a. Maybe a
Nothing) StgInfoTable
itb ByteArray#
datArr  [Word]
rawPtrs
  return (GenClosure Word
gen_closure, Int -> Size
Size Int
raw_size)

-- | Allow access directly to the chunk of memory used by a bytestring
allocate :: BSI.ByteString -> (Ptr a -> IO a) -> IO a
allocate :: forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate = ByteString -> (Ptr a -> IO a) -> IO a
forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocateByCopy


-- | Allocate a bytestring directly into memory and return a pointer to the
-- allocated buffer
allocateByCopy :: BSI.ByteString -> (Ptr a -> IO a) -> IO a
allocateByCopy :: forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocateByCopy (BSI.PS ForeignPtr Word8
fp Int
o Int
l) Ptr a -> IO a
action =
 Int -> (Ptr Word8 -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
l ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf ->
   ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
     --print (fp, o, l)
     Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BSI.memcpy Ptr Word8
buf (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
o) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
     Ptr a -> IO a
action (Ptr Word8 -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
buf)

skipClosureHeader :: Get ()
skipClosureHeader :: Get ()
skipClosureHeader
  | Bool
profiling = () () -> Get () -> Get ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Get ()
skip (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3)
  | Bool
otherwise = () () -> Get () -> Get ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Get ()
skip (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1)

decodePAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodePAPClosure :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodePAPClosure (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  Word32
carity <- Get Word32
getWord32le
  Word32
nargs <- Get Word32
getWord32le
  ClosurePtr
funp <- Get ClosurePtr
getClosurePtr
  [Word64]
cpayload <- Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nargs) Get Word64
getWord64le
  let cont :: PayloadCont
cont = ClosurePtr -> [Word64] -> PayloadCont
PayloadCont ClosurePtr
funp [Word64]
cpayload
  return $ (StgInfoTableWithPtr
-> Word32
-> Word32
-> ClosurePtr
-> PayloadCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word32 -> b -> pap -> DebugClosure pap string s b
GHC.Debug.Types.Closures.PAPClosure StgInfoTableWithPtr
infot Word32
carity Word32
nargs ClosurePtr
funp PayloadCont
cont)

decodeAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeAPClosure :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeAPClosure (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ()
_itbl <- Get ()
skipClosureHeader
  Word32
carity <- Get Word32
getWord32le
  Word32
nargs <- Get Word32
getWord32le
  ClosurePtr
funp <- Get ClosurePtr
getClosurePtr
  [Word64]
cpayload <- Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
nargs) Get Word64
getWord64le
  let cont :: PayloadCont
cont = ClosurePtr -> [Word64] -> PayloadCont
PayloadCont ClosurePtr
funp [Word64]
cpayload
  return $ (StgInfoTableWithPtr
-> Word32
-> Word32
-> ClosurePtr
-> PayloadCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word32 -> b -> pap -> DebugClosure pap string s b
GHC.Debug.Types.Closures.APClosure StgInfoTableWithPtr
infot Word32
carity Word32
nargs ClosurePtr
funp PayloadCont
cont)


decodeTVarClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeTVarClosure :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeTVarClosure (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ClosurePtr
ptr <- Get ClosurePtr
getClosurePtr
  ClosurePtr
watch_queue <- Get ClosurePtr
getClosurePtr
  Int64
updates <- Get Int64
getInt64le
  return $ (StgInfoTableWithPtr
-> ClosurePtr
-> ClosurePtr
-> Int
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr -> b -> b -> Int -> DebugClosure pap string s b
TVarClosure StgInfoTableWithPtr
infot ClosurePtr
ptr ClosurePtr
watch_queue (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
updates))

getClosurePtr :: Get ClosurePtr
getClosurePtr :: Get ClosurePtr
getClosurePtr = Get ClosurePtr
forall t. Binary t => Get t
get

getWord :: Get Word64
getWord :: Get Word64
getWord = Get Word64
getWord64le

decodeMutPrim :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeMutPrim :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeMutPrim (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  let kptrs :: Int
kptrs = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
ptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))
      kdat :: Int
kdat = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
nptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))
  [ClosurePtr]
pts <- Int -> Get ClosurePtr -> Get [ClosurePtr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
kptrs Get ClosurePtr
getClosurePtr
  [Word]
dat <- Int -> Get Word -> Get [Word]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
kdat (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Get Word64 -> Get Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le)
  return $ (StgInfoTableWithPtr
-> [ClosurePtr]
-> [Word]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr -> [b] -> [Word] -> DebugClosure pap string s b
MutPrimClosure StgInfoTableWithPtr
infot [ClosurePtr]
pts [Word]
dat)

decodeTrecChunk :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeTrecChunk :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeTrecChunk (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ClosurePtr
prev <- Get ClosurePtr
getClosurePtr
  Word64
clos_next_idx <- Get Word64
getWord64le
  [TRecEntry ClosurePtr]
chunks <- Int -> Get (TRecEntry ClosurePtr) -> Get [TRecEntry ClosurePtr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
clos_next_idx) Get (TRecEntry ClosurePtr)
getChunk
  return $ (StgInfoTableWithPtr
-> ClosurePtr
-> Word
-> [TRecEntry ClosurePtr]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> b -> Word -> [TRecEntry b] -> DebugClosure pap string s b
TRecChunkClosure StgInfoTableWithPtr
infot ClosurePtr
prev (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
clos_next_idx) [TRecEntry ClosurePtr]
chunks)
  where
    getChunk :: Get (TRecEntry ClosurePtr)
getChunk = do
      ClosurePtr
-> ClosurePtr -> ClosurePtr -> Int -> TRecEntry ClosurePtr
forall b. b -> b -> b -> Int -> TRecEntry b
TRecEntry (ClosurePtr
 -> ClosurePtr -> ClosurePtr -> Int -> TRecEntry ClosurePtr)
-> Get ClosurePtr
-> Get (ClosurePtr -> ClosurePtr -> Int -> TRecEntry ClosurePtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ClosurePtr
getClosurePtr
                Get (ClosurePtr -> ClosurePtr -> Int -> TRecEntry ClosurePtr)
-> Get ClosurePtr
-> Get (ClosurePtr -> Int -> TRecEntry ClosurePtr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ClosurePtr
getClosurePtr
                Get (ClosurePtr -> Int -> TRecEntry ClosurePtr)
-> Get ClosurePtr -> Get (Int -> TRecEntry ClosurePtr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ClosurePtr
getClosurePtr
                Get (Int -> TRecEntry ClosurePtr)
-> Get Int -> Get (TRecEntry ClosurePtr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Get Int64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64le) -- TODO: num_updates field is wrong
                                                  -- Not sure how it should
                                                  -- be decoded

decodeBlockingQueue :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeBlockingQueue :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeBlockingQueue (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ClosurePtr
q <- Get ClosurePtr
getClosurePtr
  ClosurePtr
bh <- Get ClosurePtr
getClosurePtr
  ClosurePtr
tso <- Get ClosurePtr
getClosurePtr
  ClosurePtr
bh_q <- Get ClosurePtr
getClosurePtr
  return $ (StgInfoTableWithPtr
-> ClosurePtr
-> ClosurePtr
-> ClosurePtr
-> ClosurePtr
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> b -> b -> b -> b -> DebugClosure pap string s b
GHC.Debug.Types.Closures.BlockingQueueClosure StgInfoTableWithPtr
infot ClosurePtr
q ClosurePtr
bh ClosurePtr
tso ClosurePtr
bh_q)

-- It is just far simpler to directly decode the stack here rather than use
-- the existing logic in ghc-heap......
decodeStack :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeStack :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeStack (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
cp, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
   ()
_itbl <- Get ()
skipClosureHeader
   Word32
st_size <- Get Word32
getWord32le
   Word8
st_dirty <- Get Word8
getWord8
   Word8
st_marking <- Get Word8
getWord8
   -- Up to now, 14 bytes are read, skip 2 to get to 16/start of
   -- sp field
   Int -> Get ()
skip Int
2
   StackPtr
st_sp <- Word64 -> StackPtr
StackPtr (Word64 -> StackPtr) -> Get Word64 -> Get StackPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord
   Int64
stackHeaderSize <- Get Int64
bytesRead
   let stack_offset :: Int
stack_offset = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StackPtr -> ClosurePtr -> Word64
subtractStackPtr StackPtr
st_sp ClosurePtr
cp)
             -- -stackHeaderSize for the bytes already read
             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
stackHeaderSize
       len :: Word64
len = Word32 -> Word64 -> ClosurePtr -> StackPtr -> Word64
calculateStackLen Word32
st_size (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
stackHeaderSize) ClosurePtr
cp StackPtr
st_sp
   -- Skip to start of stack frames
   Int -> Get ()
skip Int
stack_offset
   -- Read the raw frames, we can't decode them yet because we
   -- need to query the debuggee for the bitmaps
   RawStack
raw_stack <- ByteString -> RawStack
RawStack (ByteString -> RawStack) -> Get ByteString -> Get RawStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
len)
   return (StgInfoTableWithPtr
-> Word32
-> Word8
-> Word8
-> StackCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word8 -> Word8 -> s -> DebugClosure pap string s b
GHC.Debug.Types.Closures.StackClosure
            StgInfoTableWithPtr
infot
            Word32
st_size
            Word8
st_dirty
            Word8
st_marking
            (StackPtr -> RawStack -> StackCont
StackCont StackPtr
st_sp RawStack
raw_stack))

decodeFromBS :: RawClosure -> Get (DebugClosure pap string s b)
                           -> DebugClosureWithExtra Size pap string s b
decodeFromBS :: forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS (RawClosure ByteString
rc) Get (DebugClosure pap string s b)
parser =
  case Get (DebugClosure pap string s b)
-> ByteString
-> Either
     (ByteString, Int64, String)
     (ByteString, Int64, DebugClosure pap string s b)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail Get (DebugClosure pap string s b)
parser (ByteString -> ByteString
BSL.fromStrict ByteString
rc) of
    Left (ByteString, Int64, String)
err -> String -> DebugClosureWithExtra Size pap string s b
forall a. HasCallStack => String -> a
error (String
"DEC:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ByteString, Int64, String) -> String
forall a. Show a => a -> String
show (ByteString, Int64, String)
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ HasCallStack => ByteString -> String
ByteString -> String
printBS ByteString
rc)
    Right (ByteString
_rem, Int64
o, DebugClosure pap string s b
v) ->
      let !s :: Int
s = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
o
      in Size
-> DebugClosure pap string s b
-> DebugClosureWithExtra Size pap string s b
forall x pap string s b.
x
-> DebugClosure pap string s b
-> DebugClosureWithExtra x pap string s b
DCS (Int -> Size
Size Int
s) DebugClosure pap string s b
v

decodeAPStack :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeAPStack :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeAPStack (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr Word64
cp, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ()
_itbl <- Get ()
skipClosureHeader
  Word64
st_size <- Get Word64
getWord
  ClosurePtr
fun_closure <- Get ClosurePtr
getClosurePtr
  Int64
k <- Get Int64
bytesRead
  let sp :: StackPtr
sp = StackPtr -> Word64 -> StackPtr
addStackPtr (Word64 -> StackPtr
StackPtr Word64
cp) (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
k)
  RawStack
clos_payload <- ByteString -> RawStack
RawStack (ByteString -> RawStack) -> Get ByteString -> Get RawStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
st_size)
  return $ StgInfoTableWithPtr
-> Word
-> ClosurePtr
-> StackCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> Word -> b -> s -> DebugClosure pap string s b
GHC.Debug.Types.Closures.APStackClosure
              StgInfoTableWithPtr
infot
              (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
st_size)
              ClosurePtr
fun_closure
              (StackPtr -> RawStack -> StackCont
StackCont StackPtr
sp RawStack
clos_payload)

decodeStandardLayout :: Get ()
                     -> ([ClosurePtr] -> [Word] -> Closure)
                     -> (StgInfoTableWithPtr, RawInfoTable)
                     -> (ClosurePtr, RawClosure)
                     -> SizedClosure
decodeStandardLayout :: Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout Get ()
extra [ClosurePtr]
-> [Word]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
k (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = RawClosure
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall pap string s b.
RawClosure
-> Get (DebugClosure pap string s b)
-> DebugClosureWithExtra Size pap string s b
decodeFromBS RawClosure
rc (Get (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
 -> SizedClosure)
-> Get
     (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  -- For the THUNK header
  Get ()
extra
  [ClosurePtr]
pts <- Int -> Get ClosurePtr -> Get [ClosurePtr]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
ptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))) Get ClosurePtr
getClosurePtr
  [Word64]
cwords <- Int -> Get Word64 -> Get [Word64]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
nptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))) Get Word64
getWord
  return $ [ClosurePtr]
-> [Word]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
k [ClosurePtr]
pts ((Word64 -> Word) -> [Word64] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
cwords)

decodeClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure
decodeClosure :: (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeClosure i :: (StgInfoTableWithPtr, RawInfoTable)
i@(StgInfoTableWithPtr
itb, RawInfoTable
_) (ClosurePtr, RawClosure)
c
  -- MP: It was far easier to implement the decoding of these closures in
  -- ghc-heap using binary rather than patching GHC and going through that
  -- dance. I think in the future it's better to do this for all the
  -- closures... it's simpler and probably much faster.
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
PAP }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodePAPClosure (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
AP }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeAPClosure (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
TVAR }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeTVarClosure (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
MUT_PRIM }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeMutPrim (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
TREC_CHUNK }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeTrecChunk (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
BLOCKING_QUEUE }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeBlockingQueue (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
STACK }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeStack (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
AP_STACK }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeAPStack (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
CONSTR ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_0_2 =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (() -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\[ClosurePtr]
pts [Word]
ws -> StgInfoTableWithPtr
-> [ClosurePtr]
-> [Word]
-> ConstrDescCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> [b] -> [Word] -> string -> DebugClosure pap string s b
ConstrClosure StgInfoTableWithPtr
itb [ClosurePtr]
pts [Word]
ws (StgInfoTableWithPtr -> ConstrDescCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
CONSTR ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_NOCAF =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (() -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\[ClosurePtr]
pts [Word]
ws -> StgInfoTableWithPtr
-> [ClosurePtr]
-> [Word]
-> ConstrDescCont
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr
-> [b] -> [Word] -> string -> DebugClosure pap string s b
ConstrClosure StgInfoTableWithPtr
itb [ClosurePtr]
pts [Word]
ws (StgInfoTableWithPtr -> ConstrDescCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
FUN ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
FUN_STATIC =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (() -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (StgInfoTableWithPtr
-> [ClosurePtr]
-> [Word]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr -> [b] -> [Word] -> DebugClosure pap string s b
FunClosure StgInfoTableWithPtr
itb) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
THUNK ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
THUNK_0_2 =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (() () -> Get Word64 -> Get ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Get Word64
getWord) (StgInfoTableWithPtr
-> [ClosurePtr]
-> [Word]
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
StgInfoTableWithPtr -> [b] -> [Word] -> DebugClosure pap string s b
ThunkClosure StgInfoTableWithPtr
itb) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
decodeClosure (StgInfoTableWithPtr
itb, RawInfoTable ByteString
rit) (ClosurePtr
_, (RawClosure ByteString
clos)) = IO SizedClosure -> SizedClosure
forall a. IO a -> a
unsafePerformIO (IO SizedClosure -> SizedClosure)
-> IO SizedClosure -> SizedClosure
forall a b. (a -> b) -> a -> b
$ do
    ByteString
-> (Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure
forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
rit ((Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure)
-> (Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure
forall a b. (a -> b) -> a -> b
$ \Ptr SizedClosure
itblPtr -> do
      ByteString
-> (Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure
forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
clos ((Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure)
-> (Ptr SizedClosure -> IO SizedClosure) -> IO SizedClosure
forall a b. (a -> b) -> a -> b
$ \Ptr SizedClosure
closPtr -> do
        let ptr_to_itbl_ptr :: Ptr (Ptr StgInfoTable)
            ptr_to_itbl_ptr :: Ptr (Ptr StgInfoTable)
ptr_to_itbl_ptr = Ptr SizedClosure -> Ptr (Ptr StgInfoTable)
forall a b. Ptr a -> Ptr b
castPtr Ptr SizedClosure
closPtr
        -- The pointer is to the end of the info table (not the start)
        -- Info table is two words long which is why we subtract 16 from
        -- the pointer
        --print (itblPtr, closPtr)
        Ptr (Ptr StgInfoTable) -> Ptr StgInfoTable -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr StgInfoTable)
ptr_to_itbl_ptr (Ptr SizedClosure -> Ptr StgInfoTable
forall a. Ptr a -> Ptr StgInfoTable
fixTNTC Ptr SizedClosure
itblPtr)
        -- You should be able to print these addresses in gdb
        -- and observe the memory layout is identical to the debugee
        -- process
        -- Printing this return value can lead to segfaults because the
        -- pointer for constrDesc won't point to a string after being
        -- decoded.
        --print (tipe (decodedTable itb), ptr, closPtr, itblPtr)
        (!GenClosure Word
r, !Size
s) <- StgInfoTable
-> Ptr SizedClosure -> ByteString -> IO (GenClosure Word, Size)
forall a.
StgInfoTable -> Ptr a -> ByteString -> IO (GenClosure Word, Size)
getClosureRaw (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb) Ptr SizedClosure
closPtr ByteString
clos
        -- Mutate back the ByteArray as if we attempt to use it again then
        -- the itbl pointer will point somewhere into our address space
        -- rather than the debuggee address space
        --
        return $ Size
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
-> SizedClosure
forall x pap string s b.
x
-> DebugClosure pap string s b
-> DebugClosureWithExtra x pap string s b
DCS Size
s (DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
 -> SizedClosure)
-> (GenClosure Word64
    -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> GenClosure Word64
-> SizedClosure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Void -> PayloadCont)
-> (ConstrDescCont -> ConstrDescCont)
-> (Void -> StackCont)
-> (Word64 -> ClosurePtr)
-> DebugClosure Void ConstrDescCont Void Word64
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall a b c d e f g h (t :: * -> * -> * -> * -> *).
Quadtraversable t =>
(a -> b)
-> (c -> d) -> (e -> f) -> (g -> h) -> t a c e g -> t b d f h
quadmap Void -> PayloadCont
forall a. Void -> a
absurd
                        ConstrDescCont -> ConstrDescCont
forall a. a -> a
id
                        Void -> StackCont
forall a. Void -> a
absurd
                        Word64 -> ClosurePtr
mkClosurePtr (DebugClosure Void ConstrDescCont Void Word64
 -> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr)
-> (GenClosure Word64
    -> DebugClosure Void ConstrDescCont Void Word64)
-> GenClosure Word64
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgInfoTableWithPtr
-> GenClosure Word64
-> DebugClosure Void ConstrDescCont Void Word64
forall a.
(Num a, Eq a, Show a) =>
StgInfoTableWithPtr
-> GenClosure a -> DebugClosure Void ConstrDescCont Void a
convertClosure StgInfoTableWithPtr
itb
          (GenClosure Word64 -> SizedClosure)
-> GenClosure Word64 -> SizedClosure
forall a b. (a -> b) -> a -> b
$ (Word -> Word64) -> GenClosure Word -> GenClosure Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Word64) GenClosure Word
r


fixTNTC :: Ptr a -> Ptr StgInfoTable
fixTNTC :: forall a. Ptr a -> Ptr StgInfoTable
fixTNTC Ptr a
ptr
  | Bool
tablesNextToCode = Ptr Any -> Ptr StgInfoTable
forall a b. Ptr a -> Ptr b
castPtr (Ptr Any -> Ptr StgInfoTable) -> Ptr Any -> Ptr StgInfoTable
forall a b. (a -> b) -> a -> b
$ Ptr a
ptr  Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
realItblSize
  | Bool
otherwise        = Ptr a -> Ptr StgInfoTable
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Ptr StgInfoTable) -> Ptr a -> Ptr StgInfoTable
forall a b. (a -> b) -> a -> b
$ Ptr a
ptr

realItblSize :: Int
realItblSize :: Int
realItblSize
  | Bool
profiling  = Int
ItblProf.itblSize
  | Bool
otherwise  = Int
Itbl.itblSize

decodeInfoTable :: RawInfoTable -> StgInfoTable
decodeInfoTable :: RawInfoTable -> StgInfoTable
decodeInfoTable (RawInfoTable ByteString
itbl) = IO StgInfoTable -> StgInfoTable
forall a. IO a -> a
unsafePerformIO (IO StgInfoTable -> StgInfoTable)
-> IO StgInfoTable -> StgInfoTable
forall a b. (a -> b) -> a -> b
$ do
  ByteString
-> (Ptr StgInfoTable -> IO StgInfoTable) -> IO StgInfoTable
forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
itbl ((Ptr StgInfoTable -> IO StgInfoTable) -> IO StgInfoTable)
-> (Ptr StgInfoTable -> IO StgInfoTable) -> IO StgInfoTable
forall a b. (a -> b) -> a -> b
$ \Ptr StgInfoTable
itblPtr -> do
    Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
itblPtr