{-# LANGUAGE OrPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultilineStrings #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Debugger.Runtime.Interpreter.Legacy
  ( listThreads
  , decodeThreadStack
  , collectExceptionInfo
  , unpackStackFields
  ) where

import Control.Exception (SomeException)
import System.Directory (getCurrentDirectory)
import Colog.Core as Logger
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.Functor
import Data.Maybe
import GHC
import GHC.Builtin.Types
import GHC.Conc.Sync hiding (listThreads)
import GHC.Debugger.Interface.Messages
import GHC.Debugger.Monad
import GHC.Debugger.Runtime.Eval
import GHC.Debugger.Runtime.Interpreter.Types
import GHC.Debugger.Runtime.Term.Parser
import GHC.Driver.Env
import GHC.Exts.Heap.ClosureTypes
import GHC.InfoProv
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter as Interp
import GHC.Utils.Encoding.UTF8
import GHC.Utils.Outputable as Ppr
import GHCi.Message
import GHCi.RemoteTypes
import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote
import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote
import qualified GHC.Stack.Types as Stack
import qualified GHC.Stack.CloneStack as Stack
import qualified GHC.Exts.Heap.Closures as Stack
import GHC.Debugger.Session.Builtin (debuggerRuntimeFFIInspectModName, runInternal)
import GHC.Stack.CloneStack (StackSnapshot)

-- GHC 9.14: use @evalX@ and @TermParser@ to do this all without custom commands

--------------------------------------------------------------------------------
-- * Threads
--------------------------------------------------------------------------------

listThreads :: Debugger [ThreadInfo ForeignRef]
listThreads :: Debugger [ThreadInfo ForeignRef]
listThreads = Debugger [ThreadInfo ForeignRef]
-> Debugger [ThreadInfo ForeignRef]
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (Debugger [ThreadInfo ForeignRef]
 -> Debugger [ThreadInfo ForeignRef])
-> Debugger [ThreadInfo ForeignRef]
-> Debugger [ThreadInfo ForeignRef]
forall a b. (a -> b) -> a -> b
$ do
  threads_fvs <- Either BadEvalStatus [ForeignRef ThreadId]
-> Debugger [ForeignRef ThreadId]
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus [ForeignRef ThreadId]
 -> Debugger [ForeignRef ThreadId])
-> Debugger (Either BadEvalStatus [ForeignRef ThreadId])
-> Debugger [ForeignRef ThreadId]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteExpr (IO [ThreadId])
-> Debugger (Either BadEvalStatus [ForeignRef ThreadId])
forall a.
RemoteExpr (IO [a])
-> Debugger (Either BadEvalStatus [ForeignRef a])
Remote.evalIOList RemoteExpr (IO [ThreadId])
Remote.listThreads
  labels      <- getRemoteThreadsLabels threads_fvs
  forM (zip threads_fvs labels) $ \(ForeignRef ThreadId -> ForeignRef ThreadId
forall a b. ForeignRef a -> ForeignRef b
castForeignRef -> ForeignRef ThreadId
thread_fv, Maybe String
label) -> do
    status <- ForeignRef ThreadId -> Debugger ThreadStatus
getRemoteThreadStatus ForeignRef ThreadId
thread_fv
    pure ThreadInfo
      { threadInfoStatus = status
      , threadInfoLabel  = label
      , threadInfoRef    = thread_fv
      }

-- | Is the remote thread running or blocked (NOT finished NOR dead)?
getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus
getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus
getRemoteThreadStatus ForeignRef ThreadId
threadIdRef = do
  status_fv  <- Either BadEvalStatus (ForeignRef ThreadStatus)
-> Debugger (ForeignRef ThreadStatus)
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus (ForeignRef ThreadStatus)
 -> Debugger (ForeignRef ThreadStatus))
-> Debugger (Either BadEvalStatus (ForeignRef ThreadStatus))
-> Debugger (ForeignRef ThreadStatus)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteExpr (IO ThreadStatus)
-> Debugger (Either BadEvalStatus (ForeignRef ThreadStatus))
forall a.
RemoteExpr (IO a) -> Debugger (Either BadEvalStatus (ForeignRef a))
Remote.evalIO
    (RemoteExpr ThreadId -> RemoteExpr (IO ThreadStatus)
Remote.threadStatus (ForeignRef ThreadId -> RemoteExpr ThreadId
forall a. ForeignRef a -> RemoteExpr a
Remote.ref ForeignRef ThreadId
threadIdRef))
  status_parsed <-
    obtainParsedTerm "ThreadStatus" 2 True anyTy{-..no..-} (castForeignRef status_fv) threadStatusParser

  case status_parsed of
    Left [TermParseError]
errs -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Error ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TermParseError -> SDoc) -> [TermParseError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (TermParseError -> String) -> TermParseError -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermParseError -> String
getTermErrorMessage) [TermParseError]
errs))
      IO ThreadStatus -> Debugger ThreadStatus
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadStatus -> Debugger ThreadStatus)
-> IO ThreadStatus -> Debugger ThreadStatus
forall a b. (a -> b) -> a -> b
$ String -> IO ThreadStatus
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Failed to parse ThreadStatus"
    Right ThreadStatus
thrdStatus ->
      ThreadStatus -> Debugger ThreadStatus
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadStatus
thrdStatus

getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String]
getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String]
getRemoteThreadsLabels [ForeignRef ThreadId]
threadIdRefs = do

  [ForeignRef ThreadId]
-> (ForeignRef ThreadId -> Debugger (Maybe String))
-> Debugger [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ForeignRef ThreadId]
threadIdRefs ((ForeignRef ThreadId -> Debugger (Maybe String))
 -> Debugger [Maybe String])
-> (ForeignRef ThreadId -> Debugger (Maybe String))
-> Debugger [Maybe String]
forall a b. (a -> b) -> a -> b
$ \ForeignRef ThreadId
threadIdRef -> do

    r <- RemoteExpr (IO [String])
-> Debugger (Either BadEvalStatus [ForeignRef String])
forall a.
RemoteExpr (IO [a])
-> Debugger (Either BadEvalStatus [ForeignRef a])
Remote.evalIOList (RemoteExpr (IO [String])
 -> Debugger (Either BadEvalStatus [ForeignRef String]))
