{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
module GHC.Debug.Client.Query
(
pause
, fork
, pauseThen
, resume
, pausePoll
, withPause
, precacheBlocks
, gcRoots
, allBlocks
, getSourceInfo
, savedObjects
, requestCCSMain
, version
, dereferenceClosures
, dereferenceClosure
, dereferenceClosureDirect
, dereferenceClosureC
, dereferenceToClosurePtr
, addConstrDesc
, dereferenceStack
, dereferencePapPayload
, dereferenceConDesc
, dereferenceInfoTable
, dereferenceSRT
, dereferenceCCS
, dereferenceCCSDirect
, dereferenceCC
, dereferenceIndexTable
, dereferenceIndexTableDirect
) where
import Control.Exception
import GHC.Debug.Types
import qualified GHC.Debug.Decode as D
import GHC.Debug.Decode.Stack
import GHC.Debug.Client.Monad
import GHC.Debug.Client.BlockCache
import Control.Monad.State
import Debug.Trace
pause :: Debuggee -> IO ()
pause :: Debuggee -> IO ()
pause Debuggee
e = do
Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ForkOrPause -> Request ()
RequestPause ForkOrPause
Pause)
fork :: Debuggee -> IO ()
fork :: Debuggee -> IO ()
fork Debuggee
e = do
Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ForkOrPause -> Request ()
RequestPause ForkOrPause
Fork)
resume :: Debuggee -> IO ()
resume :: Debuggee -> IO ()
resume Debuggee
e = Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request ()
RequestResume
pausePoll :: Debuggee -> IO ()
pausePoll :: Debuggee -> IO ()
pausePoll Debuggee
e = do
Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request ()
RequestPoll
withPause :: Debuggee -> IO a -> IO a
withPause :: forall a. Debuggee -> IO a -> IO a
withPause Debuggee
dbg IO a
act = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Debuggee -> IO ()
pause Debuggee
dbg) (Debuggee -> IO ()
resume Debuggee
dbg) IO a
act
lookupInfoTable :: RawClosure -> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
lookupInfoTable :: RawClosure
-> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
lookupInfoTable RawClosure
rc = do
let ptr :: ConstrDescCont
ptr = HasCallStack => RawClosure -> ConstrDescCont
RawClosure -> ConstrDescCont
getInfoTblPtr RawClosure
rc
RawInfoTable
rit <- Request RawInfoTable -> DebugM RawInfoTable
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request RawInfoTable
RequestInfoTable ConstrDescCont
ptr)
Version
ver <- DebugM Version
version
let !it :: StgInfoTable
it = Version -> RawInfoTable -> StgInfoTable
D.decodeInfoTable Version
ver RawInfoTable
rit
(StgInfoTableWithPtr, RawInfoTable, RawClosure)
-> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (ConstrDescCont -> StgInfoTable -> StgInfoTableWithPtr
StgInfoTableWithPtr ConstrDescCont
ptr StgInfoTable
it,RawInfoTable
rit, RawClosure
rc)
pauseThen :: Debuggee -> DebugM b -> IO b
pauseThen :: forall a. Debuggee -> DebugM a -> IO a
pauseThen Debuggee
e DebugM b
d =
Debuggee -> IO ()
pause Debuggee
e IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Debuggee -> DebugM b -> IO b
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e DebugM b
d
dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC
dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC
dereferenceClosureC ClosurePtr
cp = SizedClosure -> DebugM SizedClosureC
addConstrDesc (SizedClosure -> DebugM SizedClosureC)
-> DebugM SizedClosure -> DebugM SizedClosureC
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
addConstrDesc :: SizedClosure -> DebugM SizedClosureC
addConstrDesc :: SizedClosure -> DebugM SizedClosureC
addConstrDesc SizedClosure
c =
(CCSPtr -> DebugM CCSPtr)
-> (ConstrDescCont -> DebugM ConstrDescCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM SizedClosureC
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDescCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
c
dereferenceToClosurePtr :: SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr :: SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr SizedClosure
c = do
(CCSPtr -> DebugM CCSPtr)
-> (ConstrDescCont -> DebugM SrtPayload)
-> (PayloadCont -> DebugM PapPayload)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM SizedClosureP
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM SrtPayload
dereferenceSRT PayloadCont -> DebugM PapPayload
dereferencePapPayload ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
c
dereferenceClosureDirect :: ClosurePtr -> DebugM SizedClosure
dereferenceClosureDirect :: ClosurePtr -> DebugM SizedClosure
dereferenceClosureDirect ClosurePtr
c = do
RawClosure
raw_c <- Request RawClosure -> DebugM RawClosure
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ClosurePtr -> Request RawClosure
RequestClosure ClosurePtr
c)
let it :: ConstrDescCont
it = HasCallStack => RawClosure -> ConstrDescCont
RawClosure -> ConstrDescCont
getInfoTblPtr RawClosure
raw_c
RawInfoTable
raw_it <- Request RawInfoTable -> DebugM RawInfoTable
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request RawInfoTable
RequestInfoTable ConstrDescCont
it)
(ConstrDescCont, RawInfoTable)
-> (ClosurePtr, RawClosure) -> DebugM SizedClosure
decodeClosure (ConstrDescCont
it, RawInfoTable
raw_it) (ClosurePtr
c, RawClosure
raw_c)
decodeClosure :: (InfoTablePtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> DebugM SizedClosure
decodeClosure :: (ConstrDescCont, RawInfoTable)
-> (ClosurePtr, RawClosure) -> DebugM SizedClosure
decodeClosure (ConstrDescCont
itp, RawInfoTable
raw_it) (ClosurePtr, RawClosure)
c = do
Version
ver <- DebugM Version
version
let !it :: StgInfoTable
it = Version -> RawInfoTable -> StgInfoTable
D.decodeInfoTable Version
ver RawInfoTable
raw_it
SizedClosure -> DebugM SizedClosure
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (SizedClosure -> DebugM SizedClosure)
-> SizedClosure -> DebugM SizedClosure
forall a b. (a -> b) -> a -> b
$ Version
-> (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure)
-> SizedClosure
D.decodeClosure Version
ver (ConstrDescCont -> StgInfoTable -> StgInfoTableWithPtr
StgInfoTableWithPtr ConstrDescCont
itp StgInfoTable
it, RawInfoTable
raw_it) (ClosurePtr, RawClosure)
c
dereferenceClosures :: [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures :: [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
cs = (ClosurePtr -> DebugM SizedClosure)
-> [ClosurePtr] -> DebugM [SizedClosure]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ClosurePtr -> DebugM SizedClosure
dereferenceClosure [ClosurePtr]
cs
dereferenceStack :: StackCont -> DebugM StackFrames
dereferenceStack :: StackCont -> DebugM StackFrames
dereferenceStack (StackCont StackPtr
sp RawStack
stack) = do
let get_bitmap :: Word32 -> DebugM PtrBitmap
get_bitmap Word32
o = Request PtrBitmap -> DebugM PtrBitmap
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (StackPtr -> Word32 -> Request PtrBitmap
RequestStackBitmap StackPtr
sp Word32
o)
get_info_table :: RawClosure -> DebugM StgInfoTableWithPtr
get_info_table RawClosure
rc = (\(StgInfoTableWithPtr
a, RawInfoTable
_, RawClosure
_) -> StgInfoTableWithPtr
a) ((StgInfoTableWithPtr, RawInfoTable, RawClosure)
-> StgInfoTableWithPtr)
-> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
-> DebugM StgInfoTableWithPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawClosure
-> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
lookupInfoTable RawClosure
rc
(RawClosure -> DebugM StgInfoTableWithPtr)
-> (Word32 -> DebugM PtrBitmap) -> RawStack -> DebugM StackFrames
forall (m :: * -> *).
Monad m =>
(RawClosure -> m StgInfoTableWithPtr)
-> (Word32 -> m PtrBitmap) -> RawStack -> m StackFrames
decodeStack RawClosure -> DebugM StgInfoTableWithPtr
get_info_table Word32 -> DebugM PtrBitmap
get_bitmap RawStack
stack
dereferencePapPayload :: PayloadCont -> DebugM PapPayload
dereferencePapPayload :: PayloadCont -> DebugM PapPayload
dereferencePapPayload (PayloadCont ClosurePtr
fp [Word64]
raw) = do
PtrBitmap
bm <- Request PtrBitmap -> DebugM PtrBitmap
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (Word16 -> ClosurePtr -> Request PtrBitmap
RequestFunBitmap (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
raw) ClosurePtr
fp)
return $ [FieldValue ClosurePtr] -> PapPayload
forall b. [FieldValue b] -> GenPapPayload b
GenPapPayload (State [Word64] [FieldValue ClosurePtr]
-> [Word64] -> [FieldValue ClosurePtr]
forall s a. State s a -> s -> a
evalState ((Bool -> StateT [Word64] Identity (FieldValue ClosurePtr))
-> PtrBitmap -> State [Word64] [FieldValue ClosurePtr]
forall (m :: * -> *) a.
Monad m =>
(Bool -> m a) -> PtrBitmap -> m [a]
traversePtrBitmap Bool -> StateT [Word64] Identity (FieldValue ClosurePtr)
decodeField PtrBitmap
bm) [Word64]
raw)
where
getWord :: StateT [Word64] Identity Word64
getWord = do
Word64
v <- ([Word64] -> Word64) -> StateT [Word64] Identity Word64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [Word64] -> Word64
forall a. HasCallStack => [a] -> a
head
([Word64] -> [Word64]) -> StateT [Word64] Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify [Word64] -> [Word64]
forall a. HasCallStack => [a] -> [a]
tail
return Word64
v
decodeField :: Bool -> StateT [Word64] Identity (FieldValue ClosurePtr)
decodeField Bool
True = ClosurePtr -> FieldValue ClosurePtr
forall b. b -> FieldValue b
SPtr (ClosurePtr -> FieldValue ClosurePtr)
-> (Word64 -> ClosurePtr) -> Word64 -> FieldValue ClosurePtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ClosurePtr
mkClosurePtr (Word64 -> FieldValue ClosurePtr)
-> StateT [Word64] Identity Word64
-> StateT [Word64] Identity (FieldValue ClosurePtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Word64] Identity Word64
getWord
decodeField Bool
False = Word64 -> FieldValue ClosurePtr
forall b. Word64 -> FieldValue b
SNonPtr (Word64 -> FieldValue ClosurePtr)
-> StateT [Word64] Identity Word64
-> StateT [Word64] Identity (FieldValue ClosurePtr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Word64] Identity Word64
getWord
dereferenceConDesc :: ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc :: ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
i = Request ConstrDesc -> DebugM ConstrDesc
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request ConstrDesc
RequestConstrDesc ConstrDescCont
i)
_noConDesc :: ConstrDescCont -> DebugM ConstrDesc
_noConDesc :: ConstrDescCont -> DebugM ConstrDesc
_noConDesc ConstrDescCont
c = ConstrDescCont -> DebugM ConstrDesc -> DebugM ConstrDesc
forall a b. Show a => a -> b -> b
traceShow ConstrDescCont
c (ConstrDesc -> DebugM ConstrDesc
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDesc
emptyConDesc)
emptyConDesc :: ConstrDesc
emptyConDesc :: ConstrDesc
emptyConDesc = [Char] -> [Char] -> [Char] -> ConstrDesc
ConstrDesc [Char]
"" [Char]
"" [Char]
""
dereferenceClosure :: ClosurePtr -> DebugM SizedClosure
dereferenceClosure :: ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
| Bool -> Bool
not (ClosurePtr -> Bool
heapAlloced ClosurePtr
cp) = ClosurePtr -> DebugM SizedClosure
dereferenceClosureDirect ClosurePtr
cp
| Bool
otherwise = do
RawClosure
rc <- BlockCacheRequest RawClosure -> DebugM RawClosure
forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
BlockCacheRequest resp -> m resp
requestBlock (ClosurePtr -> BlockCacheRequest RawClosure
LookupClosure ClosurePtr
cp)
if RawClosure -> Int
rawClosureSize RawClosure
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
then do
SizedClosure
res <- ClosurePtr -> DebugM SizedClosure
dereferenceClosureDirect ClosurePtr
cp
[Char] -> DebugM ()
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM ([Char]
"Warning!!: block decoding failed, report this as a bug:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (ClosurePtr, SizedClosure) -> [Char]
forall a. Show a => a -> [Char]
show (ClosurePtr
cp, SizedClosure
res))
return SizedClosure
res
else do
let it :: ConstrDescCont
it = HasCallStack => RawClosure -> ConstrDescCont
RawClosure -> ConstrDescCont
getInfoTblPtr RawClosure
rc
RawInfoTable
st_it <- Request RawInfoTable -> DebugM RawInfoTable
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request RawInfoTable
RequestInfoTable ConstrDescCont
it)
(ConstrDescCont, RawInfoTable)
-> (ClosurePtr, RawClosure) -> DebugM SizedClosure
decodeClosure (ConstrDescCont
it, RawInfoTable
st_it) (ClosurePtr
cp, RawClosure
rc)
precacheBlocks :: DebugM [RawBlock]
precacheBlocks :: DebugM [RawBlock]
precacheBlocks = BlockCacheRequest [RawBlock] -> DebugM [RawBlock]
forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
BlockCacheRequest resp -> m resp
requestBlock BlockCacheRequest [RawBlock]
PopulateBlockCache
gcRoots :: DebugM [ClosurePtr]
gcRoots :: DebugM [ClosurePtr]
gcRoots = Request [ClosurePtr] -> DebugM [ClosurePtr]
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request [ClosurePtr]
RequestRoots
allBlocks :: DebugM [RawBlock]
allBlocks :: DebugM [RawBlock]
allBlocks = Request [RawBlock] -> DebugM [RawBlock]
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request [RawBlock]
RequestAllBlocks
getSourceInfo :: InfoTablePtr -> DebugM (Maybe SourceInformation)
getSourceInfo :: ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo = Request (Maybe SourceInformation)
-> DebugM (Maybe SourceInformation)
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (Request (Maybe SourceInformation)
-> DebugM (Maybe SourceInformation))
-> (ConstrDescCont -> Request (Maybe SourceInformation))
-> ConstrDescCont
-> DebugM (Maybe SourceInformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstrDescCont -> Request (Maybe SourceInformation)
RequestSourceInfo
savedObjects :: DebugM [ClosurePtr]
savedObjects :: DebugM [ClosurePtr]
savedObjects = Request [ClosurePtr] -> DebugM [ClosurePtr]
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request [ClosurePtr]
RequestSavedObjects
requestCCSMain :: DebugM CCSPtr
requestCCSMain :: DebugM CCSPtr
requestCCSMain = Request CCSPtr -> DebugM CCSPtr
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request CCSPtr
RequestCCSMainPtr
version :: DebugM Version
version :: DebugM Version
version = Request Version -> DebugM Version
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request Version
RequestVersion
dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable
dereferenceInfoTable :: ConstrDescCont -> DebugM StgInfoTable
dereferenceInfoTable ConstrDescCont
it = do
RawInfoTable
rit <- Request RawInfoTable -> DebugM RawInfoTable
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request RawInfoTable
RequestInfoTable ConstrDescCont
it)
Version
ver <- DebugM Version
version
let !decoded_it :: StgInfoTable
decoded_it = Version -> RawInfoTable -> StgInfoTable
D.decodeInfoTable Version
ver RawInfoTable
rit
StgInfoTable -> DebugM StgInfoTable
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StgInfoTable
decoded_it
dereferenceSRT :: InfoTablePtr -> DebugM SrtPayload
dereferenceSRT :: ConstrDescCont -> DebugM SrtPayload
dereferenceSRT ConstrDescCont
it = Maybe ClosurePtr -> SrtPayload
forall b. Maybe b -> GenSrtPayload b
GenSrtPayload (Maybe ClosurePtr -> SrtPayload)
-> DebugM (Maybe ClosurePtr) -> DebugM SrtPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request (Maybe ClosurePtr) -> DebugM (Maybe ClosurePtr)
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request (Maybe ClosurePtr)
RequestSRT ConstrDescCont
it)
dereferenceCCSDirect :: CCSPtr -> DebugM CCSPayload
dereferenceCCSDirect :: CCSPtr -> DebugM CCSPayload
dereferenceCCSDirect CCSPtr
it = Request CCSPayload -> DebugM CCSPayload
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (CCSPtr -> Request CCSPayload
RequestCCS CCSPtr
it)
dereferenceCCS :: CCSPtr -> DebugM CCSPayload
dereferenceCCS :: CCSPtr -> DebugM CCSPayload
dereferenceCCS ccsPtr :: CCSPtr
ccsPtr@(CCSPtr Word64
w)
| Bool -> Bool
not (ClosurePtr -> Bool
heapAlloced (ClosurePtr -> Bool) -> ClosurePtr -> Bool
forall a b. (a -> b) -> a -> b
$ Word64 -> ClosurePtr
mkClosurePtr Word64
w) = CCSPtr -> DebugM CCSPayload
dereferenceCCSDirect CCSPtr
ccsPtr
| Bool
otherwise = do
RawClosure
rc <- BlockCacheRequest RawClosure -> DebugM RawClosure
forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
BlockCacheRequest resp -> m resp
requestBlock (ClosurePtr -> BlockCacheRequest RawClosure
LookupClosure (ClosurePtr -> BlockCacheRequest RawClosure)
-> ClosurePtr -> BlockCacheRequest RawClosure
forall a b. (a -> b) -> a -> b
$ Word64 -> ClosurePtr
mkClosurePtr Word64
w)
if RawClosure -> Int
rawClosureSize RawClosure
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
then do
CCSPayload
res <- CCSPtr -> DebugM CCSPayload
dereferenceCCSDirect CCSPtr
ccsPtr
[Char] -> DebugM ()
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM ([Char]
"Warning!!: block decoding failed, report this as a bug:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (CCSPtr, CCSPayload) -> [Char]
forall a. Show a => a -> [Char]
show (CCSPtr
ccsPtr, CCSPayload
res))
return CCSPayload
res
else do
Version
v <- DebugM Version
version
pure $ Version -> RawClosure -> CCSPayload
D.decodeCCS Version
v RawClosure
rc
dereferenceCC :: CCPtr -> DebugM CCPayload
dereferenceCC :: CCPtr -> DebugM CCPayload
dereferenceCC CCPtr
it = Request CCPayload -> DebugM CCPayload
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (CCPtr -> Request CCPayload
RequestCC CCPtr
it)
dereferenceIndexTableDirect :: IndexTablePtr -> DebugM IndexTable
dereferenceIndexTableDirect :: IndexTablePtr -> DebugM IndexTable
dereferenceIndexTableDirect IndexTablePtr
it = Request IndexTable -> DebugM IndexTable
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (IndexTablePtr -> Request IndexTable
RequestIndexTable IndexTablePtr
it)
dereferenceIndexTable :: IndexTablePtr -> DebugM IndexTable
dereferenceIndexTable :: IndexTablePtr -> DebugM IndexTable
dereferenceIndexTable idxTablePtr :: IndexTablePtr
idxTablePtr@(IndexTablePtr Word64
w)
| Bool -> Bool
not (ClosurePtr -> Bool
heapAlloced (ClosurePtr -> Bool) -> ClosurePtr -> Bool
forall a b. (a -> b) -> a -> b
$ Word64 -> ClosurePtr
mkClosurePtr Word64
w) = IndexTablePtr -> DebugM IndexTable
dereferenceIndexTableDirect IndexTablePtr
idxTablePtr
| Bool
otherwise = do
RawClosure
rc <- BlockCacheRequest RawClosure -> DebugM RawClosure
forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
BlockCacheRequest resp -> m resp
requestBlock (ClosurePtr -> BlockCacheRequest RawClosure
LookupClosure (ClosurePtr -> BlockCacheRequest RawClosure)
-> ClosurePtr -> BlockCacheRequest RawClosure
forall a b. (a -> b) -> a -> b
$ Word64 -> ClosurePtr
mkClosurePtr Word64
w)
if RawClosure -> Int
rawClosureSize RawClosure
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
then do
IndexTable
res <- IndexTablePtr -> DebugM IndexTable
dereferenceIndexTableDirect IndexTablePtr
idxTablePtr
[Char] -> DebugM ()
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM ([Char]
"Warning!!: block decoding failed, report this as a bug:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (IndexTablePtr, IndexTable) -> [Char]
forall a. Show a => a -> [Char]
show (IndexTablePtr
idxTablePtr, IndexTable
res))
return IndexTable
res
else do
Version
v <- DebugM Version
version
pure $ Version -> RawClosure -> IndexTable
D.decodeIndexTable Version
v RawClosure
rc