GitLab

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

Commits:

c3176c10

by Rodrigo Mesquita at 2026-09-23T17:27:47+01:00

Look up a thread's ResumeContext without taking a lock

modifyMVar is unnecessarily expensive and blocking when most often we
just care about reading without modifying. optimize for default case
(thread context already exists). It is called every single time a
breakpoint is hit (regardless of whether we stop there, e.g. in
interpreter_steplocal we do not stop there often)

-3.3% improvement over original regression

5d3cb7fa

by Rodrigo Mesquita at 2026-09-23T17:28:04+01:00

Every thread resume-context keeps a var for its EvalStatus

Kill the global mapping from thread id to EvalStatus

Instead, keep the EvalStatus in the ResumeContext associated to a thread
in the threadContextVar (where entries are created on breakpoints being
hit and when writing an EvalComplete result)

Before, every breakpoint hit meant reading the global map TVar and
deleting a map entry which did a lot of allocations. Now, we have a
Nothing variable which we overwrite to "take" rather than deleting from
a Map and allocating the GlobalDbgMap too. Note that for every
breakpoint hit we'd have to insert the ThreadId entry in the map again
(because we deleted it last time we resumed), again allocating
unnecessarily. Now it's only a look up on the map and an update on the
variable directly.

And a LOT of breakpoints were hit on interpreter_steplocal, stress
testing the cost of hitting a breakpoint

The isolated threads move to their own top-level TVar Set.

-4.4% improvement over the regression

3ffdef29

by Rodrigo Mesquita at 2026-09-23T17:28:15+01:00

Move whether a thread is isolated to the same global map

Stops us from reconstructing the set every time this changed instead to
being a per thread variable just toggled on/off, by default non-isolated
like before (before it was Set.empty, Set.insert for True, Set.delete
for FALSE). This is more straightforward -- there's always an isolation
mode per thread and we can toggle it directly

reduces slightly allocations, but the main advantage is killing a second
global map and making it more uniform with just one thread map and no
membership check for toggledness.

4a826f19

by Rodrigo Mesquita at 2026-10-01T11:22:37+01:00

Prefer foldl' in readAnyThreadEvalBreak txn

retry 'orElse' next is just next, so we might as well use a strict fold

a3e3a66f

by Rodrigo Mesquita at 2026-10-01T16:36:23+01:00

Add inline TODO about improving efficiency of readyAnyThreadBreak

It is currently O(N) in number of threads that have hit breakpoints

It should be number of *live* threads that have hit breaks, bc we still need to find a way to evacuate threads from the map

ee339734

by Rodrigo Mesquita at 2026-10-01T17:33:52+01:00

Set global breakpoint action in sandboxIO rather than withBreakAction

aa7ab6ca

by Rodrigo Mesquita at 2026-10-01T17:35:10+01:00

TODO comment on breakOnException being global rather than per-thread

a7150ad3
by Rodrigo Mesquita at 2026-10-05T16:21:30+01:00
```
WIP: Asynchronous eval/resume
```

Changes:

compiler/GHC/Runtime/Eval.hs

@@ -188,12 +188,13 @@ execOptions = ExecOptions
      -- by default we just care about breakpoints hit in this eval thread
+   }
 --- | Run a statement in the current interactive context.
 +-- | Run a statement in the current interactive context, as a new thread in the interpreter.
 +-- Returns an action which blocks waiting for the execution to finish and yield a result.
  execStmt
    :: GhcMonad m
    => String             -- ^ a statement (bind or expression)
    -> ExecOptions
 -  -> m ExecResult
 +  -> m (m ExecResult)
  execStmt input exec_opts@ExecOptions{..} = do
      hsc_env <- getSession
@@ -204,13 +205,15 @@ execStmt input exec_opts@ExecOptions{..} = do
      case mb_stmt of
        -- empty statement / comment
 -      Nothing -> return (ExecComplete (Right []) 0)
 +      Nothing -> pure (pure (ExecComplete (Right []) 0))
        Just stmt -> execStmt' stmt input exec_opts
  -- | Like `execStmt`, but takes a parsed statement as argument. Useful when
  -- doing preprocessing on the AST before execution, e.g. in GHCi (see
  -- GHCi.UI.runStmt).
 -execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
 +--
 +-- Returns an action which blocks waiting for the execution to finish and yield a result.
 +execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m (m ExecResult)
  execStmt' stmt stmt_text ExecOptions{..} = do
      hsc_env <- getSession
      let interp = hscInterp hsc_env
@@ -226,21 +229,22 @@ execStmt' stmt stmt_text ExecOptions{..} = do
      case r of
        Nothing ->
          -- empty statement / comment
 -        return (ExecComplete (Right []) 0)
 +        pure (pure (ExecComplete (Right []) 0))
        Just (ids, hval, fix_env) -> do
          updateFixityEnv fix_env
          let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep)
                            (enableIsolateThreadBreaks execIsolateMode)
 -        status <- liftIO $ evalStmt interp eval_opts (execWrap hval)
 +        rtid <- liftIO $ evalStmt interp eval_opts (execWrap hval)
          let ic = hsc_IC hsc_env
              bindings = (ic_tythings ic, ic_gre_cache ic)
              size = ghciHistSize idflags'
