Progress towards callstacks and multi-threaded debugging

- Use proper threadId when stopped at a breakpoint
- Get threadId as stackframe question
- Report actual threads on 'getThreads'
- Filter 'getThreads' threads by not-dead ones
- package: Add ghc-heap dependency

Author: alt-romes

haskell-debugger.cabal

@@ -62,7 +62,7 @@ library
                       GHC.Debugger.Logger,
                       GHC.Debugger.Stopped,
                       GHC.Debugger.Stopped.Variables,
-                      GHC.Debugger.Utils,
+
                       GHC.Debugger.Runtime,
                       GHC.Debugger.Runtime.Instances,
                       GHC.Debugger.Runtime.Instances.Discover,
@@ -71,7 +71,11 @@ library
                       GHC.Debugger.Runtime.Term.Key,
                       GHC.Debugger.Runtime.Term.Cache,
 
+                      GHC.Debugger.Runtime.Thread,
+                      GHC.Debugger.Runtime.Thread.Map,
+
                       GHC.Debugger.Monad,
+                      GHC.Debugger.Utils,
 
                       GHC.Debugger.Session,
                       GHC.Debugger.Session.Builtin,
@@ -82,6 +86,7 @@ library
                       ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,
                       ghc-boot-th >= 9.14 && < 9.16,
                       ghc-boot >= 9.14 && < 9.16,
+                      ghc-heap >= 9.14 && < 9.16,
                       array >= 0.5.8 && < 0.6,
                       containers >= 0.7 && < 0.9,
                       mtl >= 2.3 && < 3,

haskell-debugger/GHC/Debugger.hs

@@ -26,7 +26,8 @@ execute recorder = \case
     DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition)
   DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled
   GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp
-  GetStacktrace -> GotStacktrace <$> getStacktrace
+  GetThreads -> GotThreads <$> getThreads
+  GetStacktrace i -> GotStacktrace <$> getStacktrace i
   GetScopes -> GotScopes <$> getScopes
   GetVariables kind -> GotVariables <$> getVariables kind
   DoEval exp_s -> DidEval <$> doEval exp_s

haskell-debugger/GHC/Debugger/Evaluation.hs

@@ -43,6 +43,7 @@ import GHC.Debugger.Utils
 import GHC.Debugger.Interface.Messages
 import GHC.Debugger.Logger as Logger
 import qualified GHC.Debugger.Breakpoint.Map as BM
+import GHC.Debugger.Runtime.Thread
 
 data EvalLog
   = LogEvalModule GHC.Module
@@ -207,10 +208,12 @@ handleExecResult = \case
           Just VarInfo{varValue, varType, varRef} -> do
             return (EvalCompleted varValue varType varRef)
           Nothing     -> liftIO $ fail "doEval failed"
-    ExecBreak {breakNames = _, breakPointId = Nothing} ->
+    ExecBreak {breakNames = _, breakPointId = Nothing} -> do
       -- Stopped at an exception
       -- TODO: force the exception to display string with Backtrace?
-      return EvalStopped{breakId = Nothing}
+      rt_id <- getRemoteThreadIdFromContext
+      return EvalStopped{ breakId = Nothing
+                        , breakThread = rt_id }
     ExecBreak {breakNames = _, breakPointId = Just bid} -> do
       bm <- liftIO . readIORef =<< asks activeBreakpoints
       case BM.lookup bid bm of
@@ -222,8 +225,10 @@ handleExecResult = \case
             EvalStopped{} -> error "impossible for doEval"
             EvalCompleted { resultVal, resultType } ->
               if resultType == "Bool" then do
-                if resultVal == "True" then
-                  return EvalStopped{breakId = Just bid}
+                if resultVal == "True" then do
+                  rt_id <- getRemoteThreadIdFromContext
+                  return EvalStopped{ breakId = Just bid
+                                    , breakThread = rt_id }
                 else
                   resume
               else do
