{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OrPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- TODO
-- - [] Consider caching once and forall the expressions we dynamically compile and load in this module.
module GHC.Debugger.Runtime.Thread
  ( getRemoteThreadIdFromRemoteContext
  , getRemoteThreadId
  , listAllLiveRemoteThreads

  -- * Re-exports
  , ThreadInfo(..)
  ) where

import Data.Maybe
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.IORef
import GHC.Conc.Sync

#if MIN_VERSION_ghc(10,1,0)
import GHC.Builtin.WiredIn.Types
#else
import GHC.Builtin.Types
#endif
import GHC.Runtime.Heap.Inspect
import GHC.Utils.Outputable

import GHCi.Message
import GHCi.RemoteTypes

import Colog.Core as Logger
import GHC.Debugger.Monad
import GHC.Debugger.Interface.Messages
import GHC.Debugger.Runtime.Term.Parser
import GHC.Debugger.Runtime.Thread.Map

import GHC.Debugger.Runtime.Interpreter.Types
import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote
import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote

#if MIN_VERSION_ghc(9,14,2)
import qualified GHC.Debugger.Runtime.Interpreter as Debuggee
#else
import qualified GHC.Debugger.Runtime.Interpreter.Legacy as Debuggee
#endif

-- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak'
getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId
getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId
getRemoteThreadIdFromRemoteContext ForeignRef (ResumeContext [HValueRef])
fctxt = do
  -- Get the ResumeContext term and fetch the resumeContextThreadId field
  parsed_threadid <- String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser Term
-> Debugger (Either [TermParseError] Term)
forall a.
String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
"RemoteContext's ThreadId" Int
2 Bool
True Type
anyTy (ForeignRef (ResumeContext [HValueRef]) -> ForeignHValue
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignRef (ResumeContext [HValueRef])
fctxt)
                        (Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
2{-RemoteContext's ThreadId-} TermParser Term
anyTerm)
  case parsed_threadid 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 RemoteThreadId -> Debugger RemoteThreadId
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteThreadId -> Debugger RemoteThreadId)
-> IO RemoteThreadId -> Debugger RemoteThreadId
forall a b. (a -> b) -> a -> b
$ String -> IO RemoteThreadId
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Failed to parse remote ResumeContext's thread id"
    Right Term{val :: Term -> ForeignHValue
val=ForeignHValue
threadIdVal} -> do
      ForeignRef ThreadId -> Debugger RemoteThreadId
getRemoteThreadId (ForeignHValue -> ForeignRef ThreadId
forall a b. ForeignRef a -> ForeignRef b
castForeignRef ForeignHValue
threadIdVal)
    Either [TermParseError] Term
_ -> IO RemoteThreadId -> Debugger RemoteThreadId
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteThreadId -> Debugger RemoteThreadId)
-> IO RemoteThreadId -> Debugger RemoteThreadId
forall a b. (a -> b) -> a -> b
$ String -> IO RemoteThreadId
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Expected threadIdTerm to be a Term!"

-- | Call 'listThreads' on the (possibly) remote debuggee process to get the
-- list of threads running on the debuggee. Filter by running threads
-- This may include the debugger threads if using the internal interpreter.
listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ThreadInfo ForeignRef)]
listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ThreadInfo ForeignRef)]
listAllLiveRemoteThreads = do
  threadInfos <- Debugger [ThreadInfo ForeignRef]
Debuggee.listThreads
  fmap catMaybes $
    forM threadInfos $ \ThreadInfo ForeignRef
ti -> do
      rti <- ForeignRef ThreadId -> Debugger RemoteThreadId
getRemoteThreadId ThreadInfo ForeignRef
ti.threadInfoRef
      pure $ case ti.threadInfoStatus of
        (ThreadStatus
ThreadRunning ; ThreadBlocked{}) -> (RemoteThreadId, ThreadInfo ForeignRef)
-> Maybe (RemoteThreadId, ThreadInfo ForeignRef)
forall a. a -> Maybe a
Just (RemoteThreadId
rti, ThreadInfo ForeignRef
ti)
        (ThreadStatus
ThreadDied    ; ThreadStatus
ThreadFinished)  -> Maybe (RemoteThreadId, ThreadInfo ForeignRef)
forall a. Maybe a
Nothing

getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId
getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId
getRemoteThreadId ForeignRef ThreadId
threadIdRef = do
  thread_id_fv <- Either BadEvalStatus (ForeignRef Word64)
-> Debugger (ForeignRef Word64)
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus (ForeignRef Word64)
 -> Debugger (ForeignRef Word64))
-> Debugger (Either BadEvalStatus (ForeignRef Word64))
-> Debugger (ForeignRef Word64)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteExpr Word64
-> Debugger (Either BadEvalStatus (ForeignRef Word64))
forall a.
RemoteExpr a -> Debugger (Either BadEvalStatus (ForeignRef a))
Remote.eval
    (RemoteExpr ThreadId -> RemoteExpr Word64
Remote.fromThreadId (ForeignRef ThreadId -> RemoteExpr ThreadId
forall a. ForeignRef a -> RemoteExpr a
Remote.ref ForeignRef ThreadId
threadIdRef))

  parsed_int <-
    obtainParsedTerm "ThreadId's Int value" 2 True wordTy{-really, Word64, but we won't look at the type-} (castForeignRef thread_id_fv) intParser

  case parsed_int 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 RemoteThreadId -> Debugger RemoteThreadId
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteThreadId -> Debugger RemoteThreadId)
-> IO RemoteThreadId -> Debugger RemoteThreadId
forall a b. (a -> b) -> a -> b
$ String -> IO RemoteThreadId
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Failed to parse remote thread id on fromThreadId result!"
    Right Int
tid_int -> do

      tmap_ref <- (DebuggerState -> IORef ThreadMap) -> Debugger (IORef ThreadMap)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef ThreadMap
threadMap
      -- unconditionally write to the map the foreign ref (it should always
      -- refer to the same ThreadId as a possible existing entry)
      liftIO $ modifyIORef' tmap_ref $
        insertThreadMap tid_int threadIdRef

      return (RemoteThreadId tid_int)