+-
 -        handleRunStatus execSingleStep eval_opts stmt_text bindings ids
 -                        status (emptyHistory size)
 +        pure $ do
 +          status <- liftIO (waitThreadResult interp rtid)
 +          handleRunStatus execSingleStep eval_opts stmt_text bindings ids
 +                          status (emptyHistory size)
  runDecls :: GhcMonad m => String -> m [TyThing]
  runDecls = runDeclsWithLocation "<interactive>" 1
@@ -326,16 +330,16 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do
        return (ExecComplete (Left (fromSerializableException e)) alloc)
      -- Nothing case: we stopped when an exception was raised, not at a breakpoint.
 -    EvalBreak apStack_ref Nothing resume_ctxt ccs -> do
 -      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
 -      apStack_fhv     <- liftIO $ mkFinalizedHValue interp apStack_ref
 +    EvalBreak apStack_ref Nothing resume_tid ccs -> do
 +      resume_tid_fhv <- liftIO $ mkFinalizedHValue interp resume_tid
 +      apStack_fhv    <- liftIO $ mkFinalizedHValue interp apStack_ref
        let span = mkGeneralSrcSpan (fsLit "<unknown>")
        (hsc_env1, break_ids) <- liftIO $
          bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing
        let
          resume = Resume
            { resumeStmt = expr
 -          , resumeContext = resume_ctxt_fhv
 +          , resumeContext = resume_tid_fhv
            , resumeBindings = bindings
            , resumeFinalIds = final_ids
            , resumeApStack = apStack_fhv
@@ -356,7 +360,7 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do
      -- The interpreter yields on a breakpoint if:
      --  - the breakpoint was explicitly enabled (in @BreakArray@)
      --  - or one of the stepping options in @EvalOpts@ caused us to stop at one
 -    EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
 +    EvalBreak apStack_ref (Just eval_break) resume_tid ccs -> do
        let ibi = evalBreakpointToId eval_break
        let hug = hsc_HUG hsc_env
        info_brks  <- liftIO $ readIModBreaks hug ibi
@@ -368,8 +372,8 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do
          breakArray <- getBreakArray interp ibi info_brks
          breakpointStatus interp breakArray (ibi_info_index ibi)
 -      apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
 -      resume_ctxt_fhv   <- liftIO $ mkFinalizedHValue interp resume_ctxt
 +      apStack_fhv    <- liftIO $ mkFinalizedHValue interp apStack_ref
 +      resume_tid_fhv <- liftIO $ mkFinalizedHValue interp resume_tid
        -- This breakpoint is enabled or we mean to break here;
        -- we want to stop instead of just logging it.
@@ -382,7 +386,7 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do
          let
            resume = Resume
              { resumeStmt = expr
 -            , resumeContext = resume_ctxt_fhv
 +            , resumeContext = resume_tid_fhv
              , resumeBindings = bindings
              , resumeFinalIds = final_ids
              , resumeApStack = apStack_fhv
@@ -398,7 +402,9 @@ handleRunStatus step eval_opts expr bindings final_ids status history0 = do
          return (ExecBreak break_ids (Just ibi) resume)
        else do
          -- resume with the same step type
 -        status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv
 +        status <- liftIO $ do
 +          GHCi.resumeStmt interp eval_opts resume_tid_fhv
 +          GHCi.waitThreadResult interp resume_tid_fhv
          history <- if not tracing then pure history0 else do
            history1 <- liftIO $ mkHistory hug apStack_fhv ibi
            let !history' = history1 `consBL` history0
@@ -414,7 +420,9 @@ resumeExec :: GhcMonad m
             -> ThreadBreaksIsolationMode
             -> Maybe Int
             -> Resume
 -           -> m ExecResult
 +           -> m (m ExecResult)
 +           -- ^ Returns an action which blocks waiting for the resumed thread
 +           -- to break again or yield a result
  resumeExec step isolateMode mbCnt r = do
    hsc_env <- getSession
    let ic = hsc_IC hsc_env
@@ -438,7 +446,7 @@ resumeExec step isolateMode mbCnt r = do
    case r of
      Resume { resumeStmt = expr
 -           , resumeContext = fhv
 +           , resumeContext = rtid
             , resumeBindings = bindings
             , resumeFinalIds = final_ids
             , resumeApStack = apStack
@@ -454,17 +462,19 @@ resumeExec step isolateMode mbCnt r = do
            let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
                              (enableIsolateThreadBreaks isolateMode)
 -          status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
 -          let prevHistoryLst = fromListBL 50 hist
 -              hug = hsc_HUG hsc_env
 -              hist' = case mb_brkpt of
 -                 Nothing -> pure prevHistoryLst
 -                 Just bi
 -                   | breakHere False step span -> do
 -                      hist1 <- liftIO (mkHistory hug apStack bi)
 -                      return $ hist1 `consBL` fromListBL 50 hist
 -                   | otherwise -> pure prevHistoryLst
 -          handleRunStatus step eval_opts expr bindings final_ids status =<< hist'
 +          liftIO $ GHCi.resumeStmt interp eval_opts rtid
 +          pure $ do
 +            status <- liftIO $ GHCi.waitThreadResult interp rtid
 +            let prevHistoryLst = fromListBL 50 hist
 +                hug = hsc_HUG hsc_env
 +                hist' = case mb_brkpt of
 +                   Nothing -> pure prevHistoryLst
 +                   Just bi
 +                     | breakHere False step span -> do
 +                        hist1 <- liftIO (mkHistory hug apStack bi)
 +                        return $ hist1 `consBL` fromListBL 50 hist
 +                     | otherwise -> pure prevHistoryLst
 +            handleRunStatus step eval_opts expr bindings final_ids status =<< hist'
  setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m ()   -- #19157
  setupBreakpoint interp ibi cnt = do
@@ -1275,7 +1285,9 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
    updateFixityEnv fix_env
    let eval_opts = initEvalOpts dflags EvalStepNone True
 -  status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)
 +  status <- liftIO $ do
 +    rtid <- evalStmt interp eval_opts (EvalThis hvals_io)
 +    waitThreadResult interp rtid
    case status of
      EvalComplete _ (EvalSuccess [hval]) -> return hval
      EvalComplete _ (EvalException e) ->

compiler/GHC/Runtime/Interpreter.hs

@@ -11,6 +11,7 @@ module GHC.Runtime.Interpreter
    , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
    , resumeStmt
    , abandonStmt
 +  , waitThreadResult
    , evalIO
    , evalString
    , evalStringToIOString
@@ -286,11 +287,11 @@ evalStmt
    :: Interp
    -> EvalOpts
    -> EvalExpr ForeignHValue
 -  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 +  -> IO (ForeignRef ThreadId)
  evalStmt interp opts foreign_expr = do
 -  status <- withExpr foreign_expr $ \expr ->
 +  r <- withExpr foreign_expr $ \expr ->
      interpCmd interp (EvalStmt opts expr)
 -  handleEvalStatus interp status
 +  mkFinalizedHValue interp r
   where
    withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
    withExpr (EvalThis fhv) cont =
@@ -304,17 +305,25 @@ resumeStmt
    :: Interp
    -> EvalOpts
    -> ForeignRef ThreadId
 -  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 +  -> IO ()
  resumeStmt interp opts resume_tid = do
 -  status <- withForeignRef resume_tid $ \rhv ->
 +  withForeignRef resume_tid $ \rhv ->
      interpCmd interp (ResumeStmt opts rhv)
 -  handleEvalStatus interp status
  abandonStmt :: Interp -> ForeignRef ThreadId -> IO ()
  abandonStmt interp resume_tid =
    withForeignRef resume_tid $ \rhv ->
      interpCmd interp (AbandonStmt rhv)
 +waitThreadResult
 +  :: Interp
 +  -> ForeignRef ThreadId
 +  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
 +waitThreadResult interp tid = do
 +  status <- withForeignRef tid $ \rhv -> do
 +    interpCmd interp (WaitThreadResult rhv)
 +  handleEvalStatus interp status
++
  handleEvalStatus
    :: Interp
    -> EvalStatus [HValueRef]
@@ -417,8 +426,9 @@ whereFrom interp ref =
  seqHValue :: Interp -> UnitEnv -> Logger -> ForeignHValue -> IO (EvalResult ())
  seqHValue interp unit_env logger ref =
    withForeignRef ref $ \hval -> do
 -    status <- interpCmd interp (Seq hval)
 -    handleSeqHValueStatus interp unit_env logger status
 +    rtid   <- interpCmd interp (Seq hval)
 +    status <- interpCmd interp (WaitThreadResult rtid)
 +    handleSeqHValueStatus interp unit_env logger (clearEvalStatus status)
  evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
  evalBreakpointToId eval_break =
@@ -460,9 +470,10 @@ handleSeqHValueStatus interp unit_env logger eval_status =
              Just modbreaks -> put =<< getBreakLoc (readIModModBreaks hug) ibi modbreaks
        -- resume the seq (:force) processing in the iserv process
 -      withForeignRef resume_ctxt_fhv $ \hval -> do
 -        status <- interpCmd interp (ResumeSeq hval)
 -        handleSeqHValueStatus interp unit_env logger status
 +      withForeignRef resume_ctxt_fhv $ \rtid -> do
 +        interpCmd interp (ResumeSeq rtid)
 +        status <- interpCmd interp (WaitThreadResult rtid)
 +        handleSeqHValueStatus interp unit_env logger (clearEvalStatus status)
      (EvalComplete _ r) -> return r
@@ -771,3 +782,9 @@ readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaks
  fromEvalResult :: EvalResult a -> IO a
  fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
  fromEvalResult (EvalSuccess a) = return a
++
 +clearEvalStatus :: EvalStatus a -> EvalStatus ()
 +clearEvalStatus = \case
 +  EvalComplete w (EvalException se) -> EvalComplete w (EvalException se)
 +  EvalComplete w (EvalSuccess _)    -> EvalComplete w (EvalSuccess ())
 +  EvalBreak ap mb rt rccs           -> EvalBreak ap mb rt rccs

libraries/ghci/GHCi/Message.hs

@@ -62,6 +62,8 @@ import Data.Dynamic
  import Data.Typeable (TypeRep)
  import Data.IORef
  import Data.Map (Map)
 +import Data.IntMap (IntMap)
 +import qualified Data.IntMap as IM
  import Foreign
  import GHC.Generics
  import GHC.Stack.CCS
@@ -132,13 +134,13 @@ data Message a where
    EvalStmt
      :: EvalOpts
      -> EvalExpr HValueRef {- IO [a] -}
 -    -> Message (EvalStatus [HValueRef]) {- [a] -}
 +    -> Message (RemoteRef ThreadId) {- [a] -}
    -- | Resume evaluation of a statement after a breakpoint
    ResumeStmt
     :: EvalOpts
     -> RemoteRef ThreadId
 -   -> Message (EvalStatus [HValueRef])
 +   -> Message ()
    -- | Abandon evaluation of a statement after a breakpoint
    AbandonStmt
@@ -240,12 +242,23 @@ data Message a where
    -- | Evaluate something. This is used to support :force in GHCi.
    Seq
      :: HValueRef
 -    -> Message (EvalStatus ())
 +    -> Message (RemoteRef ThreadId)
    -- | Resume forcing a free variable in a breakpoint (#2950)
    ResumeSeq
      :: RemoteRef ThreadId
 -    -> Message (EvalStatus ())
 +    -> Message ()
++
 +  WaitThreadResult
 +    :: RemoteRef ThreadId
 +    -> Message (EvalStatus [HValueRef])
++
 +  WaitAnyThreadBreak
 +    :: Message EvalBreak
++
 +  WaitThreadResultOrAnyThreadBreak
 +    :: RemoteRef ThreadId
 +    -> Message (EvalStatus [HValueRef])
    -- | User-defined request encoded as a tag/payload pair.  This is left
    -- uninterpreted by GHC and is meant for GHC API applications to be able to supply
@@ -724,6 +737,7 @@ data Pipe = Pipe
    { getSome :: !(IO ByteString)
    , putAll :: !(B.Builder -> IO ())
    , pipeLeftovers :: !(IORef (Maybe ByteString))
 +  -- , waitingStatus :: !(IORef (Map (RemoteRef ThreadId) (MVar (EvalStatus ()))))
+   }
  -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write.
@@ -744,8 +758,19 @@ mkPipeFromContinuations getSome putAll = do
  remoteCall :: Binary a => Pipe -> Message a -> IO a
  remoteCall pipe msg = do
 -  writePipe pipe (putMessage msg)
 -  readPipe pipe get
 +  -- synchronous, write, read
 +  writePipe pipe (putMessage msg) -- write goes in the handle
 +  readPipe pipe get -- instead, this takes from the channel
 +  -- the channel is fed from the handle by a different thread that creates a
 +  -- stream of notifications and a stream of replies.
 +  --
 +  -- Since a reply will only come in response to a write request that happens
 +  -- while the entire is thing is locked, we'll only get 1 reply per write, and
 +  -- in fact the channel of replies is just 1 cell (MVar)
 +  --
 +  -- ATOMIC:
 +  --  write pipe
 +  --  read reply -- will never have more than 1 reply, because the Lock guarantees only 1 write.
  writePipe :: Pipe -> Put -> IO ()
  writePipe Pipe{..} put = putAll $ execPut put
@@ -755,6 +780,11 @@ remoteTHCall pipe msg = do
    writePipe pipe (putTHMessage msg)
    readPipe pipe get
 +-- todo: this will have to drain the pipe and write to a queue?
 +--  Normal replies pushed to reply channel
 +--  Remote call instead of ReadPipe, reads from the channel.
 +--
 +--  We need to drain channel for notifications...
  readPipe :: Pipe -> Get a -> IO a
  readPipe Pipe{..} get = do
    leftovers <- readIORef pipeLeftovers

libraries/ghci/GHCi/Run.hs

@@ -128,6 +128,15 @@ run m = case m of
    Seq ref -> doSeq ref
    ResumeSeq ref -> resumeSeq ref
 +  WaitThreadResult tid -> localRef tid >>= atomically . readThreadEvalStatus
 +  WaitAnyThreadBreak   -> atomically $ readAnyThreadEvalBreak
 +  WaitThreadResultOrAnyThreadBreak t -> do
 +    tid <- localRef t
 +    atomically $
 +      readThreadEvalStatus tid
 +        `orElse`
 +      (EvalPaused <$> readAnyThreadEvalBreak)
++
    Shutdown            -> unexpectedMessage m
    RunTH {}            -> unexpectedMessage m
    RunModFinalizers {} -> unexpectedMessage m
@@ -206,7 +215,7 @@ tryEval io = do
  --------------------------------------------------------------------------------
 -evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
 +evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (RemoteRef ThreadId)
  evalStmt opts expr = do
    io <- mkIO expr
    sandboxIO opts $ do
@@ -248,16 +257,16 @@ evalStringToString r str = do
  -- The UI process has more and therefore also can show more
  -- information about the breakpoint than the current iserv
  -- process.
 -doSeq :: RemoteRef a -> IO (EvalStatus ())
 -doSeq ref = clearEvalStatus <$> do
 +doSeq :: RemoteRef a -> IO (RemoteRef ThreadId)
 +doSeq ref = do
      sandboxIO evalOptsSeq $ do
        _ <- (void $ evaluate =<< localRef ref)
        return []
  -- | Process a ResumeSeq message. Continue the :force processing     #2950
  -- after a breakpoint.
 -resumeSeq :: RemoteRef ThreadId -> IO (EvalStatus ())
 -resumeSeq hvref = clearEvalStatus <$> resumeStmt evalOptsSeq hvref
 +resumeSeq :: RemoteRef ThreadId -> IO ()
 +resumeSeq hvref = resumeStmt evalOptsSeq hvref
  evalOptsSeq :: EvalOpts
  evalOptsSeq = EvalOpts
@@ -296,15 +305,16 @@ abandonStmt hvref = do
  --------------------------------------------------------------------------------
 -resumeStmt :: EvalOpts -> RemoteRef ThreadId -> IO (EvalStatus [HValueRef])
 +resumeStmt :: EvalOpts -> RemoteRef ThreadId -> IO ()
  resumeStmt opts rtid = do
    resumeThreadId <- localRef rtid
    ResumeContext{..} <- getThreadResumeContext resumeThreadId
 -  withBreakAction opts resumeThreadId $ \waitForResult ->
 -    mask_ $ do
 -      putMVar resumeBreakMVar () -- this awakens the stopped thread...
 -      redirectInterrupts resumeThreadId $
 -        waitForResult
 +  setBreakAction opts resumeThreadId -- See Note [TODO: all break options must be set every time]
 +  -- withBreakAction opts resumeThreadId $ \waitForResult ->
 +    -- mask_ $ do
 +  putMVar resumeBreakMVar () -- this awakens the stopped thread...
 +      -- redirectInterrupts resumeThreadId $
 +      --   waitForResult
  -- When running a computation, we redirect ^C exceptions to the running
  -- thread.  ToDo: we might want a way to continue even if the target
@@ -316,26 +326,51 @@ resumeStmt opts rtid = do
  -- only while we execute the user's code.  We can't afford to lose the final
  -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
 -sandboxIO :: EvalOpts -> IO [HValueRef] -> IO (EvalStatus [HValueRef])
 +sandboxIO :: EvalOpts -> IO [HValueRef] -> IO (RemoteRef ThreadId)
  sandboxIO opts io
      | useSandboxThread opts
      = do
          wait <- newEmptyMVar
 +        -- If we are evaluating expressions (sandboxIO), then make sure the
 +        -- global breakpoint action is set.
 +        --
 +        -- TODO: Is this thread unsafe? Already running threads may access this
 +        -- pointer as we write it when evaluating a new expression.
 +        --
 +        -- A solution would be to have an "initialize interpreter" command
 +        -- which sets this at the start. A different solution is to have a
 +        -- global lock and only write this once here, then lock.
 +        poke breakPointIOAction globalBreakStablePtr
++
          tid <- forkIO $ do
            takeMVar wait -- don't run anything in this thread before
 -                        -- `withBreakAction` has a chance to set up.
 +                        -- `setBreakAction` has a chance to set up.
            tid <- myThreadId
            labelThread tid "GHCi sandbox"
++
 +            -- WHEN THE THREAD IS FINISHED, write the value itself.
 +            --
 +            -- we only write the TID status map in two places:
 +            --
 +            -- When the "main" thread finishes (here)
 +            -- When any thread hits a breakpoint (global break action)
            unsafeUnmask runIt >>= writeThreadEvalStatus tid
 +            -- TODO: This unsafe-unmask is very dubious. Consult with Andrea. I
 +            -- don't think we should be uninterruptable masking interp commands
 +            -- somewhere else. This should just be runIt?
 -        -- We are running in uninterruptibleMask
 -        withBreakAction opts tid $ \waitForResult -> do
 -          putMVar wait ()
 -          redirectInterrupts tid $ unsafeUnmask $
 -            waitForResult
 +        -- We are running in uninterruptibleMask -- TODO WHY??
 +        setBreakAction opts tid
 +        putMVar wait ()
++
 +        mkRemoteRef tid
 +        -- withBreakAction opts tid $ \waitForResult -> do
 +        --   putMVar wait ()
 +        --   redirectInterrupts tid $ unsafeUnmask $
 +        --     waitForResult
      | otherwise
      = do
@@ -349,7 +384,17 @@ sandboxIO opts io
        -- tracing, etc.) need the expression to be running in a
        -- separate thread, so debugging is only enabled when
        -- using the sandbox.
 -      runIt
 +      tid <- forkIO (pure ())
 +      runIt >>= writeThreadEvalStatus tid
 +      mkRemoteRef tid
 +        -- We `runIt` on the main thread, but fork a new thread to store to the
 +        -- result with `writeThreadEvalStatus` to fit the asynchronous API. We
 +        -- can't use myThreadId because if the user happens to runIt twice
 +        -- before awaiting, the second result will clobber the first.
++
 +        -- TODO We have to be careful evacuating this map bc there may be
 +        -- uncollected results from finished threads. So the thread map can't
 +        -- be weak refs ? Or maybe because of the RemoteRef it's fine. Ah, prob.
    where
      runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
@@ -404,17 +449,17 @@ sandboxIO opts io
  -- whenever "main" or one of the threads spawned by "main" hit a breakpoint,
  -- rather than just "main" being observed. This should be used for the main
  -- debuggee execution of a debugger.
 -withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a
 -withBreakAction opts tid@(ThreadId tid#) act
 -  = bracket setBreakAction resetBreakAction (\_ -> act waitForResult)
 +-- withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a
 +-- withBreakAction opts tid@(ThreadId tid#) act = do
++
 +setBreakAction :: EvalOpts -> ThreadId -> IO ()
 +setBreakAction opts tid@(ThreadId tid#) = do
 +  ctx <- getThreadResumeContext tid
 +  setBreakAction' ctx
 +    -- bracket _ (resetBreakAction ctx) (\_ -> act (waitForResult ctx))
    where
 -    setBreakAction = do
 -      poke breakPointIOAction globalBreakStablePtr
 -         -- TODO: This is poke thread unsafe, as one thread might be accessing this
 -         -- global variable while this thread tries to overwrite it. We should
 -         -- rather do it when the interpreter process/internal is initialized
 -         -- somehow.
+-
 +    setBreakAction' ctx = do
 +      -- TODO: TERRIBLY NOT MULTI-THREAD FRIENDLY. Each thread needs its own RTS flag exceptionFlag, like we have for step-in or step-out.
        runIf breakOnException $ \_ -> poke exceptionFlag 1
          -- Breaking on exceptions is not enabled by default, since it
          -- might be a bit surprising. The exception flag is turned off
@@ -422,32 +467,34 @@ withBreakAction opts tid@(ThreadId tid#) act
        runIf# singleStep rts_enableStopNextBreakpoint
        runIf# stepOut    rts_enableStopAfterReturn
 -      runIf  isolateThreadBreaks setIsolatedThread
 -    resetBreakAction () = do
 -      poke exceptionFlag 0
 +      runIfCtx ctx isolateThreadBreaks setIsolatedCtx
++
 +    resetBreakAction ctx () = do
 +      poke exceptionFlag 0 -- just wrong, expection flag should be per-thread
        rts_disableStopAfterReturn    tid#
        rts_disableStopNextBreakpoint tid#
 -      runIf isolateThreadBreaks unsetIsolatedThread
 +      runIfCtx ctx isolateThreadBreaks unsetIsolatedCtx
        -- freeStablePtr stablePtr TODO: we never free the global stablePtr for
        -- global action. Maybe we should have a de-init for clean up.
        -- TODO: don't set it in `setBreakAction` either. Should be on
        -- interpreter initialization.
 -    runIf  pred what = when (pred opts) (what tid)
 -    runIf# pred what = when (pred opts) (what tid#)
 +    runIf    pred what     = when (pred opts) (what tid)
 +    runIf#   pred what     = when (pred opts) (what tid#)
 +    runIfCtx ctx pred what = when (pred opts) (what ctx)
 -    waitForResult
 +    waitForResult ctx
        | isolateThreadBreaks opts
        = atomically $
 -          readThreadEvalStatus tid
 +          readCtxEvalStatus ctx
        | otherwise
        = atomically $
            (EvalPaused <$> readAnyThreadEvalBreak)
            `orElse`
 -          readThreadEvalStatus tid
 +          readCtxEvalStatus ctx
  -- While we're waiting for the sandbox thread to return a result, if
  -- the current thread receives an asynchronous exception we re-throw
@@ -476,9 +523,3 @@ redirectInterrupts target wait = do
         Nothing -> wait
         Just target -> do throwTo target (e :: SomeException); wait
 -clearEvalStatus :: EvalStatus a -> EvalStatus ()
 -clearEvalStatus = \case
 -  EvalComplete w (EvalException se) -> EvalComplete w (EvalException se)
 -  EvalComplete w (EvalSuccess _)    -> EvalComplete w (EvalSuccess ())
 -  EvalBreak ap mb rt rccs           -> EvalBreak ap mb rt rccs
+-

libraries/ghci/GHCi/Run/Breakpoints.hs

@@ -8,10 +8,12 @@ module GHCi.Run.Breakpoints
    -- * Per-thread breakpoints
    , readThreadEvalStatus, readAnyThreadEvalBreak
    , writeThreadEvalStatus
 +  , readCtxEvalStatus, writeCtxEvalStatus
    -- ** Isolating thread breakpoints
    , withIsolatedThread
    , setIsolatedThread, unsetIsolatedThread
 +  , setIsolatedCtx, unsetIsolatedCtx
    -- ** Querying the global thread breakpoint map
    , listOtherPausedThreads
@@ -29,18 +31,15 @@ import GHCi.Message
  import GHCi.RemoteTypes
  import qualified Data.Map as Map
 -import qualified Data.Set as Set
  import Control.Concurrent
  import Control.Exception
  import qualified Data.ByteString.Short.Internal as BS
 -#if defined(PROFILING)
 -import GHC.Data.ShortByteString
 -#endif
  import GHC.Exts
  import GHC.Stack
  import Foreign hiding (void)
  import GHC.Conc.Sync
  import GHC.IO hiding ( bracket )
 +import Control.Monad
  --------------------------------------------------------------------------------
  -- * Global break action
@@ -72,7 +71,7 @@ globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction
  globalBreakAction :: BreakpointCallback
  globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
    tid <- myThreadId
 -  ResumeContext{..} <- getThreadResumeContext tid
 +  ctx@ResumeContext{..} <- getThreadResumeContext tid
    resume_r <- mkRemoteRef tid
    apStack_r <- mkRemoteRef apStack
    ccs <- toRemotePtr <$> getCCSOf apStack
@@ -83,7 +82,7 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
        info_mod <- BS.packCString (Ptr info_mod#)
        info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
        pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
 -  writeThreadEvalStatus tid $ EvalBreak apStack_r mb_breakpoint resume_r ccs
 +  writeCtxEvalStatus ctx $ EvalBreak apStack_r mb_breakpoint resume_r ccs
    -- Block until this thread is resumed (by the thread which took the
    -- `ResumeContext` from the `statusMVar`).
@@ -109,14 +108,19 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
  -- Succeeds when the given thread writes to the global debugger map an eval result.
  readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef])
  readThreadEvalStatus tid = do
 -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 -  case Map.lookup tid threadEvalStatuses of
 +  ctxs <- readTVar threadContextsVar
 +  case Map.lookup tid ctxs of
 +    Just ctx -> readCtxEvalStatus ctx
 +    Nothing  -> retry -- to write a thread break or result, the
 +                      -- 'threadContextsVar' entry will be created
++
 +-- | Like 'readThreadEvalStatus', but when the 'ResumeContext' is already
 +-- available (to avoid looking it up unnecessarily).
 +readCtxEvalStatus :: ResumeContext -> STM (EvalStatus [HValueRef])
 +readCtxEvalStatus ResumeContext{resumeEvalStatus} =
 +  readTVar resumeEvalStatus >>= \case
      Just r  -> do
 -      writeTVar globalDbgStatusVar
 -        GlobalDbgStatus
 -          { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it
 -          , isolatedThreads
 -          }
 +      writeTVar resumeEvalStatus Nothing -- clear it
        pure r
      Nothing -> retry -- until someone writes the result for this thread
@@ -126,38 +130,46 @@ readThreadEvalStatus tid = do
  -- The debugger will be waiting for threads to break using `readAnyThreadEvalBreak`.
  --
  -- Succeeds when any thread hits a breakpoint.
 +--
 +-- TODO: Instead of reading all elems of the map, we could have the global
 +-- break action write breakpoints hit into a global `TChan ThreadId`, and then
 +-- `readAnyThreadEvalBreak` would read off of this channel breakpoints that
 +-- were hit, and do the lookup on the map by ThreadId, retrying if it has
 +-- already been handled (i.e. set to Nothing)
  readAnyThreadEvalBreak :: STM EvalBreak
  readAnyThreadEvalBreak = do
 -  dbgs <- readTVar globalDbgStatusVar
 +  ctxs <- readTVar threadContextsVar
    -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet
 -  foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs))
 +  foldl' (\next ctx -> next `orElse` readBreak ctx) retry (Map.elems ctxs)
    where
 -    readStatus GlobalDbgStatus{..} (tid, _) -- don't look at isolated threads
 -      | Set.member tid isolatedThreads
 -      = 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
 -              , isolatedThreads
 -              }
 -          pure b
 +    readBreak ResumeContext{resumeEvalStatus, resumeIsolated} = do
 +      isolated <- readTVar resumeIsolated
 +      if isolated
 +        then retry -- don't look at isolated threads
 +        else readTVar resumeEvalStatus >>= \case
 +          Just (EvalPaused b) -> do
 +            writeTVar resumeEvalStatus Nothing
 +            pure b
 +          Just EvalComplete{} ->
 +            retry -- successes can be read with `readThreadEvalStatus`
 +          Nothing ->
 +            retry -- no status for this thread yet
  writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO ()
 -writeThreadEvalStatus tid status =
 +writeThreadEvalStatus tid status = do
 +  -- get or create a 'ResumeContext' for the thread (e.g. we may write the
 +  -- EvalComplete without breakpoints occurring, so the map won't have an entry):
 +  ctx <- getThreadResumeContext tid
 +  writeCtxEvalStatus ctx status
++
 +-- | Like 'writeThreadEvalStatus', but for when the 'ResumeContext' is already
 +-- available
 +writeCtxEvalStatus :: ResumeContext -> EvalStatus [HValueRef] -> IO ()
 +writeCtxEvalStatus ResumeContext{resumeEvalStatus} status =
    atomically $ do
 -    GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 -    writeTVar globalDbgStatusVar $
 -      GlobalDbgStatus
 -        { threadEvalStatuses =
 -            Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible")
 -                tid status threadEvalStatuses
 -        , isolatedThreads }
 +    readTVar resumeEvalStatus >>= \case
 +      Just{}  -> error "writeCtxEvalStatus: should be impossible"
 +      Nothing -> writeTVar resumeEvalStatus (Just status)
  -- ** Isolating thread breakpoints ---------------------------------------------
@@ -174,23 +186,15 @@ withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread t
  -- expression to run should not be seen at all by the debugger (e.g. when
  -- evaluating an expr to :force a variable)
  setIsolatedThread :: ThreadId -> IO ()
 -setIsolatedThread tid = atomically $ do
 -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 -  writeTVar globalDbgStatusVar
 -    GlobalDbgStatus
 -      { threadEvalStatuses
 -      , isolatedThreads = Set.insert tid isolatedThreads
 -      }
 +setIsolatedThread = getThreadResumeContext >=> setIsolatedCtx
  -- | Undoes 'setIsolatedThread'
  unsetIsolatedThread :: ThreadId -> IO ()
 -unsetIsolatedThread tid = atomically $ do
 -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
 -  writeTVar globalDbgStatusVar
 -    GlobalDbgStatus
 -      { threadEvalStatuses
 -      , isolatedThreads = Set.delete tid isolatedThreads
 -      }
 +unsetIsolatedThread = getThreadResumeContext >=> unsetIsolatedCtx
++
 +setIsolatedCtx, unsetIsolatedCtx :: ResumeContext -> IO ()
 +setIsolatedCtx   ctx = atomically $ writeTVar (resumeIsolated ctx) True
 +unsetIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) False
  -- ** Querying the global thread breakpoint map --------------------------------
@@ -201,64 +205,74 @@ unsetIsolatedThread tid = atomically $ do
  -- the global thread mapping) and are asking about which other threads are
  -- paused to list them.
  listOtherPausedThreads :: IO [ThreadId]
 -listOtherPausedThreads = do
 -  m <- atomically $ readTVar globalDbgStatusVar
 -  pure $ Map.keys $ Map.filter isBreak (threadEvalStatuses m)
 +listOtherPausedThreads = atomically $ do
 +  ctxs <- readTVar threadContextsVar
 +  paused <- mapM isBreak (Map.toList ctxs)
 +  pure [tid | (tid, True) <- paused]
    where
 -    isBreak EvalBreak{}     = True
 -    isBreak EvalComplete{} = False
+-
 --- ** Global thread exec status map --------------------------------------------
+-
 --- | 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...).
 ---
 --- 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 a thread's result by calling
 -  -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression
 -  -- finishes evaluating, see e.g. 'sandboxIO'.
 -  , isolatedThreads    :: !(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.
 -  }
 +    isBreak (tid, ResumeContext{resumeEvalStatus}) = do
 +      status <- readTVar resumeEvalStatus
 +      pure (tid, case status of
 +                   Just EvalBreak{}    -> True
 +                   Just EvalComplete{} -> False
 +                   Nothing             -> False)
  --------------------------------------------------------------------------------
  -- * Per-thread resume-ing
  --------------------------------------------------------------------------------
  getThreadResumeContext :: ThreadId -> IO ResumeContext
 -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do
 -  case Map.lookup tid gbm0 of
 +getThreadResumeContext tid = do
 +  ctxs0 <- readTVarIO threadContextsVar
 +  case Map.lookup tid ctxs0 of
 +    Just ctx -> pure ctx -- common case: hence read without transaction
      Nothing  -> do
 -      r <- ResumeContext <$> newEmptyMVar
 -      let !gbm1 = Map.insert tid r gbm0
 -      pure (gbm1, r)
 -    Just ctx -> do
 -      pure (gbm0, ctx)
 +      new_ctx <- ResumeContext <$> newEmptyMVar
 +                               <*> newTVarIO Nothing
 +                               <*> newTVarIO False
 +      atomically $ do -- write new thread context atomically
 +        ctxs1 <- readTVar threadContextsVar
 +        case Map.lookup tid ctxs1 of
 +          Just ctx -> pure ctx -- already exists
 +          Nothing  -> do
 +            let !ctxs2 = Map.insert tid new_ctx ctxs1
 +            writeTVar threadContextsVar ctxs2
 +            pure new_ctx
 --- | A global mapping from thread ids to the MVars on which they block when stopped.
 -globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext)
 -globalBreakActionMap = unsafePerformIO $ newMVar Map.empty
 -{-# NOINLINE globalBreakActionMap #-}
 +-- | A global mapping from threads to their per-thread state 'ResumeContext'
 +-- (that e.g. contain the MVars on which they block when stopped)
 +threadContextsVar :: TVar (Map.Map ThreadId ResumeContext)
 +threadContextsVar = unsafePerformIO $ newTVarIO Map.empty
 +{-# NOINLINE threadContextsVar #-}
 -newtype ResumeContext = ResumeContext
 -  { resumeBreakMVar :: MVar ()
 +-- | Global context for a thread, which is created and inserted in the global
 +-- 'threadContextsVar' when a thread hits a breakpoint (and, thus, the
 +-- 'globalBreakAction') is run, or when 'withBreakAction' sets the thread
 +-- isolation (e.g. in 'sandboxIO'), or in other calls to
 +-- 'getThreadResumeContext', the function which gets or creates a thread
 +-- 'ResumeContext'.
 +--
 +-- TODO: Rename ResumeContext to something like ThreadContext or
 +-- ThreadDbgContext or (Thread)BreakContext, and fields to something like
 +-- dbgEvalStatus, threadIsolated, ...
 +data ResumeContext = ResumeContext
 +  { resumeBreakMVar :: !(MVar ())
    -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar
 -  -- (gotten from the 'globalBreakActionMap').
 +  -- (gotten from the 'threadContextsVar').
    -- The debugger can unblock that thread by signaling its MVar.
 +  , resumeEvalStatus :: !(TVar (Maybe (EvalStatus [HValueRef])))
 +  -- ^ When a thread hits a breakpoint, the 'globalBreakAction' is run and
 +  -- writes an 'EvalBreak' in this @TVar@ (which was found in 'threadContextsVar').
 +  --
 +  -- Additionally, the 'EvalComplete' result of a thread may be written here
 +  -- using `writeThreadEvalStatus tid (EvalComplete ...)` after the main
 +  -- expression finishes evaluating, see e.g. 'sandboxIO'.
 +  --
 +  -- The variable should be emptied (i.e. set to 'Nothing') by whoever
 +  -- reads the status.
 +  , resumeIsolated :: !(TVar Bool)
 +  -- ^ When set, this thread is meant to be ignored by 'readAnyThreadEvalBreak'.
 +  -- That is, if a thread with resumeIsolated=True hits a breakpoint, its
 +  -- 'EvalBreak' can only be read with @'readThreadEvalStatus' tid@ for this
 +  -- thread's @tid@ directly.
+   }

libraries/ghci/GHCi/Server.hs

@@ -70,6 +70,14 @@ servWithCustom verbose hook pipe restore customHandler = loop
      when verbose $ trace ("msg: " ++ (show msg))
      case msg of
 +      -- The expressions which block waiting for a result musn't block the
 +      -- server thread, so send them off and notify over the wire when done.
 +      --
 +      -- The other end (see 'remoteCall') will be processing notifications, and
 +      -- it will use the returned pointer as the index for the matching notification.
 +      WaitThreadResult                 {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef
 +      WaitAnyThreadBreak               {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef
 +      WaitThreadResultOrAnyThreadBreak {} -> forkIO (run msg >>= (notification =<< myThreadId)) >>= reply . mkRemoteRef
        CustomMessage tag payload -> handleCustom tag payload
        Shutdown -> return ()
        RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc