{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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.Version
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 GHC.Exts.Heap.FFIClosures

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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word# -> Word
W# Word#
raw_size_wh) 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)) forall a. Integral a => a -> a -> a
`div` Int
8
      end_ptrs :: Int
end_ptrs = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems_ptrs forall a. Num a => a -> a -> a
- Int
1
      rawPtrs :: [Word]
rawPtrs = 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 <- forall a b.
IO (String, String, String)
-> (Ptr a -> IO (Maybe CostCentreStack))
-> StgInfoTable
-> ByteArray#
-> [b]
-> IO (GenClosure b)
getClosureDataFromHeapRepPrim (forall (m :: * -> *) a. Monad m => a -> m a
return (String
"", String
"", String
""))
                                               (\Ptr Any
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 =
 forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
l forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf ->
   forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp 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 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
o) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
     Ptr a -> IO a
action (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
buf)

skipClosureHeader :: Get ()
skipClosureHeader :: Get ()
skipClosureHeader
  | Bool
profiling = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Get ()
skip (Int
8 forall a. Num a => a -> a -> a
* Int
3)
  | Bool
otherwise = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int -> Get ()
skip (Int
8 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (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 $ (forall srt pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word32 -> b -> pap -> DebugClosure srt 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (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 $ (forall srt pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word32 -> b -> pap -> DebugClosure srt 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 $ (forall srt pap string s b.
StgInfoTableWithPtr
-> b -> b -> Int -> DebugClosure srt pap string s b
TVarClosure StgInfoTableWithPtr
infot ClosurePtr
ptr ClosurePtr
watch_queue (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
updates))

getClosurePtr :: Get ClosurePtr
getClosurePtr :: Get ClosurePtr
getClosurePtr = 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  let kptrs :: Int
kptrs = forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
ptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))
      kdat :: Int
kdat = forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
nptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))
  [ClosurePtr]
pts <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
kptrs Get ClosurePtr
getClosurePtr
  [Word]
dat <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
kdat (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le)
  return $ (forall srt pap string s b.
StgInfoTableWithPtr
-> [b] -> [Word] -> DebugClosure srt 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
clos_next_idx) Get (TRecEntry ClosurePtr)
getChunk
  return $ (forall srt pap string s b.
StgInfoTableWithPtr
-> b -> Word -> [TRecEntry b] -> DebugClosure srt pap string s b
TRecChunkClosure StgInfoTableWithPtr
infot ClosurePtr
prev (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
clos_next_idx) [TRecEntry ClosurePtr]
chunks)
  where
    getChunk :: Get (TRecEntry ClosurePtr)
getChunk = do
      forall b. b -> b -> b -> Int -> TRecEntry b
TRecEntry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ClosurePtr
getClosurePtr
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ClosurePtr
getClosurePtr
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ClosurePtr
getClosurePtr
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 $ (forall srt pap string s b.
StgInfoTableWithPtr
-> b -> b -> b -> b -> DebugClosure srt 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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 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 = 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
             forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
stackHeaderSize
       len :: Word64
len = Word32 -> Word64 -> ClosurePtr -> StackPtr -> Word64
calculateStackLen Word32
st_size (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
len)
   return (forall srt pap string s b.
StgInfoTableWithPtr
-> Word32 -> Word8 -> Word8 -> s -> DebugClosure srt 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 srt pap string s b)
                           -> DebugClosureWithExtra Size srt pap string s b
decodeFromBS :: forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS (RawClosure ByteString
rc) Get (DebugClosure srt pap string s b)
parser =
  case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail Get (DebugClosure srt pap string s b)
parser (ByteString -> ByteString
BSL.fromStrict ByteString
rc) of
    Left (ByteString, Int64, String)
err -> forall a. HasCallStack => String -> a
error (String
"DEC:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString, Int64, String)
err forall a. [a] -> [a] -> [a]
++ HasCallStack => ByteString -> String
printBS ByteString
rc)
    Right (ByteString
_rem, Int64
o, DebugClosure srt pap string s b
v) ->
      let !s :: Int
s = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
o
      in forall x srt pap string s b.
x
-> DebugClosure srt pap string s b
-> DebugClosureWithExtra x srt pap string s b
DCS (Int -> Size
Size Int
s) DebugClosure srt 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) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc 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) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
k)
  RawStack
