WIP: Callstacks

cabal.project

@@ -2,6 +2,10 @@ packages: . haskell-debugger-view
 
 allow-newer: ghc-bignum,containers,time,ghc,base,template-haskell
 
+ghc-options: -finfo-table-map
+package *
+    ghc-options: -finfo-table-map
+
 if !os(windows)
     package *
         -- Speeds up a bit

haskell-debugger.cabal

@@ -58,20 +58,25 @@ library
     exposed-modules:  GHC.Debugger,
                       GHC.Debugger.Breakpoint,
                       GHC.Debugger.Breakpoint.Map,
-                      GHC.Debugger.Evaluation,
                       GHC.Debugger.Logger,
+                      GHC.Debugger.Run,
                       GHC.Debugger.Stopped,
                       GHC.Debugger.Stopped.Variables,
-                      GHC.Debugger.Utils,
+
                       GHC.Debugger.Runtime,
+                      GHC.Debugger.Runtime.Eval,
                       GHC.Debugger.Runtime.Instances,
                       GHC.Debugger.Runtime.Instances.Discover,
 
                       GHC.Debugger.Runtime.Term.Parser,
                       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 +87,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,
@@ -96,6 +102,7 @@ library
                       aeson >= 2.2.3 && < 2.3,
                       hie-bios >= 0.15 && < 0.18,
                       file-embed >= 0.0.16 && < 0.1,
+                      attoparsec >= 0.13 && < 0.15,
                       -- Logger dependencies
                       time >= 1.14 && < 2,
                       prettyprinter >= 1.7.1 && < 2,

haskell-debugger/GHC/Debugger.hs

@@ -7,7 +7,7 @@ import System.Exit
 import Control.Monad.IO.Class
 
 import GHC.Debugger.Breakpoint
-import GHC.Debugger.Evaluation
+import GHC.Debugger.Run
 import GHC.Debugger.Stopped
 import GHC.Debugger.Monad
 import GHC.Debugger.Interface.Messages
@@ -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/Interface/Messages.hs

@@ -39,8 +39,11 @@
   -- | 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,7 +211,8 @@
   | DidContinue EvalResult
   | DidStep EvalResult
   | DidExec EvalResult
-  | GotStacktrace [StackFrame]
+  | GotThreads [DebuggeeThread]
+  | GotStacktrace [DbgStackFrame]
   | GotScopes [ScopeInfo]
   | GotVariables (Either VarInfo [VarInfo])
   | Aborted String
@@ -234,6 +238,16 @@
   | 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, Eq, Ord)
+
 data EvalResult
   = EvalCompleted { resultVal :: String
                   , resultType :: String
@@ -243,13 +257,26 @@
                   -- 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 StackFrame
-  = StackFrame
+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 DbgStackFrame
+  = DbgStackFrame
     { name :: String
     -- ^ Title of stack frame
     , sourceSpan :: SourceSpan
@@ -264,6 +291,6 @@
 deriving instance Show Command
 deriving instance Show Response
 
 instance Show GHC.InternalBreakpointId where
   show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix
 

haskell-debugger/GHC/Debugger/Monad.hs

@@ -61,6 +61,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)
 
@@ -92,6 +93,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
 
@@ -177,6 +181,7 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' extraGhcArgs m
           }
           -- Default debugger settings
           `GHC.xopt_set` LangExt.PackageImports
