{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
module GHC.Debug.Client.Query
  ( -- * Pause/Resume
    pause
  , fork
  , pauseThen
  , resume
  , pausePoll
  , withPause

  -- * General Requests
  , precacheBlocks
  , gcRoots
  , allBlocks
  , getSourceInfo
  , savedObjects
  , requestCCSMain
  , version

  -- * Dereferencing functions
  , 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 the debuggee
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 the debuggee
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

-- | Like pause, but wait for the debuggee to pause itself. It currently
-- impossible to resume after a pause caused by a poll.?????????? Is that true???? can we not just call resume????
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

-- | Bracketed version of pause/resume.
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

-- Derefence other structures so we just have 'ClosurePtr' at leaves.
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


-- | Decode a closure corresponding to the given 'ClosurePtr'
-- You should not use this function directly unless you know what you are
-- doing. 'dereferenceClosure' will be much faster in general.
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

-- | Deference some StackFrames from a given 'StackCont'
dereferenceStack :: StackCont -> DebugM StackFrames
dereferenceStack :: StackCont -> DebugM StackFrames
dereferenceStack (StackCont StackPtr
sp RawStack
stack) = do
--  req_stack <- request (RequestStack (coerce cp))
  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
--  traceShowM ("BAD", printStack stack, rawStackSize stack)
--  traceShowM ("GOOD", printStack req_stack, rawStackSize req_stack)
  (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

-- | Derference the PapPayload from the 'PayloadCont'
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]
""

{-
-- | Print out the number of request made for each request type
traceRequestLog :: Env u w -> IO ()
traceRequestLog d = do
  s <- readIORef (statsRef d)
  putStrLn (ppStats s)

traceProfile :: Env u w -> IO ()
traceProfile e = do
  p <- readIORef (profRef e)
  print (profile p)
  -}

-- | Consult the 'BlockCache' for the block which contains a specific
-- closure, if it's not there then try to fetch the right block, if that
-- fails, call 'dereferenceClosureDirect'
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)

-- | Fetch all the blocks from the debuggee and add them to the block cache
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

-- | Query the debuggee for the list of GC Roots
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

-- | Query the debuggee for all the blocks it knows about
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

-- | Query the debuggee for source information about a specific info table.
-- This requires your executable to be built with @-finfo-table-map@.
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

-- | Query the debuggee for the list of saved objects.
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

-- | Query the debuggee for the protocol version
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