@@ -237,7 +242,10 @@ handleExecResult = \case
               resume
 
         -- Unconditionally 'EvalStopped' in all other cases
-        _ -> return EvalStopped{breakId = Just bid}
+        _ -> do
+          rt_id <- getRemoteThreadIdFromContext
+          return EvalStopped{ breakId = Just bid
+                            , breakThread = rt_id }
 
 -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'.
 inspectName :: Name -> Debugger (Maybe VarInfo)
@@ -248,3 +256,9 @@ inspectName n = do
       pure Nothing
     Just tt -> Just <$> tyThingToVarInfo tt
 
+getRemoteThreadIdFromContext :: Debugger RemoteThreadId
+getRemoteThreadIdFromContext = do
+  GHC.getResumeContext >>= \case
+    resume1:_ ->
+      getRemoteThreadIdFromRemoteContext $ GHC.resumeContext resume1
+    _ -> error "No resumes but stopped?!?"

haskell-debugger/GHC/Debugger/Interface/Messages.hs

@@ -39,8 +39,11 @@ data Command
   -- | Clear all function breakpoints
   | ClearFunctionBreakpoints
 
+  -- | Get all threads
+  | GetThreads
+
   -- | Get the evaluation stacktrace until the current breakpoint.
-  | GetStacktrace
+  | GetStacktrace RemoteThreadId
 
   -- | Get the list of available scopes at the current breakpoint
   | GetScopes
@@ -208,6 +211,7 @@ data Response
   | DidContinue EvalResult
   | DidStep EvalResult
   | DidExec EvalResult
+  | GotThreads [DebuggeeThread]
   | GotStacktrace [StackFrame]
   | GotScopes [ScopeInfo]
   | GotVariables (Either VarInfo [VarInfo])
@@ -234,6 +238,16 @@ data BreakFound
   | ManyBreaksFound [BreakFound]
   deriving (Show)
 
+-- | A reference to a remote thread by remote id
+-- See 'getRemoteThreadId'.
+newtype RemoteThreadId = RemoteThreadId
+    { remoteThreadIntRef :: Int
+    -- ^ The number identifier of the thread on the (remote) interpreter. To
+    -- find the proper remote 'ThreadId' corresponding to this numeric
+    -- identifier, lookup the 'remoteThreadIntRef' in the 'ThreadMap'
+    }
+    deriving Show
+
 data EvalResult
   = EvalCompleted { resultVal :: String
                   , resultType :: String
@@ -243,11 +257,24 @@ data EvalResult
                   -- that the user can expand as a normal variable.
                   }
   | EvalException { resultVal :: String, resultType :: String }
-  | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }
+  | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId
+                  -- ^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)?
+                  , breakThread :: RemoteThreadId
+                  -- ^ In which thread did we hit the breakpoint?
+                  }
   -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped.
   | EvalAbortedWith String
   deriving (Show)
 
+data DebuggeeThread
+  = DebuggeeThread
+    { tId :: !RemoteThreadId
+    -- ^ An identifier for a thread on the (possibly remote) debuggee process
+    , tName :: !(Maybe String)
+    -- ^ Thread label, if there is one
+    }
+    deriving (Show)
+
 data StackFrame
   = StackFrame
     { name :: String

haskell-debugger/GHC/Debugger/Monad.hs

@@ -59,6 +59,7 @@ import GHC.Debugger.Runtime.Term.Key
 import GHC.Debugger.Session
 import GHC.Debugger.Session.Builtin
 import qualified GHC.Debugger.Breakpoint.Map as BM
+import qualified GHC.Debugger.Runtime.Thread.Map as TM
 
 import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)
 
@@ -90,6 +91,9 @@ data DebuggerState = DebuggerState
       , rtinstancesCache :: IORef RuntimeInstancesCache
       -- ^ RuntimeInstancesCache
 