clos_payload <- ByteString -> RawStack
RawStack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
st_size)
  return $ forall srt pap string s b.
StgInfoTableWithPtr
-> Word -> b -> s -> DebugClosure srt pap string s b
GHC.Debug.Types.Closures.APStackClosure
              StgInfoTableWithPtr
infot
              (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 SrtCont PayloadCont SrtCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout Get ()
extra [ClosurePtr]
-> [Word]
-> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
k (StgInfoTableWithPtr
infot, RawInfoTable
_) (ClosurePtr
_, RawClosure
rc) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  -- For the THUNK header
  Get ()
extra
  [ClosurePtr]
pts <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral (StgInfoTable -> Word32
ptrs (StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
infot))) Get ClosurePtr
getClosurePtr
  [Word64]
cwords <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (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 SrtCont PayloadCont SrtCont StackCont ClosurePtr
k [ClosurePtr]
pts (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
cwords)

decodeArrWords :: (StgInfoTableWithPtr, b)
               -> (a, RawClosure) -> DebugClosureWithExtra Size src pap string s b1
decodeArrWords :: forall b a src pap string s b1.
(StgInfoTableWithPtr, b)
-> (a, RawClosure)
-> DebugClosureWithExtra Size src pap string s b1
decodeArrWords  (StgInfoTableWithPtr
infot, b
_) (a
_, RawClosure
rc) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  Word64
bytes <- Get Word64
getWord64le
  [Word64]
payload <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
bytes forall a. Integral a => a -> a -> a
`ceilIntDiv` Word64
8) Get Word64
getWord
  return $ forall srt pap string s b.
StgInfoTableWithPtr
-> Word -> [Word] -> DebugClosure srt pap string s b
GHC.Debug.Types.Closures.ArrWordsClosure StgInfoTableWithPtr
infot (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bytes) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
payload)

-- | Compute @ceiling (a/b)@.
ceilIntDiv :: Integral a => a -> a -> a
ceilIntDiv :: forall a. Integral a => a -> a -> a
ceilIntDiv a
a a
b = (a
a forall a. Num a => a -> a -> a
+ a
b forall a. Num a => a -> a -> a
- a
1) forall a. Integral a => a -> a -> a
`div` a
b

tsoVersionChanged :: Version
tsoVersionChanged :: Version
tsoVersionChanged = Word32 -> Word32 -> Version
Version Word32
905 Word32
20220925

decodeTSO :: Version
          -> (StgInfoTableWithPtr, RawInfoTable)
          -> (a, RawClosure)
          -> SizedClosure
decodeTSO :: forall a.
Version
-> (StgInfoTableWithPtr, RawInfoTable)
-> (a, RawClosure)
-> SizedClosure
decodeTSO Version
ver (StgInfoTableWithPtr
infot, RawInfoTable
_) (a
_, RawClosure
rc) = forall srt pap string s b.
RawClosure
-> Get (DebugClosure srt pap string s b)
-> DebugClosureWithExtra Size srt pap string s b
decodeFromBS RawClosure
rc forall a b. (a -> b) -> a -> b
$ do
  ()
_itbl <- Get ()
skipClosureHeader
  ClosurePtr
link <- Get ClosurePtr
getClosurePtr
  ClosurePtr
global_link <- Get ClosurePtr
getClosurePtr
  ClosurePtr
tsoStack <- Get ClosurePtr
getClosurePtr
  WhatNext
what_next <- Word16 -> WhatNext
parseWhatNext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le
  WhyBlocked