-> RemoteExpr (IO [String])
-> Debugger (Either BadEvalStatus [ForeignRef String])
forall a b. (a -> b) -> a -> b
$ Remote.do
      mb_str <- RemoteExpr ThreadId -> RemoteExpr (IO (Maybe String))
Remote.threadLabel (ForeignRef ThreadId -> RemoteExpr ThreadId
forall a. ForeignRef a -> RemoteExpr a
Remote.ref ForeignRef ThreadId
threadIdRef)
      Remote.return (Remote.maybeToList mb_str)

    expectRight r >>= \case
      []          -> Maybe String -> Debugger (Maybe String)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
      [ForeignRef String
io_lbl_fv] -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> Debugger String -> Debugger (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either BadEvalStatus String -> Debugger String
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus String -> Debugger String)
-> Debugger (Either BadEvalStatus String) -> Debugger String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteExpr String -> Debugger (Either BadEvalStatus String)
Remote.evalString (ForeignRef String -> RemoteExpr String
forall a. ForeignRef a -> RemoteExpr a
Remote.ref ForeignRef String
io_lbl_fv))
      [ForeignRef String]
_ -> IO (Maybe String) -> Debugger (Maybe String)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Debugger (Maybe String))
-> IO (Maybe String) -> Debugger (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Unexpected result from evaluating \"threadLabel\""

--------------------------------------------------------------------------------
-- *** TermParsers
--------------------------------------------------------------------------------

threadStatusParser :: TermParser ThreadStatus
threadStatusParser :: TermParser ThreadStatus
threadStatusParser = do
        (String -> TermParser ()
matchConstructorTerm String
"ThreadRunning"  TermParser () -> ThreadStatus -> TermParser ThreadStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ThreadStatus
ThreadRunning)
    TermParser ThreadStatus
-> TermParser ThreadStatus -> TermParser ThreadStatus
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"ThreadFinished" TermParser () -> ThreadStatus -> TermParser ThreadStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ThreadStatus
ThreadFinished)
    TermParser ThreadStatus
-> TermParser ThreadStatus -> TermParser ThreadStatus
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"ThreadDied"     TermParser () -> ThreadStatus -> TermParser ThreadStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ThreadStatus
ThreadDied)
    TermParser ThreadStatus
-> TermParser ThreadStatus -> TermParser ThreadStatus
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"ThreadBlocked"  TermParser () -> TermParser ThreadStatus -> TermParser ThreadStatus
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (BlockReason -> ThreadStatus
ThreadBlocked (BlockReason -> ThreadStatus)
-> TermParser BlockReason -> TermParser ThreadStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser BlockReason -> TermParser BlockReason
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser BlockReason
blockedReasonParser))

blockedReasonParser :: TermParser BlockReason
blockedReasonParser :: TermParser BlockReason
blockedReasonParser = do
        (String -> TermParser ()
matchConstructorTerm String
"BlockedOnMVar"        TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnMVar)
    TermParser BlockReason
-> TermParser BlockReason -> TermParser BlockReason
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"BlockedOnBlackHole"   TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnBlackHole)
    TermParser BlockReason
-> TermParser BlockReason -> TermParser BlockReason
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"BlockedOnException"   TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnException)
    TermParser BlockReason
-> TermParser BlockReason -> TermParser BlockReason
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"BlockedOnSTM"         TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnSTM)
    TermParser BlockReason
-> TermParser BlockReason -> TermParser BlockReason
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"BlockedOnForeignCall" TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnForeignCall)
    TermParser BlockReason
-> TermParser BlockReason -> TermParser BlockReason
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"BlockedOnOther"       TermParser () -> BlockReason -> TermParser BlockReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockReason
BlockedOnOther)


--------------------------------------------------------------------------------
-- * Thread stack frames
--------------------------------------------------------------------------------

decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]
decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo ForeignRef]
decodeThreadStack ForeignRef ThreadId
threadIdRef = Debugger [StackFrameInfo ForeignRef]
-> Debugger [StackFrameInfo ForeignRef]
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (Debugger [StackFrameInfo ForeignRef]
 -> Debugger [StackFrameInfo ForeignRef])
-> Debugger [StackFrameInfo ForeignRef]
-> Debugger [StackFrameInfo ForeignRef]
forall a b. (a -> b) -> a -> b
$ do
  l <- RemoteExpr (IO (StackSnapshot, [(StackFrame, Maybe InfoProv)]))
-> Debugger
     (Either
        BadEvalStatus
        (ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)])))
forall a.
RemoteExpr (IO a) -> Debugger (Either BadEvalStatus (ForeignRef a))
Remote.evalIO (RemoteExpr (IO (StackSnapshot, [(StackFrame, Maybe InfoProv)]))
 -> Debugger
      (Either
         BadEvalStatus
         (ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)]))))
-> RemoteExpr (IO (StackSnapshot, [(StackFrame, Maybe InfoProv)]))
-> Debugger
     (Either
        BadEvalStatus
        (ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)])))
forall a b. (a -> b) -> a -> b
$ Remote.do
    clonedStack <- RemoteExpr ThreadId -> RemoteExpr (IO StackSnapshot)
Remote.cloneThreadStack (ForeignRef ThreadId -> RemoteExpr ThreadId
forall a. ForeignRef a -> RemoteExpr a
Remote.ref ForeignRef ThreadId
threadIdRef)
    frames      <- Remote.decodeStackWithIpe clonedStack
    Remote.return $ Remote.pair `Remote.app` clonedStack `Remote.app` frames

  case l of
    Left (EvalRaisedException SomeException
e) -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Info (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Failed to decode the stack with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace will be returned...")
      [StackFrameInfo ForeignRef] -> Debugger [StackFrameInfo ForeignRef]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Left BadEvalStatus
e -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Failed to decode the stack with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (BadEvalStatus -> String
forall a. Show a => a -> String
show BadEvalStatus
e) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No StackTrace will be returned...")
      [StackFrameInfo ForeignRef] -> Debugger [StackFrameInfo ForeignRef]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Right ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)])
p_fv -> do
      stack_frames_fvs <-
          (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)]
-> Debugger [ForeignRef (StackFrame, Maybe InfoProv)]
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)]
 -> Debugger [ForeignRef (StackFrame, Maybe InfoProv)])
-> Debugger
     (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)])
-> Debugger [ForeignRef (StackFrame, Maybe InfoProv)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Debugger
   (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)])
 -> Debugger [ForeignRef (StackFrame, Maybe InfoProv)])
-> Debugger
     (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)])
-> Debugger [ForeignRef (StackFrame, Maybe InfoProv)]
forall a b. (a -> b) -> a -> b
$ RemoteExpr (IO [(StackFrame, Maybe InfoProv)])
-> Debugger
     (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)])
forall a.
RemoteExpr (IO [a])
-> Debugger (Either BadEvalStatus [ForeignRef a])
Remote.evalIOList (RemoteExpr (IO [(StackFrame, Maybe InfoProv)])
 -> Debugger
      (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)]))
-> RemoteExpr (IO [(StackFrame, Maybe InfoProv)])
-> Debugger
     (Either BadEvalStatus [ForeignRef (StackFrame, Maybe InfoProv)])
forall a b. (a -> b) -> a -> b
$ Remote.do
            RemoteExpr [(StackFrame, Maybe InfoProv)]
-> RemoteExpr (IO [(StackFrame, Maybe InfoProv)])
forall a. RemoteExpr a -> RemoteExpr (IO a)
Remote.return (RemoteExpr [(StackFrame, Maybe InfoProv)]
 -> RemoteExpr (IO [(StackFrame, Maybe InfoProv)]))
-> RemoteExpr [(StackFrame, Maybe InfoProv)]
-> RemoteExpr (IO [(StackFrame, Maybe InfoProv)])
forall a b. (a -> b) -> a -> b
$ RemoteExpr
  ((StackSnapshot, [(StackFrame, Maybe InfoProv)])
   -> [(StackFrame, Maybe InfoProv)])
forall a b. RemoteExpr ((a, b) -> b)
Remote.snd RemoteExpr
  ((StackSnapshot, [(StackFrame, Maybe InfoProv)])
   -> [(StackFrame, Maybe InfoProv)])
-> ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)])
-> RemoteExpr [(StackFrame, Maybe InfoProv)]
forall a b. RemoteExpr (a -> b) -> ForeignRef a -> RemoteExpr b
`Remote.appRef` ForeignRef (StackSnapshot, [(StackFrame, Maybe InfoProv)])
p_fv
      cloned_stack_fv <-
          (expectRight =<<) $ Remote.evalIO $ Remote.do
            Remote.return $ Remote.fst `Remote.appRef` p_fv

      fmap catMaybes $ do
       forM (zip stack_frames_fvs [0..]) $ \ (ForeignRef (StackFrame, Maybe InfoProv)
stack_frame_fv,Int
ix) -> do
        String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser (Maybe (StackFrameInfo ForeignRef))
-> Debugger
     (Either [TermParseError] (Maybe (StackFrameInfo ForeignRef)))
forall a.
String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
"ghc-heap:StackFrame" Int
2 Bool
True Type
anyTy{-todo:stackframety?-} (ForeignRef (StackFrame, Maybe InfoProv) -> ForeignHValue
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignRef (StackFrame, Maybe InfoProv)
stack_frame_fv)
          (ForeignRef StackSnapshot
-> Int -> TermParser (Maybe (StackFrameInfo ForeignRef))
stackFrameInfoParser ForeignRef StackSnapshot
cloned_stack_fv Int
ix) Debugger
  (Either [TermParseError] (Maybe (StackFrameInfo ForeignRef)))
-> (Either [TermParseError] (Maybe (StackFrameInfo ForeignRef))
    -> Debugger (Maybe (StackFrameInfo ForeignRef)))
-> Debugger (Maybe (StackFrameInfo ForeignRef))
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left [TermParseError]
errs -> do
              Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Error ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TermParseError -> SDoc) -> [TermParseError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (TermParseError -> String) -> TermParseError -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermParseError -> String
getTermErrorMessage) [TermParseError]
errs))
              Maybe (StackFrameInfo ForeignRef)
-> Debugger (Maybe (StackFrameInfo ForeignRef))
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (StackFrameInfo ForeignRef)
forall a. Maybe a
Nothing
            Right Maybe (StackFrameInfo ForeignRef)
tm -> do
              Maybe (StackFrameInfo ForeignRef)
-> Debugger (Maybe (StackFrameInfo ForeignRef))
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (StackFrameInfo ForeignRef)
tm

--------------------------------------------------------------------------------
-- ** Decoding Stack Frames ----------------------------------------------------
--------------------------------------------------------------------------------

-- | Try to decode a 'StackFrameInfo' from a @(StackFrame, Maybe InfoProv)@ term
stackFrameInfoParser :: ForeignRef Stack.StackSnapshot -> Int -> TermParser (Maybe (StackFrameInfo ForeignRef))
stackFrameInfoParser :: ForeignRef StackSnapshot
-> Int -> TermParser (Maybe (StackFrameInfo ForeignRef))
stackFrameInfoParser ForeignRef StackSnapshot
stack Int
frameIx = do
  -- Try a stack annotation first
  stackAnno <- Int
-> TermParser (Maybe (Maybe SrcLoc, String))
-> TermParser (Maybe (Maybe SrcLoc, String))
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser (Maybe (Maybe SrcLoc, String))
stackAnnoParser
  case stackAnno of
    Maybe (Maybe SrcLoc, String)
Nothing -> do
      -- Try IPE next
      mipe <- Int -> TermParser (Maybe InfoProv) -> TermParser (Maybe InfoProv)
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 (TermParser InfoProv -> TermParser (Maybe InfoProv)
forall a. TermParser a -> TermParser (Maybe a)
maybeParser TermParser InfoProv
infoProvParser)
      case mipe of
        Maybe InfoProv
Nothing -> do
          -- Try decoding a continuation BCO with a breakpoint next
          ((InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
 -> StackFrameInfo ForeignRef)
-> Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
-> Maybe (StackFrameInfo ForeignRef)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InternalBreakpointId
 -> DbgStackFrameBCOArgs ForeignRef -> StackFrameInfo ForeignRef)
