GitLab

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC

Commits:

a17d329a
by Rodrigo Mesquita at 2026-09-02T14:59:24+01:00
```
WIP
```
9d6ecb8b
by Rodrigo Mesquita at 2026-09-02T18:07:32+01:00
```
HMmm almost there I think
```

2 changed files:

libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Run.hs

Changes:

  {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
      GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
 -    CPP, NamedFieldPuns #-}
 +    CPP, NamedFieldPuns, PatternSynonyms #-}
  {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
  -- |
@@ -14,8 +14,8 @@ module GHCi.Message
    , ConInfoTable(..)
    , THMessage(..), THMsg(..)
    , QResult(..)
 -  , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
 -  , EvalBreakpoint (..)
 +  , EvalStatus_(..,EvalBreak), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
 +  , EvalBreak(..), EvalBreakpoint (..)
    , SerializableException(..)
    , toSerializableException, fromSerializableException
    , THResult(..), THResultType(..)
@@ -415,13 +415,22 @@ type EvalStatus a = EvalStatus_ a a
  data EvalStatus_ a b
    = EvalComplete Word64 (EvalResult a)
 -  | EvalBreak
 +  | EvalPaused EvalBreak
 +  deriving (Generic, Show)
++
 +pattern EvalBreak :: HValueRef -> (Maybe EvalBreakpoint) -> (RemoteRef ThreadId) -> (RemotePtr CostCentreStack) -> EvalStatus_ a b
 +pattern EvalBreak a b c d = EvalPaused (EvalBreak_ a b c d)
 +{-# COMPLETE EvalComplete, EvalBreak #-}
++
 +data EvalBreak
 +  = EvalBreak_
         HValueRef{- AP_STACK -}
         (Maybe EvalBreakpoint)
         (RemoteRef ThreadId)
         (RemotePtr CostCentreStack) -- Cost centre stack
    deriving (Generic, Show)
 +instance Binary EvalBreak
  instance Binary a => Binary (EvalStatus_ a b)
  data EvalBreakpoint = EvalBreakpoint

libraries/ghci/GHCi/Run.hs

  {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
 -    UnboxedTuples, LambdaCase, UnliftedFFITypes #-}
 +    UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns #-}
  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  {-# LANGUAGE BangPatterns #-}
@@ -32,6 +32,7 @@ import GHCi.BreakArray
  import GHCi.StaticPtrTable
  import qualified Data.Map as Map
 +import qualified Data.Set as Set
  import Control.Concurrent
  import Control.DeepSeq
  import Control.Exception
@@ -211,7 +212,9 @@ resumeSeq hvref = clearEvalStatus <$> do
        mask_ $ do
          putMVar resumeBreakMVar () -- this awakens the stopped thread...
          redirectInterrupts resumeThreadId $
 -          readThreadEvalStatus resumeThreadId
 +          withShadowThread resumeThreadId $
 +            atomically $
 +            readThreadEvalStatus resumeThreadId
  evalOptsSeq :: EvalOpts
  evalOptsSeq = EvalOpts
@@ -244,8 +247,9 @@ sandboxIO opts io = do
             labelThread tid "GHCi sandbox"
             unsafeUnmask runIt >>= writeThreadEvalStatus tid
 -         redirectInterrupts tid $ unsafeUnmask $
 -           readThreadEvalStatus tid
 +         redirectInterrupts tid $ unsafeUnmask $ atomically $
 +           (EvalPaused <$> readAnyThreadEvalBreak)
 +            `orElse` readThreadEvalStatus tid
         else
            -- GLUT on OS X needs to run on the main thread. If you
            -- try to use it from another thread then you just get a
@@ -379,7 +383,8 @@ resumeStmt opts rtid = do
      mask_ $ do
        putMVar resumeBreakMVar () -- this awakens the stopped thread...
        redirectInterrupts resumeThreadId $
 -        readThreadEvalStatus resumeThreadId
 +        withShadowThread resumeThreadId $
 +          atomically $ readThreadEvalStatus resumeThreadId
  -- when abandoning a computation we have to
  --      (a) kill the thread with an async exception, so that the
@@ -399,7 +404,8 @@ abandonStmt hvref = do
    ResumeContext{..} <- getThreadResumeContext tid
    killThread tid
    putMVar resumeBreakMVar ()
 -  _ <- readThreadEvalStatus tid
 +  _ <- withShadowThread tid $ atomically $
 +    readThreadEvalStatus tid
    return ()
  -- Malloc and copy the bytes.  We don't have any way to monitor the
@@ -505,42 +511,114 @@ newtype ResumeContext = ResumeContext
    -- The debugger can unblock that thread by signaling its MVar.
+   }
 --- brilliant STM
 --- * only retries when the map is written again
 --- * essentially blocks until the result for this thread is there
 -readThreadEvalStatus :: ThreadId -> IO (EvalStatus [HValueRef])
 +-- | To evaluate a statement in the interpreter, a thread is forked by
 +-- `sandboxIO` to run the statement. To synchronize, the statement result will
 +-- be written by the thread to the global thread dbg status
 +-- (`writeThreadEvalStatus`) and `sandboxIO` will block waiting for either any
 +-- breakpoint to be hit ('readAnyThreadEvalBreak') /or/ for the thread
 +-- specifically to write its final result. To wait for that thread
 +-- specifically, use this function.
 +--
 +-- Succeeds when the given thread writes to the global debugger map an eval result.
 +readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef])
  readThreadEvalStatus tid = do
 -  atomically $ do
 -    dbgmap <- readTVar globalDbgStatusVar
 -    case Map.lookup tid dbgmap of
 -      Just r  -> do
 -        writeTVar globalDbgStatusVar $!
 -          Map.delete tid dbgmap -- clear it
 -        pure r
 -      Nothing -> retry -- until someone writes the result for this thread
 +  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 +  case Map.lookup tid threadEvalStatuses of
 +    Just r  -> do
 +      writeTVar globalDbgStatusVar
 +        GlobalDbgStatus
 +          { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it
 +          , shadowedThreads
 +          }
 +      pure r
 +    Nothing -> retry -- until someone writes the result for this thread
++
 +-- | All threads running in the interpreter will be debugger-enabled, meaning
 +-- if they hit an enabled breakpoint, the 'globalBreakAction' will be
 +-- executed and write a 'EvalBreak' value to the global thread dbg status map.
 +-- The debugger will be waiting for threads to break using `readAnyThreadEvalBreak`.
 +--
 +-- Succeeds when any thread hits a breakpoint.
 +readAnyThreadEvalBreak :: STM EvalBreak
 +readAnyThreadEvalBreak = do
 +  dbgs <- readTVar globalDbgStatusVar
 +  -- try reading all mvars and retry if none yield a result
 +  foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs))
 +  where
 +    readStatus GlobalDbgStatus{..} (tid, _) -- don't look at dbg-shadowed threads
 +      | Set.member tid shadowedThreads
 +      = retry