why_blocked <- Word16 -> WhyBlocked
parseWhyBlocked forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16le
  [TsoFlags]
flags <- Word32 -> [TsoFlags]
parseTsoFlags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le
  ClosurePtr
_block_info <- Get ClosurePtr
getClosurePtr
  Word64
threadId <- Get Word64
getWord64le
  Word32
saved_errno <- Get Word32
getWord32le
  Word32
dirty       <- Get Word32
getWord32le

  ClosurePtr
_bound       <- Get ClosurePtr
getClosurePtr
  ClosurePtr
_cap         <- Get ClosurePtr
getClosurePtr
  ClosurePtr
trec           <- Get ClosurePtr
getClosurePtr
  Maybe ClosurePtr
threadLabel <-
    if Version
ver forall a. Ord a => a -> a -> Bool
>= Version
tsoVersionChanged
      then do
        ClosurePtr
thread_label <- Get ClosurePtr
getClosurePtr
        return $ if ClosurePtr
thread_label forall a. Eq a => a -> a -> Bool
== Word64 -> ClosurePtr
mkClosurePtr Word64
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ClosurePtr
thread_label
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  ClosurePtr
blocked_exceptions <- Get ClosurePtr
getClosurePtr
  ClosurePtr
bq             <- Get ClosurePtr
getClosurePtr
  Int64
alloc_limit    <- Get Int64
getInt64le
  Word32
tot_stack_size <- Get Word32
getWord32le
  let DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
res :: Closure = (GHC.Debug.Types.Closures.TSOClosure
            { info :: StgInfoTableWithPtr
info = StgInfoTableWithPtr
infot
            , _link :: ClosurePtr
_link = ClosurePtr
link
            , prof :: Maybe StgTSOProfInfo
prof = forall a. Maybe a
Nothing
            , Int64
[TsoFlags]
Maybe ClosurePtr
Word32
Word64
WhyBlocked
WhatNext
ClosurePtr
tot_stack_size :: Word32
alloc_limit :: Int64
dirty :: Word32
saved_errno :: Word32
threadId :: Word64
flags :: [TsoFlags]
why_blocked :: WhyBlocked
what_next :: WhatNext
threadLabel :: Maybe ClosurePtr
bq :: ClosurePtr
blocked_exceptions :: ClosurePtr
trec :: ClosurePtr
tsoStack :: ClosurePtr
global_link :: ClosurePtr
tot_stack_size :: Word32
alloc_limit :: Int64
bq :: ClosurePtr
blocked_exceptions :: ClosurePtr
threadLabel :: Maybe ClosurePtr
trec :: ClosurePtr
dirty :: Word32
saved_errno :: Word32
threadId :: Word64
flags :: [TsoFlags]
why_blocked :: WhyBlocked
what_next :: WhatNext
tsoStack :: ClosurePtr
global_link :: ClosurePtr
.. })
  return DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
res





decodeClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure
decodeClosure :: Version
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeClosure Version
ver 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.
--  | traceShow itb False = undefined
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ARR_WORDS }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = forall b a src pap string s b1.
(StgInfoTableWithPtr, b)
-> (a, RawClosure)
-> DebugClosureWithExtra Size src pap string s b1
decodeArrWords (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (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
TSO }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb = forall a.
Version
-> (StgInfoTableWithPtr, RawInfoTable)
-> (a, RawClosure)
-> SizedClosure
decodeTSO Version
ver (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 forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_0_2 =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\[ClosurePtr]
pts [Word]
ws -> forall srt pap string s b.
StgInfoTableWithPtr
-> [b] -> [Word] -> string -> DebugClosure srt pap string s b
ConstrClosure StgInfoTableWithPtr
itb [ClosurePtr]
pts [Word]
ws (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
CONSTR forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_NOCAF =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\[ClosurePtr]
pts [Word]
ws -> forall srt pap string s b.
StgInfoTableWithPtr
-> [b] -> [Word] -> string -> DebugClosure srt pap string s b
ConstrClosure StgInfoTableWithPtr
itb [ClosurePtr]
pts [Word]
ws (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
FUN forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty forall a. Ord a => a -> a -> Bool
<= ClosureType
FUN_STATIC =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall srt pap string s b.
StgInfoTableWithPtr
-> srt -> [b] -> [Word] -> DebugClosure srt pap string s b
FunClosure StgInfoTableWithPtr
itb (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
  | (StgInfoTable { tipe :: StgInfoTable -> ClosureType
tipe = ClosureType
ty }) <- StgInfoTableWithPtr -> StgInfoTable
decodedTable StgInfoTableWithPtr
itb
  , ClosureType
THUNK forall a. Ord a => a -> a -> Bool
<= ClosureType
ty Bool -> Bool -> Bool
&& ClosureType
ty forall a. Ord a => a -> a -> Bool
<= ClosureType
THUNK_0_2 =
      Get ()
-> ([ClosurePtr]
    -> [Word]
    -> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr)
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
decodeStandardLayout (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Get Word64
getWord) (forall srt pap string s b.
StgInfoTableWithPtr
-> srt -> [b] -> [Word] -> DebugClosure srt pap string s b
ThunkClosure StgInfoTableWithPtr
itb (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itb)) (StgInfoTableWithPtr, RawInfoTable)
i (ClosurePtr, RawClosure)
c
decodeClosure Version
_ (StgInfoTableWithPtr, RawInfoTable)
rit (ClosurePtr, RawClosure)
rc =
  forall a.
(StgInfoTableWithPtr, RawInfoTable)
-> (a, RawClosure) -> SizedClosure
decodeWithLibrary (StgInfoTableWithPtr, RawInfoTable)
rit (ClosurePtr, RawClosure)
rc


decodeWithLibrary :: (StgInfoTableWithPtr, RawInfoTable)
                      -> (a, RawClosure)
                      -> SizedClosure
decodeWithLibrary :: forall a.
(StgInfoTableWithPtr, RawInfoTable)
-> (a, RawClosure) -> SizedClosure
decodeWithLibrary (StgInfoTableWithPtr
itb, RawInfoTable ByteString
rit) (a
_, (RawClosure ByteString
clos)) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
rit forall a b. (a -> b) -> a -> b
$ \Ptr SizedClosure
itblPtr -> do
      forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
clos 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 = 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)
        forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr StgInfoTable)
ptr_to_itbl_ptr (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) <- 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 $ forall x srt pap string s b.
x
-> DebugClosure srt pap string s b
-> DebugClosureWithExtra x srt pap string s b
DCS Size
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c d e f g h i j (t :: * -> * -> * -> * -> * -> *).
Quintraversable t =>
(a -> b)
-> (c -> d)
-> (e -> f)
-> (g -> h)
-> (i -> j)
-> t a c e g i
-> t b d f h j
quinmap forall a. a -> a
id forall a. Void -> a
absurd
                        forall a. a -> a
id
                        forall a. Void -> a
absurd
                        Word64 -> ClosurePtr
mkClosurePtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Num a, Eq a, Show a) =>
StgInfoTableWithPtr
-> GenClosure a -> DebugClosure SrtCont Void SrtCont Void a
convertClosure StgInfoTableWithPtr
itb
          forall a b. (a -> b) -> a -> b
$ 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 = forall a b. Ptr a -> Ptr b
castPtr forall a b. (a -> b) -> a -> b
$ Ptr a
ptr  forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
realItblSize
  | Bool
otherwise        = forall a b. Ptr a -> Ptr b
castPtr 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) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  forall a. ByteString -> (Ptr a -> IO a) -> IO a
allocate ByteString
itbl forall a b. (a -> b) -> a -> b
$ \Ptr StgInfoTable
itblPtr -> do
    Ptr StgInfoTable -> IO StgInfoTable
peekItbl Ptr StgInfoTable
itblPtr