-> (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
-> StackFrameInfo ForeignRef
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InternalBreakpointId
-> DbgStackFrameBCOArgs ForeignRef -> StackFrameInfo ForeignRef
forall (ref :: * -> *).
InternalBreakpointId
-> DbgStackFrameBCOArgs ref -> StackFrameInfo ref
StackFrameBreakpointInfo)
            (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
 -> Maybe (StackFrameInfo ForeignRef))
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
-> TermParser (Maybe (StackFrameInfo ForeignRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 (ForeignRef StackSnapshot
-> Int
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
retBCOParser ForeignRef StackSnapshot
stack Int
frameIx)
        Just InfoProv
ipe -> Maybe (StackFrameInfo ForeignRef)
-> TermParser (Maybe (StackFrameInfo ForeignRef))
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StackFrameInfo ForeignRef)
 -> TermParser (Maybe (StackFrameInfo ForeignRef)))
-> Maybe (StackFrameInfo ForeignRef)
-> TermParser (Maybe (StackFrameInfo ForeignRef))
forall a b. (a -> b) -> a -> b
$
          StackFrameInfo ForeignRef -> Maybe (StackFrameInfo ForeignRef)
forall a. a -> Maybe a
Just (InfoProv -> StackFrameInfo ForeignRef
forall (ref :: * -> *). InfoProv -> StackFrameInfo ref
StackFrameIPEInfo InfoProv
ipe)
    Just (Maybe SrcLoc
srcLoc, String
ann) -> Maybe (StackFrameInfo ForeignRef)
-> TermParser (Maybe (StackFrameInfo ForeignRef))
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StackFrameInfo ForeignRef)
 -> TermParser (Maybe (StackFrameInfo ForeignRef)))
-> Maybe (StackFrameInfo ForeignRef)
-> TermParser (Maybe (StackFrameInfo ForeignRef))
forall a b. (a -> b) -> a -> b
$
      StackFrameInfo ForeignRef -> Maybe (StackFrameInfo ForeignRef)
forall a. a -> Maybe a
Just (Maybe SrcLoc -> String -> StackFrameInfo ForeignRef
forall (ref :: * -> *).
Maybe SrcLoc -> String -> StackFrameInfo ref
StackFrameAnnotation Maybe SrcLoc
srcLoc String
ann)

-- | Decode an 'InfoProv' from an @InfoProv@ term
infoProvParser :: TermParser InfoProv
infoProvParser :: TermParser InfoProv
infoProvParser = String
-> ClosureType
-> String
-> String
-> String
-> String
-> String
-> String
-> InfoProv
InfoProv
  (String
 -> ClosureType
 -> String
 -> String
 -> String
 -> String
 -> String
 -> String
 -> InfoProv)
-> TermParser String
-> TermParser
     (ClosureType
      -> String
      -> String
      -> String
      -> String
      -> String
      -> String
      -> InfoProv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser String
stringParser -- ipName
  TermParser
  (ClosureType
   -> String
   -> String
   -> String
   -> String
   -> String
   -> String
   -> InfoProv)
-> TermParser ClosureType
-> TermParser
     (String
      -> String -> String -> String -> String -> String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClosureType -> TermParser ClosureType
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosureType
INVALID_OBJECT -- ipDesc (this is a stub)
  TermParser
  (String
   -> String -> String -> String -> String -> String -> InfoProv)
-> TermParser String
-> TermParser
     (String -> String -> String -> String -> String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
2 TermParser String
stringParser -- ipTyDesc
  TermParser
  (String -> String -> String -> String -> String -> InfoProv)
-> TermParser String
-> TermParser (String -> String -> String -> String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
3 TermParser String
stringParser -- ipLabel
  TermParser (String -> String -> String -> String -> InfoProv)
-> TermParser String
-> TermParser (String -> String -> String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
4 TermParser String
stringParser -- ipUnitId
  TermParser (String -> String -> String -> InfoProv)
-> TermParser String -> TermParser (String -> String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
5 TermParser String
stringParser -- ipMod
  TermParser (String -> String -> InfoProv)
-> TermParser String -> TermParser (String -> InfoProv)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
6 TermParser String
stringParser -- ipSrcFile
  TermParser (String -> InfoProv)
-> TermParser String -> TermParser InfoProv
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
7 TermParser String
stringParser -- ipSrcSpan

-- | Try to decode an 'InternalBreakpointId' from a @StackFrame@ term
retBCOParser :: ForeignRef Stack.StackSnapshot
             -> Int
             -> TermParser (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
retBCOParser :: ForeignRef StackSnapshot
-> Int
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
retBCOParser ForeignRef StackSnapshot
stack_fv Int
frame_ix = do
  -- Match against "RetBCO" frames and extract the BCOClosure information
  let bcoParser :: TermParser Term
bcoParser = Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 (Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0{-take from Box-} TermParser Term
anyTerm)
      bcoArgsParser :: TermParser Term
bcoArgsParser = Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
2 (TermParser Term -> TermParser Term
forall a. HasCallStack => TermParser a -> TermParser a
seqTermP TermParser Term
ensureTerm)
  TermParser (Term, Term) -> TermParser (Maybe (Term, Term))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> TermParser ()
matchConstructorTerm String
"RetBCO" TermParser () -> TermParser (Term, Term) -> TermParser (Term, Term)
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Term -> Term -> (Term, Term))
-> TermParser Term -> TermParser Term -> TermParser (Term, Term)
forall a b c.
(a -> b -> c) -> TermParser a -> TermParser b -> TermParser c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) TermParser Term
bcoParser TermParser Term
bcoArgsParser)
    TermParser (Maybe (Term, Term))
-> (Maybe (Term, Term)
    -> TermParser
         (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)))
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
forall a b. TermParser a -> (a -> TermParser b) -> TermParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (Suspension{ForeignHValue
val :: ForeignHValue
val :: Term -> ForeignHValue
val, ctype :: Term -> ClosureType
ctype=ClosureType
BCO},Term{val :: Term -> ForeignHValue
val=ForeignHValue
bcoArgs}) -> do
        {-"the otherwise case: Unknown closure", hence Suspension-}

        let bcoArgsOffset :: Remote.RemoteExpr (StackSnapshot -> Int -> Maybe Word)
            bcoArgsOffset :: RemoteExpr (StackSnapshot -> Int -> Maybe Word)
bcoArgsOffset = ModuleName
-> String
-> [String]
-> RemoteExpr (StackSnapshot -> Int -> Maybe Word)
forall a. ModuleName -> String -> [String] -> RemoteExpr a
Remote.var ModuleName
debuggerRuntimeFFIInspectModName String
"bcoArgsOffset" []

        tag_fv <- Debugger (Either BadEvalStatus (ForeignRef (Maybe Word)))
-> TermParser (ForeignRef (Maybe Word))
forall e a. Show e => Debugger (Either e a) -> TermParser a
liftDebuggerOrFail (Debugger (Either BadEvalStatus (ForeignRef (Maybe Word)))
 -> TermParser (ForeignRef (Maybe Word)))
-> Debugger (Either BadEvalStatus (ForeignRef (Maybe Word)))
-> TermParser (ForeignRef (Maybe Word))
forall a b. (a -> b) -> a -> b
$ RemoteExpr (Maybe Word)
-> Debugger (Either BadEvalStatus (ForeignRef (Maybe Word)))
forall a.
RemoteExpr a -> Debugger (Either BadEvalStatus (ForeignRef a))
Remote.eval (RemoteExpr (StackSnapshot -> Int -> Maybe Word)
bcoArgsOffset RemoteExpr (StackSnapshot -> Int -> Maybe Word)
-> ForeignRef StackSnapshot -> RemoteExpr (Int -> Maybe Word)
forall a b. RemoteExpr (a -> b) -> ForeignRef a -> RemoteExpr b
`Remote.appRef` ForeignRef StackSnapshot
stack_fv RemoteExpr (Int -> Maybe Word)
-> RemoteExpr Int -> RemoteExpr (Maybe Word)
forall a b. RemoteExpr (a -> b) -> RemoteExpr a -> RemoteExpr b
`Remote.app` (Int -> RemoteExpr Int
Remote.lit Int
frame_ix))
        tag <- liftDebuggerOrFail $ obtainParsedTerm "tag" 3 True anyTy (castForeignRef tag_fv) (maybeParser $ wordParser <|> wordPrimParser)

        -- Decode the BCO closure using 'getClosureData' on the foreign heap
        bco_closure_fv <- liftDebuggerOrFail $
          Remote.evalIO
            (Remote.getClosureData (Remote.ref (castForeignRef val)))

        r <- liftDebuggerOrFail $
          obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId
        let bcorefs = ForeignRef b -> NoShow (ForeignRef b)
forall a. a -> NoShow a
NoShow (ForeignRef b -> NoShow (ForeignRef b))
-> ForeignRef b -> NoShow (ForeignRef b)
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> ForeignRef b
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignHValue
bcoArgs
        return $ (, DbgStackFrameBCOArgs bcorefs tag) <$> r
      Maybe (Term, Term)
_ -> Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
-> TermParser
     (Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef))
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (InternalBreakpointId, DbgStackFrameBCOArgs ForeignRef)
forall a. Maybe a
Nothing

-- | Try to decode an 'StackAnnotation' from a @StackFrame@ term
stackAnnoParser :: TermParser (Maybe (Maybe Stack.SrcLoc, String))
stackAnnoParser :: TermParser (Maybe (Maybe SrcLoc, String))
stackAnnoParser = do
  -- Match against "AnnFrame" frames and extract the 'SomeStackAnnotation'
  (String -> TermParser ()
matchConstructorTerm String
"AnnFrame" TermParser () -> TermParser (Maybe Term) -> TermParser (Maybe Term)
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> TermParser (Maybe Term) -> TermParser (Maybe Term)
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 (Int -> TermParser (Maybe Term) -> TermParser (Maybe Term)
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0{-take from Box-} (Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> TermParser Term -> TermParser (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermParser Term
anyTerm)) TermParser (Maybe Term)
-> TermParser (Maybe Term) -> TermParser (Maybe Term)
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Term -> TermParser (Maybe Term)
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Term
forall a. Maybe a
Nothing)
    TermParser (Maybe Term)
-> (Maybe Term -> TermParser (Maybe (Maybe SrcLoc, String)))
-> TermParser (Maybe (Maybe SrcLoc, String))
forall a b. TermParser a -> (a -> TermParser b) -> TermParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Term{ForeignHValue
val :: Term -> ForeignHValue
val :: ForeignHValue
val} -> do
        stack_anno <- Debugger (Either BadEvalStatus String) -> TermParser String
forall e a. Show e => Debugger (Either e a) -> TermParser a
liftDebuggerOrFail (Debugger (Either BadEvalStatus String) -> TermParser String)
-> Debugger (Either BadEvalStatus String) -> TermParser String
forall a b. (a -> b) -> a -> b
$
          RemoteExpr String -> Debugger (Either BadEvalStatus String)
Remote.evalString
#if MIN_VERSION_ghc_experimental(9,1402,0)
            (Remote.displayStackAnnotationShort (Remote.ref (castForeignRef val)))
#else
            (RemoteExpr SomeStackAnnotation -> RemoteExpr String
Remote.displayStackAnnotation (ForeignRef SomeStackAnnotation -> RemoteExpr SomeStackAnnotation
forall a. ForeignRef a -> RemoteExpr a
Remote.ref (ForeignHValue -> ForeignRef SomeStackAnnotation
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignHValue
val)))
#endif

        src_loc <- getOptionalStackAnnotationSrcLoc

        pure $ Just (src_loc, stack_anno)
      Maybe Term
_ ->
        Maybe (Maybe SrcLoc, String)
-> TermParser (Maybe (Maybe SrcLoc, String))
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe SrcLoc, String)
forall a. Maybe a
Nothing

-- | Parse an 'InternalBreakpointId' out of a 'BCOClosure' term.
bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId)
bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId)
bcoInternalBreakpointId = do
  mbcpIxs <- TermParser (Maybe BCOBreakPointInfo)