+          `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile
           `GHC.gopt_set` GHC.Opt_ImplicitImportQualified
           `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges
           `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges
@@ -482,6 +487,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/Evaluation.hs → haskell-debugger/GHC/Debugger/Run.hs

@@ -9,7 +9,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
-module GHC.Debugger.Evaluation where
+module GHC.Debugger.Run where
 
 import GHC.Utils.Outputable
 import Control.Monad.IO.Class
@@ -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/Runtime/Eval.hs

@@ -0,0 +1,118 @@
+-- | Lower-level interface to evaluating things in the (possibly remote) debuggee process
+module GHC.Debugger.Runtime.Eval where
+
+import GHC
+import GHC.Driver.Env
+import GHC.Runtime.Interpreter as Interp
+import Control.Monad.Reader
+import GHC.Driver.Config
+import GHCi.RemoteTypes
+import GHCi.Message
+import Control.Exception
+
+import GHC.Debugger.Monad
+
+--------------------------------------------------------------------------------
+-- * Evaluation on Foreign Heap Values
+--------------------------------------------------------------------------------
+
+-- | Evaluate `f x` for any @f :: a -> b@ and any @x :: a@.
+-- The result is the foreign reference to a heap value of type @b@
+evalApplication :: ForeignHValue -> ForeignHValue -> Debugger (Either BadEvalStatus ForeignHValue)
+evalApplication fref aref = evalApplicationExpr ((EvalThis fref) `EvalApp` (EvalThis aref))
+
+-- | Evaluate `f x y` for any @f :: a -> b ->@ and any @x :: a, y :: b@.
+-- The result is the foreign reference to a heap value of type @c@
+evalApplication2 :: ForeignHValue -> ForeignHValue -> ForeignHValue -> Debugger (Either BadEvalStatus ForeignHValue)
+evalApplication2 fref aref bref = evalApplicationExpr ((EvalThis fref) `EvalApp` (EvalThis aref) `EvalApp` (EvalThis bref))
+
+-- | Evaluate the given 'EvalExpr' of type @b@ in the debuggee process.
+-- The result is the foreign reference to a heap value of type @b@
+evalApplicationExpr :: EvalExpr ForeignHValue -> Debugger (Either BadEvalStatus ForeignHValue)
+evalApplicationExpr eval_expr = do
+  hsc_env <- getSession
+  mk_list_fv <- compileExprRemote "(pure @IO . (:[])) :: a -> IO [a]"
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  handleSingStatus <$> liftIO (
+    evalStmt interp eval_opts $ (EvalThis mk_list_fv) `EvalApp` eval_expr
+    )
+
+-- | Evaluate `f x` for any @f :: a -> IO b@ and any @x :: a@.
+-- The result is the foreign reference to a heap value of type @b@ (the IO action is executed)
+evalApplicationIO :: ForeignHValue -> ForeignHValue -> Debugger (Either BadEvalStatus ForeignHValue)
+evalApplicationIO fref aref = do
+  hsc_env <- getSession
+  fmap_list_fv <- compileExprRemote "(fmap (:[])) :: IO a -> IO [a]"
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  handleSingStatus <$> liftIO (evalStmt interp eval_opts $ (EvalThis fmap_list_fv) `EvalApp` ((EvalThis fref) `EvalApp` (EvalThis aref)))
+
+-- | Evaluate `f x` for any @f :: a -> IO [b]@ and any @x :: a@.
+-- The result is a list of foreign references to the heap values returned in the list of @b@s (the IO action is executed)
+evalApplicationIOList :: ForeignHValue -> ForeignHValue -> Debugger (Either BadEvalStatus [ForeignHValue])
+evalApplicationIOList fref aref = do
+  hsc_env <- getSession
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  handleMultiStatus <$> liftIO (evalStmt interp eval_opts $ (EvalThis fref) `EvalApp` (EvalThis aref))
+
+-- | Evaluate `x` for any @x :: a@.
+-- The result is the foreign reference to a heap value of type @a@
+evalThis :: ForeignHValue -> Debugger (Either BadEvalStatus ForeignHValue)
+evalThis aref = do
+  hsc_env <- getSession
+  mk_list_fv <- compileExprRemote "(pure @IO . (:[])) :: a -> IO [a]"
+
+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone
+      interp = hscInterp hsc_env
+
+  handleSingStatus <$> liftIO (
+    evalStmt interp eval_opts $ (EvalThis mk_list_fv) `EvalApp` (EvalThis aref)
+    )
+
+-- ** Handling evaluation results ----------------------------------------------
+
+-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a single value
+handleSingStatus :: EvalStatus_ [ForeignHValue] [HValueRef] -> Either BadEvalStatus ForeignHValue
+handleSingStatus status =
+  case status of
+    EvalComplete _ (EvalSuccess [res]) -> Right res
+    EvalComplete _ (EvalSuccess []) ->
+      Left EvalReturnedNoResults
+    EvalComplete _ (EvalSuccess (_:_:_)) ->
+      Left EvalReturnedTooManyResults
+    EvalComplete _ (EvalException e) ->
+      Left (EvalRaisedException (fromSerializableException e))
+    EvalBreak {} ->
+      --TODO: Could we accidentally hit this if we set a breakpoint regardless of whether EvalStep=None? perhaps.
+      Left EvalHitUnexpectedBreakpoint
+
+-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a list of values
+handleMultiStatus :: EvalStatus_ [ForeignHValue] [HValueRef] -> Either BadEvalStatus [ForeignHValue]
+handleMultiStatus status =
+  case status of
+    EvalComplete _ (EvalSuccess res) -> Right res
+    EvalComplete _ (EvalException e) ->
+      Left (EvalRaisedException (fromSerializableException e))
+    EvalBreak {} ->
+      Left EvalHitUnexpectedBreakpoint
+
+--------------------------------------------------------------------------------
+-- * Exceptions
+--------------------------------------------------------------------------------
+
+data BadEvalStatus
+  = EvalRaisedException SomeException
+  | EvalHitUnexpectedBreakpoint
+  | EvalReturnedNoResults
+  | EvalReturnedTooManyResults
+  deriving Show
+
+instance Exception BadEvalStatus