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

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

  -- * Dereferencing functions
  , dereferenceClosures
  , dereferenceClosure
  , dereferenceClosureDirect
  , dereferenceClosureC
  , dereferenceStack
  , dereferencePapPayload
  , dereferenceConDesc
  , dereferenceInfoTable

  ) where

import           Control.Exception
import           GHC.Debug.Types
import           GHC.Debug.Decode
import           GHC.Debug.Decode.Stack
import GHC.Debug.Client.Monad
import           GHC.Debug.Client.BlockCache
import Control.Monad.State
import Data.Word

import Debug.Trace

-- | Pause the debuggee
pause :: Debuggee -> IO ()
pause :: Debuggee -> IO ()
pause Debuggee
e = do
  forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e forall a b. (a -> b) -> a -> b
$ 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
  forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e forall a b. (a -> b) -> a -> b
$ 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 = forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e forall a b. (a -> b) -> a -> b
$ 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
  forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e forall a b. (a -> b) -> a -> b
$ 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 = 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
getInfoTblPtr RawClosure
rc
    (StgInfoTableWithPtr
itbl, RawInfoTable
rit) <- forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable ConstrDescCont
ptr)
    forall (m :: * -> *) a. Monad m => a -> m a
return (StgInfoTableWithPtr
itbl,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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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 = do
  SizedClosure
c <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
  forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- 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
getInfoTblPtr RawClosure
raw_c
    (StgInfoTableWithPtr, RawInfoTable)
raw_it <- forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable ConstrDescCont
it)
    return $ (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeClosure (StgInfoTableWithPtr, RawInfoTable)
raw_it (ClosurePtr
c, RawClosure
raw_c)

dereferenceClosures  :: [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures :: [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
cs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 = 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) 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)
  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 <- forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (Word16 -> ClosurePtr -> Request PtrBitmap
RequestFunBitmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
raw) ClosurePtr
fp)
  return $ forall b. [FieldValue b] -> GenPapPayload b
GenPapPayload (forall s a. State s a -> s -> a
evalState (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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. [a] -> a
head
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. [a] -> [a]
tail
      return Word64
v

    decodeField :: Bool -> StateT [Word64] Identity (FieldValue ClosurePtr)
decodeField Bool
True  = forall b. b -> FieldValue b
SPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ClosurePtr
mkClosurePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Word64] Identity Word64
getWord
    decodeField Bool
False = forall b. Word64 -> FieldValue b
SNonPtr 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 = 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 = forall a b. Show a => a -> b -> b
traceShow ConstrDescCont
c (forall (m :: * -> *) a. Monad m => a -> m a
return ConstrDesc
emptyConDesc)

emptyConDesc :: ConstrDesc
emptyConDesc :: ConstrDesc
emptyConDesc = String -> String -> String -> ConstrDesc
ConstrDesc String
"" String
"" String
""

{-
-- | 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 <-  forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
BlockCacheRequest resp -> m resp
requestBlock (ClosurePtr -> BlockCacheRequest RawClosure
LookupClosure ClosurePtr
cp)
      let it :: ConstrDescCont
it = HasCallStack => RawClosure -> ConstrDescCont
getInfoTblPtr RawClosure
rc
      (StgInfoTableWithPtr, RawInfoTable)
st_it <- forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable ConstrDescCont
it)
      return $ (StgInfoTableWithPtr, RawInfoTable)
-> (ClosurePtr, RawClosure) -> SizedClosure
decodeClosure (StgInfoTableWithPtr, 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 = 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 = 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 = 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 = forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request 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 = forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request [ClosurePtr]
RequestSavedObjects

-- | Query the debuggee for the protocol version
version :: DebugM Word32
version :: DebugM Word32
version = forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request Word32
RequestVersion

dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable
dereferenceInfoTable :: ConstrDescCont -> DebugM StgInfoTable
dereferenceInfoTable ConstrDescCont
it = StgInfoTableWithPtr -> StgInfoTable
decodedTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request (ConstrDescCont -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable ConstrDescCont
it)