bcoBreakPointInfoParser
  case mbcpIxs of
    Maybe BCOBreakPointInfo
Nothing -> Maybe InternalBreakpointId
-> TermParser (Maybe InternalBreakpointId)
forall a. a -> TermParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InternalBreakpointId
forall a. Maybe a
Nothing
    Just BCOBreakPointInfo{Word
brk_array_ix :: Word
info_mod_name_ix :: Word
info_mod_id_ix :: Word
brk_info_ix_hi :: Word
brk_info_ix_lo :: Word
brk_info_ix_lo :: BCOBreakPointInfo -> Word
brk_info_ix_hi :: BCOBreakPointInfo -> Word
info_mod_id_ix :: BCOBreakPointInfo -> Word
info_mod_name_ix :: BCOBreakPointInfo -> Word
brk_array_ix :: BCOBreakPointInfo -> Word
..} -> do
      mod_name <- Word -> TermParser String
bcoLiteralString Word
info_mod_name_ix
      mod_id   <- bcoLiteralString info_mod_id_ix

      return $ Just $ evalBreakpointToId EvalBreakpoint
        { eb_info_mod      = mod_name
        , eb_info_mod_unit = utf8EncodeShortByteString mod_id
        , eb_info_index    = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo
        }

getOptionalStackAnnotationSrcLoc :: TermParser (Maybe Stack.SrcLoc)
#if MIN_VERSION_ghc_experimental(9,1402,0)
getOptionalStackAnnotationSrcLoc = do
  src_loc_fv <- liftDebuggerOrFail $
    Remote.eval
      (Remote.stackAnnotationSourceLocation (Remote.ref (castForeignRef val)))

  liftDebuggerOrFail $
    obtainParsedTerm "Annotation SrcLoc" maxBound True anyTy (castForeignRef src_loc_fv) (maybeParser srcLocParser)
 where
  -- | Parse a 'SrcLoc'.
  srcLocParser :: TermParser Stack.SrcLoc
  srcLocParser = do
    Stack.SrcLoc
      <$> subtermWith 0 stringParser -- srcLocPackage
      <*> subtermWith 1 stringParser -- srcLocModule
      <*> subtermWith 2 stringParser -- srcLocFile
      <*> subtermWith 3 intPrimParser -- unpacked srcLocStartLine
      <*> subtermWith 4 intPrimParser -- unpacked srcLocStartCol
      <*> subtermWith 5 intPrimParser -- unpacked srcLocEndLine
      <*> subtermWith 6 intPrimParser -- unpacked srcLocEndCol
#else
getOptionalStackAnnotationSrcLoc :: TermParser (Maybe SrcLoc)
getOptionalStackAnnotationSrcLoc = do
  Maybe SrcLoc -> TermParser (Maybe SrcLoc)
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SrcLoc
forall a. Maybe a
Nothing
#endif


-- | Parse a literal 'String' from a BCO given a valid index into the literals array
bcoLiteralString :: Word -> TermParser String
bcoLiteralString :: Word -> TermParser String
bcoLiteralString Word
ix = do
  Term{val=literals_fv} <- Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
2 (Int -> TermParser Term
subtermTerm Int
0{-Box's field-})
  liftDebuggerOrFail $ do
    Remote.evalIOString $
        Remote.peekCString $
          Remote.withUnboxed (Remote.lit (fromIntegral ix))
            (Remote.indexAddrArray (Remote.untypedRef literals_fv))

-- | The indexes found in the BRK_FUN instruction
data BCOBreakPointInfo = BCOBreakPointInfo
  { BCOBreakPointInfo -> Word
brk_array_ix     :: !Word
  , BCOBreakPointInfo -> Word
info_mod_name_ix :: !Word
  , BCOBreakPointInfo -> Word
info_mod_id_ix   :: !Word
  , BCOBreakPointInfo -> Word
brk_info_ix_hi   :: !Word
  , BCOBreakPointInfo -> Word
brk_info_ix_lo   :: !Word
  }
  deriving Int -> BCOBreakPointInfo -> ShowS
[BCOBreakPointInfo] -> ShowS
BCOBreakPointInfo -> String
(Int -> BCOBreakPointInfo -> ShowS)
-> (BCOBreakPointInfo -> String)
-> ([BCOBreakPointInfo] -> ShowS)
-> Show BCOBreakPointInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BCOBreakPointInfo -> ShowS
showsPrec :: Int -> BCOBreakPointInfo -> ShowS
$cshow :: BCOBreakPointInfo -> String
show :: BCOBreakPointInfo -> String
$cshowList :: [BCOBreakPointInfo] -> ShowS
showList :: [BCOBreakPointInfo] -> ShowS
Show

-- | Parses a 'BCOBreakPoint' if the current term is a 'BCOClosure' headed by a
-- BRK_FUN bytecode instruction.
-- Returns Nothing if the 'BCOClosure' instructions are headed by a BRK_FUN.
bcoBreakPointInfoParser :: TermParser (Maybe BCOBreakPointInfo)
bcoBreakPointInfoParser :: TermParser (Maybe BCOBreakPointInfo)
bcoBreakPointInfoParser = do
  Term{val=instrs_array_fv} <- Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1{-instrs field-} (Int -> TermParser Term
subtermTerm Int
0{-Box's field-})
  -- highly internals dependent...
  -- find the BCI at index 0. bci is word16. the first 8bits are for flags
  -- something something BCO_READ_LARGE_ARG with (index_at 0#) rather than always BCO_NEXT?
  do
    hsc_env <- liftDebugger getSession

    -- The BRK_FUN is the first instruction, unless BCO_NAME is enabled, in
    -- which case it's the second.
    let bRK_FUN_offset
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AddBcoName (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) = Int
2 -- BCO_NAME + ptrs ix.
          | Bool
otherwise = Int
0 :: Int

    let find_ixs_fv = String -> RemoteExpr a
forall a. String -> RemoteExpr a
Remote.raw (String -> RemoteExpr a) -> String -> RemoteExpr a
forall a b. (a -> b) -> a -> b
$
          String
"\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bRK_FUN_offset String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"""#))
                    in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then
                        Data.Maybe.Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#)
                      else Data.Maybe.Nothing"""
    rs_fv <- liftDebuggerOrFail $ Remote.eval
      (find_ixs_fv `Remote.app` Remote.untypedRef instrs_array_fv)

    mparsed_bco_brk <- liftDebugger $ obtainParsedTerm "Ixs" maxBound True anyTy rs_fv $
      maybeParser $ BCOBreakPointInfo <$>
        subtermWith 0 wordParser <*> subtermWith 1 wordParser <*> subtermWith 2 wordParser
                                 <*> subtermWith 3 wordParser <*> subtermWith 4 wordParser
    case mparsed_bco_brk of
      Left [TermParseError]
errs -> Debugger (Maybe BCOBreakPointInfo)
-> TermParser (Maybe BCOBreakPointInfo)
forall a. Debugger a -> TermParser a
liftDebugger (Debugger (Maybe BCOBreakPointInfo)
 -> TermParser (Maybe BCOBreakPointInfo))
-> Debugger (Maybe BCOBreakPointInfo)
-> TermParser (Maybe BCOBreakPointInfo)
forall a b. (a -> b) -> a -> b
$ do
        Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Error ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TermParseError -> SDoc) -> [TermParseError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (TermParseError -> String) -> TermParseError -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermParseError -> String
getTermErrorMessage) [TermParseError]
errs))
        IO (Maybe BCOBreakPointInfo) -> Debugger (Maybe BCOBreakPointInfo)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe BCOBreakPointInfo)
 -> Debugger (Maybe BCOBreakPointInfo))
-> IO (Maybe BCOBreakPointInfo)
-> Debugger (Maybe BCOBreakPointInfo)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe BCOBreakPointInfo)
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Failed to parse BCOClosure's BRK_FUN"
      Right Maybe BCOBreakPointInfo
r -> Maybe BCOBreakPointInfo -> TermParser (Maybe BCOBreakPointInfo)
forall a. a -> TermParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BCOBreakPointInfo
r

unpackStackFields :: ForeignRef [Stack.StackField] -> Maybe [Int] -> Debugger [ForeignHValue]
unpackStackFields :: ForeignRef [StackField] -> Maybe [Int] -> Debugger [ForeignHValue]
unpackStackFields ForeignRef [StackField]
fldsRef Maybe [Int]
mixs = Debugger [ForeignHValue] -> Debugger [ForeignHValue]
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (Debugger [ForeignHValue] -> Debugger [ForeignHValue])
-> Debugger [ForeignHValue] -> Debugger [ForeignHValue]
forall a b. (a -> b) -> a -> b
$ do
  (Either BadEvalStatus [ForeignHValue] -> Debugger [ForeignHValue]
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus [ForeignHValue] -> Debugger [ForeignHValue])
-> Debugger (Either BadEvalStatus [ForeignHValue])
-> Debugger [ForeignHValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Debugger (Either BadEvalStatus [ForeignHValue])
 -> Debugger [ForeignHValue])
-> Debugger (Either BadEvalStatus [ForeignHValue])
-> Debugger [ForeignHValue]
forall a b. (a -> b) -> a -> b
$ RemoteExpr (IO [HValue])
-> Debugger (Either BadEvalStatus [ForeignHValue])
forall a.
RemoteExpr (IO [a])
-> Debugger (Either BadEvalStatus [ForeignRef a])
Remote.evalIOList (RemoteExpr (IO [HValue])
 -> Debugger (Either BadEvalStatus [ForeignHValue]))
-> RemoteExpr (IO [HValue])
-> Debugger (Either BadEvalStatus [ForeignHValue])
forall a b. (a -> b) -> a -> b
$
    RemoteExpr ([StackField] -> Maybe [Int] -> IO [HValue])
Remote.unpackStackFields RemoteExpr ([StackField] -> Maybe [Int] -> IO [HValue])
-> ForeignRef [StackField]
-> RemoteExpr (Maybe [Int] -> IO [HValue])
forall a b. RemoteExpr (a -> b) -> ForeignRef a -> RemoteExpr b
`Remote.appRef` ForeignRef [StackField]
fldsRef RemoteExpr (Maybe [Int] -> IO [HValue])
-> RemoteExpr (Maybe [Int]) -> RemoteExpr (IO [HValue])
forall a b. RemoteExpr (a -> b) -> RemoteExpr a -> RemoteExpr b
`Remote.app` String -> RemoteExpr (Maybe [Int])
forall a. String -> RemoteExpr a
Remote.raw (Maybe [Int] -> String
forall a. Show a => a -> String
show Maybe [Int]
mixs)

--------------------------------------------------------------------------------
-- * Exception Info
--------------------------------------------------------------------------------

-- | Evaluate helper code inside the debuggee that turns the exception context
-- into our 'ExceptionInfo' structure.
collectExceptionInfo :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo)
collectExceptionInfo :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo)
collectExceptionInfo ForeignRef SomeException
excRef = Debugger (Maybe ExceptionInfo) -> Debugger (Maybe ExceptionInfo)
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (Debugger (Maybe ExceptionInfo) -> Debugger (Maybe ExceptionInfo))
-> Debugger (Maybe ExceptionInfo) -> Debugger (Maybe ExceptionInfo)
forall a b. (a -> b) -> a -> b
$ do
  -- 1. Add a "data" declaration for the datatype the expression will return
  _ <- String -> Debugger [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
runDecls String
exceptionInfoData
  -- 2. Gather information about the exception.
  evalRes <- Remote.eval
    (Remote.raw exceptionInfoExpr `Remote.app` Remote.ref excRef)
  case evalRes of
    Left BadEvalStatus
err -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Debug (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
forall doc. IsLine doc => String -> doc
Ppr.text String
"Failed to evaluate exception info:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
Ppr.<+> String -> SDoc
forall doc. IsLine doc => String -> doc
Ppr.text (BadEvalStatus -> String
forall a. Show a => a -> String
show BadEvalStatus
err)
      Maybe ExceptionInfo -> Debugger (Maybe ExceptionInfo)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExceptionInfo
forall a. Maybe a
Nothing
    Right ForeignRef (ZonkAny 0)
fhv -> do
      parsed <- String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser ExceptionInfo
-> Debugger (Either [TermParseError] ExceptionInfo)
forall a.
String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
"Exception info" Int
4 Bool
True Type
anyTy (ForeignRef (ZonkAny 0) -> ForeignHValue
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignRef (ZonkAny 0)
fhv)
        TermParser ExceptionInfo
exceptionInfoParser
      case parsed of
        Left [TermParseError]
errs -> do
          Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Debug (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
Ppr.text String
"Failed to parse exception info:"
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
Ppr.<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
Ppr.vcat ((TermParseError -> SDoc) -> [TermParseError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
forall doc. IsLine doc => String -> doc
Ppr.text (String -> SDoc)
-> (TermParseError -> String) -> TermParseError -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermParseError -> String
getTermErrorMessage) [TermParseError]
errs)
          Maybe ExceptionInfo -> Debugger (Maybe ExceptionInfo)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExceptionInfo
forall a. Maybe a
Nothing
        Right ExceptionInfo
info -> Maybe ExceptionInfo -> Debugger (Maybe ExceptionInfo)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptionInfo -> Maybe ExceptionInfo
forall a. a -> Maybe a
Just ExceptionInfo
info)

-- | Parse the helper 'ExceptionInfoNode' structure produced inside the
-- debuggee into our externally facing 'ExceptionInfo'.
exceptionInfoParser :: TermParser ExceptionInfo
exceptionInfoParser :: TermParser ExceptionInfo
exceptionInfoParser = do
  cwd <- IO AbsFilePath -> TermParser AbsFilePath
forall a. IO a -> TermParser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AbsFilePath -> TermParser AbsFilePath)
-> IO AbsFilePath -> TermParser AbsFilePath
forall a b. (a -> b) -> a -> b
$ String -> AbsFilePath
mkAbsolute (String -> AbsFilePath) -> IO String -> IO AbsFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
  ExceptionInfo
    <$> subtermWith 0 stringParser
    <*> subtermWith 1 stringParser
    <*> subtermWith 2 stringParser
    <*> subtermWith 3 (maybeParser stringParser)
    <*> subtermWith 4 (maybeParser $ exceptionLocationTupleParser cwd)
    <*> subtermWith 5 (parseList exceptionInfoParser)
  where
    -- Parsed from @(String, Int, Int)@.
    -- See Note [Paths should be made absolute at the source]
    exceptionLocationTupleParser :: AbsFilePath -> TermParser SourceSpan
    exceptionLocationTupleParser :: AbsFilePath -> TermParser SourceSpan
exceptionLocationTupleParser AbsFilePath
prefix = do
      locFile <- Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser String
stringParser
      srcLine <- subtermWith 1 intParser
      srcCol <- subtermWith 2 intParser
      pure SourceSpan
        { file = prefix /> locFile
        , startLine = srcLine
        , startCol = srcCol
        , endLine = srcLine
        , endCol = srcCol
        }

-- | Definition for the helper 'ExceptionInfoNode' data type compiled into the
-- debuggee to aid in transporting nested exception information.
-- We need a specific datatype because ExceptionInfoNode is recursive.
exceptionInfoData :: String
exceptionInfoData :: String
exceptionInfoData = String
"""
  data ExceptionInfoNode = ExceptionInfoNode
    { exceptionNodeTypeName :: String
    , exceptionNodeFullTypeName :: String
    , exceptionNodeMessage :: String
    , exceptionNodeContext :: Data.Maybe.Maybe String
    , exceptionNodeSourceSpan :: Data.Maybe.Maybe (String, Int, Int)
    , exceptionNodeInner :: [ExceptionInfoNode]
    }
  """

-- | Helper expression run in the debuggee that walks the exception context and
-- populates the 'ExceptionInfoNode' structure.
exceptionInfoExpr :: String
exceptionInfoExpr :: String
exceptionInfoExpr = String
"""
  let collectExceptionInfo :: Control.Exception.SomeException -> ExceptionInfoNode
      collectExceptionInfo se' =
        case se' of
          Control.Exception.SomeException exc ->
            let ctx = Control.Exception.someExceptionContext se'
                rendered = Control.Exception.Context.displayExceptionContext ctx
                whileHandling = Control.Exception.Context.getExceptionAnnotations ctx
                innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling
                sourceSpan = exceptionContextLocation ctx
                simpleTypeName = Data.Typeable.tyConName tc
                modulePrefix = case Data.Typeable.tyConModule tc of
                  mdl | Prelude.null mdl -> \"\"
                      | otherwise -> mdl Prelude.++ \".\"
                packagePrefix = case Data.Typeable.tyConPackage tc of
                  pkg | Prelude.null pkg -> \"\"
                      | otherwise -> pkg Prelude.++ \":\"
                tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)
                fullTypeName = packagePrefix Prelude.++ modulePrefix Prelude.++ simpleTypeName
                unwrap (Control.Exception.WhileHandling inner) = inner
                contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered
            in ExceptionInfoNode
                 { exceptionNodeTypeName = simpleTypeName
                 , exceptionNodeFullTypeName = fullTypeName
                 , exceptionNodeMessage = Control.Exception.displayException se'
                 , exceptionNodeContext = contextText
                 , exceptionNodeSourceSpan = sourceSpan
                 , exceptionNodeInner = innerNodes
                 }
      exceptionContextLocation ctx =
        let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of
              Data.Maybe.Just (_, loc) ->
                Data.Maybe.Just
                  ( GHC.Exception.srcLocFile loc
                  , GHC.Exception.srcLocStartLine loc
                  , GHC.Exception.srcLocStartCol loc
                  )
              Data.Maybe.Nothing -> Data.Maybe.Nothing
            bts :: [Control.Exception.Backtrace.Backtraces]
            bts = Control.Exception.Context.getExceptionAnnotations ctx
        in case bts of
             bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of
               Data.Maybe.Just cs -> fromCallStack cs
               Data.Maybe.Nothing -> Data.Maybe.Nothing
             [] -> Data.Maybe.Nothing
  in collectExceptionInfo
  """