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: ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -1,6 +1,6 @@ {-# 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 ===================================== @@ -1,5 +1,5 @@ {-# 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. + } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32737daaf2f3702b617edf8dca87028... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32737daaf2f3702b617edf8dca87028... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help