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

Commits:

5 changed files:

Changes:

  • compiler/GHC/Driver/Config.hs
    ... ... @@ -41,15 +41,15 @@ data EvalStep
    41 41 
       | EvalStepNone
    42 42
    43 43 
     -- | Extract GHCi options from DynFlags and step
    44 
    -initEvalOpts :: DynFlags -> EvalStep -> EvalOpts
    45 
    -initEvalOpts dflags step =
    44 
    +initEvalOpts :: DynFlags -> EvalStep -> Bool -> EvalOpts
    45 
    +initEvalOpts dflags step isolate_breaks =
    46 46 
       EvalOpts
    47 47 
         { useSandboxThread = gopt Opt_GhciSandbox dflags
    48 48 
         , singleStep       = singleStep
    49 49 
         , stepOut          = stepOut
    50 50 
         , breakOnException = gopt Opt_BreakOnException dflags
    51 51 
         , breakOnError     = gopt Opt_BreakOnError dflags
    52 
    -    , isolateThreadBreaks = True
    52 
    +    , isolateThreadBreaks = isolate_breaks
    53 53 
           -- Must opt-in to listening to all thread's breakpoints.
    54 54 
           -- (e.g. for running 'main' in a debugger)
    55 55 
         }

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -230,18 +230,16 @@ execStmt' stmt stmt_text ExecOptions{..} = do
    230 230 
           Just (ids, hval, fix_env) -> do
    231 231 
             updateFixityEnv fix_env
    232 232
    233 
    -        status <-
    234 
    -          liftIO $ do
    235 
    -            let eval_opts = (initEvalOpts idflags' (enableGhcStepMode execSingleStep))
    236 
    -                              { isolateThreadBreaks = enableIsolateThreadBreaks execIsolateMode }
    237 
    -            evalStmt interp eval_opts (execWrap hval)
    233 
    +        let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep)
    234 
    +                          (enableIsolateThreadBreaks execIsolateMode)
    235 
    +        status <- liftIO $ evalStmt interp eval_opts (execWrap hval)
    238 236
    239 237 
             let ic = hsc_IC hsc_env
    240 238 
                 bindings = (ic_tythings ic, ic_gre_cache ic)
    241 239
    242 240 
                 size = ghciHistSize idflags'
    243 241
    244 
    -        handleRunStatus execSingleStep execIsolateMode stmt_text bindings ids
    242 
    +        handleRunStatus execSingleStep eval_opts stmt_text bindings ids
    245 243 
                             status (emptyHistory size)
    246 244
    247 245 
     runDecls :: GhcMonad m => String -> m [TyThing]
    ... ... @@ -293,18 +291,22 @@ emptyHistory size = nilBL size
    293 291 
     -- or :stepmodule, rather than :step, we only care about certain breakpoints).
    294 292 
     handleRunStatus :: GhcMonad m
    295 293 
                     => SingleStep
    296 
    -                -> ThreadBreaksIsolationMode
    294 
    +                -- ^ The kind of step we're doing. 'handleRunStatus' may resume
    295 
    +                -- the evaluation automatically if the step kind indicates to
    296 
    +                -- ignore this breakpoint (e.g. when doing 'ModuleStep' but the
    297 
    +                -- breakpoint just hit belongs to a different module)
    298 
    +                -> EvalOpts
    299 
    +                -- ^ The evaluation options in case the evaluation is resumed.
    297 300 
                     -> String
    298 301 
                     -> ResumeBindings
    299 302 
                     -> [Id]
    300 303 
                     -> EvalStatus_ [ForeignHValue] [HValueRef]
    301 304 
                     -> BoundedList History
    302 305 
                     -> m ExecResult
    303 
    -handleRunStatus step isolateMode expr bindings final_ids status history0 = do
    306 
    +handleRunStatus step eval_opts expr bindings final_ids status history0 = do
    304 307 
       hsc_env <- getSession
    305 308 
       let
    306 309 
         interp = hscInterp hsc_env
    307 
    -    dflags = hsc_dflags hsc_env
    308 310 
       case status of
    309 311
    310 312 
         -- Completed successfully
    ... ... @@ -396,15 +398,13 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do
    396 398 
             return (ExecBreak break_ids (Just ibi) resume)
    397 399 
           else do
    398 400 
             -- resume with the same step type
    399 
    -        let eval_opts = (initEvalOpts dflags (enableGhcStepMode step))
    400 
    -                          { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode }
    401 401 
             status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv
    402 402 
             history <- if not tracing then pure history0 else do
    403 403 
               history1 <- liftIO $ mkHistory hug apStack_fhv ibi
    404 404 
               let !history' = history1 `consBL` history0
    405 405 
                     -- history is strict, otherwise our BoundedList is pointless.
    406 406 
               return history'
    407 
    -        handleRunStatus step isolateMode expr bindings final_ids status history
    407 
    +        handleRunStatus step eval_opts expr bindings final_ids status history
    408 408 
      where
    409 409 
       tracing | RunAndLogSteps <- step = True
    410 410 
               | otherwise              = False
    ... ... @@ -452,8 +452,8 @@ resumeExec step isolateMode mbCnt r = do
    452 452 
                 (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt
    453 453 
                 _ -> return ()
    454 454
    455 
    -          let eval_opts = (initEvalOpts dflags (enableGhcStepMode step))
    456 
    -                            { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode }
    455 
    +          let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
    456 
    +                            (enableIsolateThreadBreaks isolateMode)
    457 457 
               status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
    458 458 
               let prevHistoryLst = fromListBL 50 hist
    459 459 
                   hug = hsc_HUG hsc_env
    ... ... @@ -464,7 +464,7 @@ resumeExec step isolateMode mbCnt r = do
    464 464 
                           hist1 <- liftIO (mkHistory hug apStack bi)
    465 465 
                           return $ hist1 `consBL` fromListBL 50 hist
    466 466 
                        | otherwise -> pure prevHistoryLst
    467 
    -          handleRunStatus step isolateMode expr bindings final_ids status =<< hist'
    467 
    +          handleRunStatus step eval_opts expr bindings final_ids status =<< hist'
    468 468
    469 469 
     setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m ()   -- #19157
    470 470 
     setupBreakpoint interp ibi cnt = do
    ... ... @@ -1274,7 +1274,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
    1274 1274 
             _ -> panic "compileParsedExprRemote"
    1275 1275
    1276 1276 
       updateFixityEnv fix_env
    1277 
    -  let eval_opts = initEvalOpts dflags EvalStepNone
    1277 
    +  let eval_opts = initEvalOpts dflags EvalStepNone True
    1278 1278 
       status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)
    1279 1279 
       case status of
    1280 1280 
         EvalComplete _ (EvalSuccess [hval]) -> return hval

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -395,7 +395,7 @@ data EvalOpts
    395 395 
       , stepOut :: Bool
    396 396 
       , breakOnException :: Bool
    397 397 
       , breakOnError :: Bool
    398 
    -  , isolateThreadBreaks :: Bool
    398 
    +  , isolateThreadBreaks :: !Bool
    399 399 
       -- ^ If @isolateThreadBreaks == True@, any breakpoint hit by the thread
    400 400 
       -- forked~[1] to execute this expression is only seen by a caller observing
    401 401 
       -- this thread's result explicitly. That is, this thread's 'EvalStatus' can

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -405,10 +405,11 @@ sandboxIO opts io
    405 405 
     -- rather than just "main" being observed. This should be used for the main
    406 406 
     -- debuggee execution of a debugger.
    407 407 
     withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a
    408 
    -withBreakAction opts tid@(ThreadId tid#) act
    409 
    -  = bracket setBreakAction resetBreakAction (\_ -> act waitForResult)
    408 
    +withBreakAction opts tid@(ThreadId tid#) act = do
    409 
    +  ctx <- getThreadResumeContext tid
    410 
    +  bracket (setBreakAction ctx) (resetBreakAction ctx) (\_ -> act (waitForResult ctx))
    410 411 
       where
    411 
    -    setBreakAction = do
    412 
    +    setBreakAction ctx = do
    412 413 
           poke breakPointIOAction globalBreakStablePtr
    413 414 
              -- TODO: This is poke thread unsafe, as one thread might be accessing this
    414 415 
              -- global variable while this thread tries to overwrite it. We should
    ... ... @@ -422,32 +423,34 @@ withBreakAction opts tid@(ThreadId tid#) act
    422 423
    423 424 
           runIf# singleStep rts_enableStopNextBreakpoint
    424 425 
           runIf# stepOut    rts_enableStopAfterReturn
    425 
    -      runIf  isolateThreadBreaks setIsolatedThread
    426 426
    427 
    -    resetBreakAction () = do
    427 
    +      runIfCtx ctx isolateThreadBreaks setIsolatedCtx
    428 
    +
    429 
    +    resetBreakAction ctx () = do
    428 430 
           poke exceptionFlag 0
    429 431 
           rts_disableStopAfterReturn    tid#
    430 432 
           rts_disableStopNextBreakpoint tid#
    431 
    -      runIf isolateThreadBreaks unsetIsolatedThread
    433 
    +      runIfCtx ctx isolateThreadBreaks unsetIsolatedCtx
    432 434
    433 435 
           -- freeStablePtr stablePtr TODO: we never free the global stablePtr for
    434 436 
           -- global action. Maybe we should have a de-init for clean up.
    435 437 
           -- TODO: don't set it in `setBreakAction` either. Should be on
    436 438 
           -- interpreter initialization.
    437 439
    438 
    -    runIf  pred what = when (pred opts) (what tid)
    439 
    -    runIf# pred what = when (pred opts) (what tid#)
    440 
    +    runIf    pred what     = when (pred opts) (what tid)
    441 
    +    runIf#   pred what     = when (pred opts) (what tid#)
    442 
    +    runIfCtx ctx pred what = when (pred opts) (what ctx)
    440 443
    441 
    -    waitForResult
    444 
    +    waitForResult ctx
    442 445 
           | isolateThreadBreaks opts
    443 446 
           = atomically $
    444 
    -          readThreadEvalStatus tid
    447 
    +          readCtxEvalStatus ctx
    445 448
    446 449 
           | otherwise
    447 450 
           = atomically $
    448 451 
               (EvalPaused <$> readAnyThreadEvalBreak)
    449 452 
               `orElse`
    450 
    -          readThreadEvalStatus tid
    453 
    +          readCtxEvalStatus ctx
    451 454
    452 455 
     -- While we're waiting for the sandbox thread to return a result, if
    453 456 
     -- the current thread receives an asynchronous exception we re-throw

  • libraries/ghci/GHCi/Run/Breakpoints.hs
    ... ... @@ -8,10 +8,12 @@ module GHCi.Run.Breakpoints
    8 8 
       -- * Per-thread breakpoints
    9 9 
       , readThreadEvalStatus, readAnyThreadEvalBreak
    10 10 
       , writeThreadEvalStatus
    11 
    +  , readCtxEvalStatus, writeCtxEvalStatus
    11 12
    12 13 
       -- ** Isolating thread breakpoints
    13 14 
       , withIsolatedThread
    14 15 
       , setIsolatedThread, unsetIsolatedThread
    16 
    +  , setIsolatedCtx, unsetIsolatedCtx
    15 17
    16 18 
       -- ** Querying the global thread breakpoint map
    17 19 
       , listOtherPausedThreads
    ... ... @@ -29,18 +31,15 @@ import GHCi.Message
    29 31 
     import GHCi.RemoteTypes
    30 32
    31 33 
     import qualified Data.Map as Map
    32 
    -import qualified Data.Set as Set
    33 34 
     import Control.Concurrent
    34 35 
     import Control.Exception
    35 36 
     import qualified Data.ByteString.Short.Internal as BS
    36 
    -#if defined(PROFILING)
    37 
    -import GHC.Data.ShortByteString
    38 
    -#endif
    39 37 
     import GHC.Exts
    40 38 
     import GHC.Stack
    41 39 
     import Foreign hiding (void)
    42 40 
     import GHC.Conc.Sync
    43 41 
     import GHC.IO hiding ( bracket )
    42 
    +import Control.Monad
    44 43
    45 44 
     --------------------------------------------------------------------------------
    46 45 
     -- * Global break action
    ... ... @@ -72,7 +71,7 @@ globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction
    72 71 
     globalBreakAction :: BreakpointCallback
    73 72 
     globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
    74 73 
       tid <- myThreadId
    75 
    -  ResumeContext{..} <- getThreadResumeContext tid
    74 
    +  ctx@ResumeContext{..} <- getThreadResumeContext tid
    76 75 
       resume_r <- mkRemoteRef tid
    77 76 
       apStack_r <- mkRemoteRef apStack
    78 77 
       ccs <- toRemotePtr <$> getCCSOf apStack
    ... ... @@ -83,7 +82,7 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
    83 82 
           info_mod <- BS.packCString (Ptr info_mod#)
    84 83 
           info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
    85 84 
           pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
    86 
    -  writeThreadEvalStatus tid $ EvalBreak apStack_r mb_breakpoint resume_r ccs
    85 
    +  writeCtxEvalStatus ctx $ EvalBreak apStack_r mb_breakpoint resume_r ccs
    87 86
    88 87 
       -- Block until this thread is resumed (by the thread which took the
    89 88 
       -- `ResumeContext` from the `statusMVar`).
    ... ... @@ -109,14 +108,19 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do
    109 108 
     -- Succeeds when the given thread writes to the global debugger map an eval result.
    110 109 
     readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef])
    111 110 
     readThreadEvalStatus tid = do
    112 
    -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
    113 
    -  case Map.lookup tid threadEvalStatuses of
    111 
    +  ctxs <- readTVar threadContextsVar
    112 
    +  case Map.lookup tid ctxs of
    113 
    +    Just ctx -> readCtxEvalStatus ctx
    114 
    +    Nothing  -> retry -- to write a thread break or result, the
    115 
    +                      -- 'threadContextsVar' entry will be created
    116 
    +
    117 
    +-- | Like 'readThreadEvalStatus', but when the 'ResumeContext' is already
    118 
    +-- available (to avoid looking it up unnecessarily).
    119 
    +readCtxEvalStatus :: ResumeContext -> STM (EvalStatus [HValueRef])
    120 
    +readCtxEvalStatus ResumeContext{resumeEvalStatus} =
    121 
    +  readTVar resumeEvalStatus >>= \case
    114 122 
         Just r  -> do
    115 
    -      writeTVar globalDbgStatusVar
    116 
    -        GlobalDbgStatus
    117 
    -          { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it
    118 
    -          , isolatedThreads
    119 
    -          }
    123 
    +      writeTVar resumeEvalStatus Nothing -- clear it
    120 124 
           pure r
    121 125 
         Nothing -> retry -- until someone writes the result for this thread
    122 126
    ... ... @@ -128,36 +132,38 @@ readThreadEvalStatus tid = do
    128 132 
     -- Succeeds when any thread hits a breakpoint.
    129 133 
     readAnyThreadEvalBreak :: STM EvalBreak
    130 134 
     readAnyThreadEvalBreak = do
    131 
    -  dbgs <- readTVar globalDbgStatusVar
    135 
    +  ctxs <- readTVar threadContextsVar
    132 136 
       -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet
    133 
    -  foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs))
    137 
    +  foldr (\ctx next -> readBreak ctx `orElse` next) retry (Map.elems ctxs)
    134 138 
       where
    135 
    -    readStatus GlobalDbgStatus{..} (tid, _) -- don't look at isolated threads
    136 
    -      | Set.member tid isolatedThreads
    137 
    -      = retry
    138 
    -
    139 
    -    readStatus GlobalDbgStatus{..} (tid, status)
    140 
    -      = do
    141 
    -      case status of
    142 
    -        EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus`
    143 
    -        EvalPaused b   -> do
    144 
    -          writeTVar globalDbgStatusVar
    145 
    -            GlobalDbgStatus
    146 
    -              { threadEvalStatuses = Map.delete tid threadEvalStatuses
    147 
    -              , isolatedThreads
    148 
    -              }
    149 
    -          pure b
    139 
    +    readBreak ResumeContext{resumeEvalStatus, resumeIsolated} = do
    140 
    +      isolated <- readTVar resumeIsolated
    141 
    +      if isolated
    142 
    +        then retry -- don't look at isolated threads
    143 
    +        else readTVar resumeEvalStatus >>= \case
    144 
    +          Just (EvalPaused b) -> do
    145 
    +            writeTVar resumeEvalStatus Nothing
    146 
    +            pure b
    147 
    +          Just EvalComplete{} ->
    148 
    +            retry -- successes can be read with `readThreadEvalStatus`
    149 
    +          Nothing ->
    150 
    +            retry -- no status for this thread yet
    150 151
    151 152 
     writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO ()
    152 
    -writeThreadEvalStatus tid status =
    153 
    +writeThreadEvalStatus tid status = do
    154 
    +  -- get or create a 'ResumeContext' for the thread (e.g. we may write the
    155 
    +  -- EvalComplete without breakpoints occurring, so the map won't have an entry):
    156 
    +  ctx <- getThreadResumeContext tid
    157 
    +  writeCtxEvalStatus ctx status
    158 
    +
    159 
    +-- | Like 'writeThreadEvalStatus', but for when the 'ResumeContext' is already
    160 
    +-- available
    161 
    +writeCtxEvalStatus :: ResumeContext -> EvalStatus [HValueRef] -> IO ()
    162 
    +writeCtxEvalStatus ResumeContext{resumeEvalStatus} status =
    153 163 
       atomically $ do
    154 
    -    GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
    155 
    -    writeTVar globalDbgStatusVar $
    156 
    -      GlobalDbgStatus
    157 
    -        { threadEvalStatuses =
    158 
    -            Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible")
    159 
    -                tid status threadEvalStatuses
    160 
    -        , isolatedThreads }
    164 
    +    readTVar resumeEvalStatus >>= \case
    165 
    +      Just{}  -> error "writeCtxEvalStatus: should be impossible"
    166 
    +      Nothing -> writeTVar resumeEvalStatus (Just status)
    161 167
    162 168
    163 169 
     -- ** Isolating thread breakpoints ---------------------------------------------
    ... ... @@ -174,23 +180,15 @@ withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread t
    174 180 
     -- expression to run should not be seen at all by the debugger (e.g. when
    175 181 
     -- evaluating an expr to :force a variable)
    176 182 
     setIsolatedThread :: ThreadId -> IO ()
    177 
    -setIsolatedThread tid = atomically $ do
    178 
    -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
    179 
    -  writeTVar globalDbgStatusVar
    180 
    -    GlobalDbgStatus
    181 
    -      { threadEvalStatuses
    182 
    -      , isolatedThreads = Set.insert tid isolatedThreads
    183 
    -      }
    183 
    +setIsolatedThread = getThreadResumeContext >=> setIsolatedCtx
    184 184
    185 185 
     -- | Undoes 'setIsolatedThread'
    186 186 
     unsetIsolatedThread :: ThreadId -> IO ()
    187 
    -unsetIsolatedThread tid = atomically $ do
    188 
    -  GlobalDbgStatus{..} <- readTVar globalDbgStatusVar
    189 
    -  writeTVar globalDbgStatusVar
    190 
    -    GlobalDbgStatus
    191 
    -      { threadEvalStatuses
    192 
    -      , isolatedThreads = Set.delete tid isolatedThreads
    193 
    -      }
    187 
    +unsetIsolatedThread = getThreadResumeContext >=> unsetIsolatedCtx
    188 
    +
    189 
    +setIsolatedCtx, unsetIsolatedCtx :: ResumeContext -> IO ()
    190 
    +setIsolatedCtx   ctx = atomically $ writeTVar (resumeIsolated ctx) True
    191 
    +unsetIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) False
    194 192
    195 193 
     -- ** Querying the global thread breakpoint map --------------------------------
    196 194
    ... ... @@ -201,64 +199,74 @@ unsetIsolatedThread tid = atomically $ do
    201 199 
     -- the global thread mapping) and are asking about which other threads are
    202 200 
     -- paused to list them.
    203 201 
     listOtherPausedThreads :: IO [ThreadId]
    204 
    -listOtherPausedThreads = do
    205 
    -  m <- atomically $ readTVar globalDbgStatusVar
    206 
    -  pure $ Map.keys $ Map.filter isBreak (threadEvalStatuses m)
    202 
    +listOtherPausedThreads = atomically $ do
    203 
    +  ctxs <- readTVar threadContextsVar
    204 
    +  paused <- mapM isBreak (Map.toList ctxs)
    205 
    +  pure [tid | (tid, True) <- paused]
    207 206 
       where
    208 
    -    isBreak EvalBreak{}     = True
    209 
    -    isBreak EvalComplete{} = False
    210 
    -
    211 
    --- ** Global thread exec status map --------------------------------------------
    212 
    -
    213 
    --- | When we launch a new thread using the debugger, we map ... TODO ... all
    214 
    --- threads launched by that main stmt may further spawn threads, and any of
    215 
    --- them might hit a breakpoint (break array toggled, or per-thread step in
    216 
    --- might be used, or pause button, etc...).
    217 
    ---
    218 
    --- When we launch that main thread we also write its result to this map. So
    219 
    --- this map will only contain the results of threads we explicitly care to
    220 
    --- observe the result of. Not all threads will write their results here,
    221 
    --- certainly not ones spawned unknowningly by the main stmt.
    222 
    --- ...
    223 
    --- todo words
    224 
    -globalDbgStatusVar :: TVar GlobalDbgStatus
    225 
    -globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty
    226 
    -{-# NOINLINE globalDbgStatusVar #-}
    227 
    -
    228 
    -data GlobalDbgStatus = GlobalDbgStatus
    229 
    -  { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef]))
    230 
    -  -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'.
    231 
    -  -- We can additionally observe a thread's result by calling
    232 
    -  -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression
    233 
    -  -- finishes evaluating, see e.g. 'sandboxIO'.
    234 
    -  , isolatedThreads    :: !(Set.Set ThreadId)
    235 
    -  -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'.
    236 
    -  -- That is, even if one of the threads in this set hits a breakpoint, we
    237 
    -  -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly.
    238 
    -  }
    207 
    +    isBreak (tid, ResumeContext{resumeEvalStatus}) = do
    208 
    +      status <- readTVar resumeEvalStatus
    209 
    +      pure (tid, case status of
    210 
    +                   Just EvalBreak{}    -> True
    211 
    +                   Just EvalComplete{} -> False
    212 
    +                   Nothing             -> False)
    239 213
    240 214 
     --------------------------------------------------------------------------------
    241 215 
     -- * Per-thread resume-ing
    242 216 
     --------------------------------------------------------------------------------
    243 217
    244 218 
     getThreadResumeContext :: ThreadId -> IO ResumeContext
    245 
    -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do
    246 
    -  case Map.lookup tid gbm0 of
    219 
    +getThreadResumeContext tid = do
    220 
    +  ctxs0 <- readTVarIO threadContextsVar
    221 
    +  case Map.lookup tid ctxs0 of
    222 
    +    Just ctx -> pure ctx -- common case: hence read without transaction
    247 223 
         Nothing  -> do
    248 
    -      r <- ResumeContext <$> newEmptyMVar
    249 
    -      let !gbm1 = Map.insert tid r gbm0
    250 
    -      pure (gbm1, r)
    251 
    -    Just ctx -> do
    252 
    -      pure (gbm0, ctx)
    224 
    +      new_ctx <- ResumeContext <$> newEmptyMVar
    225 
    +                               <*> newTVarIO Nothing
    226 
    +                               <*> newTVarIO False
    227 
    +      atomically $ do -- write new thread context atomically
    228 
    +        ctxs1 <- readTVar threadContextsVar
    229 
    +        case Map.lookup tid ctxs1 of
    230 
    +          Just ctx -> pure ctx -- already exists
    231 
    +          Nothing  -> do
    232 
    +            let !ctxs2 = Map.insert tid new_ctx ctxs1
    233 
    +            writeTVar threadContextsVar ctxs2
    234 
    +            pure new_ctx
    253 235
    254 
    --- | A global mapping from thread ids to the MVars on which they block when stopped.
    255 
    -globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext)
    256 
    -globalBreakActionMap = unsafePerformIO $ newMVar Map.empty
    257 
    -{-# NOINLINE globalBreakActionMap #-}
    236 
    +-- | A global mapping from threads to their per-thread state 'ResumeContext'
    237 
    +-- (that e.g. contain the MVars on which they block when stopped)
    238 
    +threadContextsVar :: TVar (Map.Map ThreadId ResumeContext)
    239 
    +threadContextsVar = unsafePerformIO $ newTVarIO Map.empty
    240 
    +{-# NOINLINE threadContextsVar #-}
    258 241
    259 
    -newtype ResumeContext = ResumeContext
    260 
    -  { resumeBreakMVar :: MVar ()
    242 
    +-- | Global context for a thread, which is created and inserted in the global
    243 
    +-- 'threadContextsVar' when a thread hits a breakpoint (and, thus, the
    244 
    +-- 'globalBreakAction') is run, or when 'withBreakAction' sets the thread
    245 
    +-- isolation (e.g. in 'sandboxIO'), or in other calls to
    246 
    +-- 'getThreadResumeContext', the function which gets or creates a thread
    247 
    +-- 'ResumeContext'.
    248 
    +--
    249 
    +-- TODO: Rename ResumeContext to something like ThreadContext or
    250 
    +-- ThreadDbgContext or (Thread)BreakContext, and fields to something like
    251 
    +-- dbgEvalStatus, threadIsolated, ...
    252 
    +data ResumeContext = ResumeContext
    253 
    +  { resumeBreakMVar :: !(MVar ())
    261 254 
       -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar
    262 
    -  -- (gotten from the 'globalBreakActionMap').
    255 
    +  -- (gotten from the 'threadContextsVar').
    263 256 
       -- The debugger can unblock that thread by signaling its MVar.
    257 
    +  , resumeEvalStatus :: !(TVar (Maybe (EvalStatus [HValueRef])))
    258 
    +  -- ^ When a thread hits a breakpoint, the 'globalBreakAction' is run and
    259 
    +  -- writes an 'EvalBreak' in this @TVar@ (which was found in 'threadContextsVar').
    260 
    +  --
    261 
    +  -- Additionally, the 'EvalComplete' result of a thread may be written here
    262 
    +  -- using `writeThreadEvalStatus tid (EvalComplete ...)` after the main
    263 
    +  -- expression finishes evaluating, see e.g. 'sandboxIO'.
    264 
    +  --
    265 
    +  -- The variable should be emptied (i.e. set to 'Nothing') by whoever
    266 
    +  -- reads the status.
    267 
    +  , resumeIsolated :: !(TVar Bool)
    268 
    +  -- ^ When set, this thread is meant to be ignored by 'readAnyThreadEvalBreak'.
    269 
    +  -- That is, if a thread with resumeIsolated=True hits a breakpoint, its
    270 
    +  -- 'EvalBreak' can only be read with @'readThreadEvalStatus' tid@ for this
    271 
    +  -- thread's @tid@ directly.
    264 272 
       }

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/c0876759757f2ef4c2e8d7ea2de65ec9b4b4bd9d...64836f8c2dc5ec9cde23253cf1407dc1659a6a38 at 1790696507