+      , threadMap         :: IORef TM.ThreadMap
+      -- ^ 'ThreadMap' for threads spawned by the debuggee
+
       , genUniq           :: IORef Int
       -- ^ Generates unique ints
 
@@ -478,6 +482,7 @@ initialDebuggerState l hsDbgViewUid =
   DebuggerState <$> liftIO (newIORef BM.empty)
                 <*> liftIO (newIORef mempty)
                 <*> liftIO (newIORef emptyRuntimeInstancesCache)
+                <*> liftIO (newIORef TM.emptyThreadMap)
                 <*> liftIO (newIORef 0)
                 <*> pure hsDbgViewUid
                 <*> pure l

haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs

@@ -7,6 +7,9 @@ module GHC.Debugger.Runtime.Instances.Discover
   , RuntimeInstancesCache
   , getDebugViewInstance
   , emptyRuntimeInstancesCache
+
+  -- * Finding runtime instances utils
+  , compileAndLoadMthd
   ) where
 
 import Data.IORef
@@ -105,7 +108,7 @@ findDebugViewInstance needle_ty = do
   case mhdv_uid of
     Just hdv_uid -> do
       let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName
-      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr)
+      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) :: RdrName
 
       (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do
 
@@ -119,16 +122,16 @@ findDebugViewInstance needle_ty = do
 
         -- Try to compile and load an expression for all methods of `DebugView`
         -- applied to the dictionary for the given Type (`needle_ty`)
-        let debugValueMN  = mthdRdrName "debugValueIOWrapper"
-            debugFieldsMN = mthdRdrName "debugFieldsIOWrapper"
+        let debugValueME  = nlHsVar $ mthdRdrName "debugValueIOWrapper"
+            debugFieldsME = nlHsVar $ mthdRdrName "debugFieldsIOWrapper"
             debugValueWrapperMT =
               mkVisFunTyMany needle_ty $
                 mkTyConApp ioTyCon [mkListTy varValueIOTy]
             debugFieldsWrapperMT =
               mkVisFunTyMany needle_ty $
                 mkTyConApp ioTyCon [mkListTy varFieldsIOTy]
-        !debugValue_fval  <- compileAndLoadMthd debugValueMN  debugValueWrapperMT
-        !debugFields_fval <- compileAndLoadMthd debugFieldsMN debugFieldsWrapperMT
+        !debugValue_fval  <- compileAndLoadMthd debugValueME  debugValueWrapperMT
+        !debugFields_fval <- compileAndLoadMthd debugFieldsME debugFieldsWrapperMT
 
         let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
             interp    = hscInterp hsc_env
@@ -170,18 +173,16 @@ findDebugViewInstance needle_ty = do
 
 -- | Try to compile and load a class method for the given type.
 --
--- E.g. @compileAndLoadMthd "debugValue" (<ty> -> VarValue)@ returns the
--- foreign value for an expression @debugValue@ applied to the dictionary for
--- the requested type.
-compileAndLoadMthd :: RdrName -- ^ Name of method/name of function that takes dictionary
-                   -> Type    -- ^ The final type of expr when funct is alredy applied to dict
+-- E.g. @compileAndLoadMthd (nlHsVar "foo") <ty>@ returns the
+-- foreign value for an expression @foo@ applied to the dictionary required to
+-- produce the final requested type
+compileAndLoadMthd :: LHsExpr GhcPs -- ^ Expr of method/expr that takes dictionary
+                   -> Type         -- ^ The final type of expr when funct is alredy applied to dict
                    -> TcM ForeignHValue
-compileAndLoadMthd mthName mthTy = do
+compileAndLoadMthd expr mthTy = do
   hsc_env <- getTopEnv
 
-  let expr = nlHsVar mthName
-
-  -- Rn, Tc, desugar applied to DebugView dictionary
+  -- Rn, Tc, desugar applied to dictionary
   (expr', _)    <- rnExpr (unLoc expr)
   (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)
   ev            <- simplifyTop wcs