++
 +    readStatus GlobalDbgStatus{..} (tid, status)
 +      = do
 +      case status of
 +        EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus`
 +        EvalPaused b   -> do
 +          writeTVar globalDbgStatusVar
 +            GlobalDbgStatus
 +              { threadEvalStatuses = Map.delete tid threadEvalStatuses
 +              , shadowedThreads
 +              }
 +          pure b
  writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO ()
 -writeThreadEvalStatus tid new = do
 +writeThreadEvalStatus tid new =
    atomically $ do
 -    dbgmap <- readTVar globalDbgStatusVar
 -    writeTVar globalDbgStatusVar $!
 -      Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") tid new dbgmap
+-
 --- | A global synchronization variable which a thread writes an 'EvalBreak' to
 --- when it hits a breakpoint. This variable is shared across all threads, and
 --- the debugger can read the threads which hit breakpoints by reading from this
 --- variable. It will also be written with 'EvalSuccess' when a `sandboxIO`
 --- action finishes (TODO: wait what? that is a bit weird. so what if we run two
 --- evalStmt? they will both race to write a result? but then how do we tell
 --- which result we got from where? this won't do in general, but let's see if
 --- it can solve some problems first)
 +    GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 +    writeTVar globalDbgStatusVar $
 +      GlobalDbgStatus
 +        { threadEvalStatuses =
 +            Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible")
 +                tid new threadEvalStatuses
 +        , shadowedThreads }
++
 +-- | Make sure that anyone watching for threads hitting breakpoints with
 +-- 'readAnyThreadEvalBreak' ignore the given thread if it ever hits a breakpoint.
  --
 --- IDEA: maybe `sandboxIO` and friends receive as an argument the var on which
 --- to expect the result specifically? And distinguish that from the global break var?
 --- Then we split the EvalSuccess and EvalBreak into two datatypes.
 +-- This forces this thread's result to be received solely through
 +-- 'readThreadEvalStatus' for that ThreadId, which is typically desired when an
 +-- expression to run should not be seen at all by the debugger (e.g. when
 +-- evaluating an expr to :force a variable)
 +withShadowThread :: ThreadId -> IO a -> IO a
 +withShadowThread tid = bracket_ setShadowThread unsetShadowThread
 +  where
 +    setShadowThread = atomically $ do
 +      GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 +      writeTVar globalDbgStatusVar
 +        GlobalDbgStatus
 +          { threadEvalStatuses
 +          , shadowedThreads = Set.insert tid shadowedThreads
 +          }
 +    unsetShadowThread = atomically $ do
 +      GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 +      writeTVar globalDbgStatusVar
 +        GlobalDbgStatus
 +          { threadEvalStatuses
 +          , shadowedThreads = Set.delete tid shadowedThreads
 +          }
++
 +-- | When we launch a new thread using the debugger, we map ... TODO ... all
 +-- threads launched by that main stmt may further spawn threads, and any of
 +-- them might hit a breakpoint (break array toggled, or per-thread step in
 +-- might be used, or pause button, etc...).
  --
 --- Instead, let's just assume we may wait for a single thread's result and this
 --- kind of falls out nicely. See my impl. notes.
 -globalDbgStatusVar :: TVar (Map.Map ThreadId (EvalStatus [HValueRef]))
 -globalDbgStatusVar = unsafePerformIO $ newTVarIO Map.empty
 +-- When we launch that main thread we also write its result to this map. So
 +-- this map will only contain the results of threads we explicitly care to
 +-- observe the result of. Not all threads will write their results here,
 +-- certainly not ones spawned unknowningly by the main stmt.
 +-- ...
 +-- todo words
 +globalDbgStatusVar :: TVar GlobalDbgStatus
 +globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty
  {-# NOINLINE globalDbgStatusVar #-}
++
 +data GlobalDbgStatus = GlobalDbgStatus
 +  { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef]))
 +  -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'.
 +  -- We can additionally observe the result of a thread by calling
 +  -- `writeThreadEvalStatus` at the end with its result, e.g. in 'sandboxIO'
 +  , shadowedThreads    :: !(Set.Set ThreadId)
 +  -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'.
 +  -- That is, even if one of the threads in this set hits a breakpoint, we
 +  -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly.
 +  }