Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC Commits: b7aee273 by Rodrigo Mesquita at 2026-09-04T10:39:49+01:00 move to GHCi.Run.Breakpoints - - - - - 8dafed3e by Rodrigo Mesquita at 2026-09-04T17:10:33+01:00 Refactor: we have the interactive Ids directly... clean up significantly Removes things like names <- map idName ids map (\i -> let id = find (\x -> i==idName x) names) idso and is more straightforward because there's less state going around (no more updating HscEnv as an output) It also kills `printTypeOfNames` completely, since now we just have the Ids. No longer `lookupName` names to get back the ids... ``` printTypeOfName :: GHC.GhcMonad m => Name -> m () printTypeOfName n = do maybe_tything <- GHC.lookupName n case maybe_tything of Nothing -> return () Just thing -> printTyThing thing ``` now is just `printTyThing . AnId` Also: ```diff - tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [i | AnId i <- tythings] + docs <- mapM pprTypeAndContents idsSorted ``` (and yes, in ExecBreaks there are only Ids, no TyThings, bc they are only constructed by the interpreter execution which can only bind ids. for TyThings use runDecls which doesn't return execBreaks.) I have a plan for the `resumes`, I'm getting there. Put the resume in ExecBreak fixes grrr - - - - - c43cb731 by Rodrigo Mesquita at 2026-09-04T17:29:40+01:00 UNDO the removing-hsc-env-globality part of the clean up and keep just the good parts - - - - - f7a22268 by Rodrigo Mesquita at 2026-09-04T17:38:20+01:00 just to test rtti of final_ids if that would work - - - - - 9 changed files: - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/ghci/GHCi/Run.hs - + libraries/ghci/GHCi/Run/Breakpoints.hs - libraries/ghci/ghci.cabal.in Changes: ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -121,8 +121,7 @@ pprintClosureCommand bindThings force str = do -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. let reconstructed_type = termType term - hsc_env <- getSession - case (improveRTTIType hsc_env id_ty' reconstructed_type) of + case improveRTTIType id_ty' reconstructed_type of Nothing -> return (subst, term') Just subst' -> do { logger <- getLogger ; liftIO $ ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -131,7 +131,7 @@ import GHC.ByteCode.Breakpoints import Control.Monad import Data.Dynamic import Data.IntMap (IntMap) -import Data.List (find,intercalate) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import Unsafe.Coerce ( unsafeCoerce ) import qualified GHC.Unit.Home.Graph as HUG @@ -244,12 +244,12 @@ execStmt' stmt stmt_text ExecOptions{..} = do handleRunStatus execSingleStep execIsolateMode stmt_text bindings ids status (emptyHistory size) -runDecls :: GhcMonad m => String -> m [Name] +runDecls :: GhcMonad m => String -> m [TyThing] runDecls = runDeclsWithLocation "<interactive>" 1 -- | Run some declarations and return any user-visible names that were brought -- into scope. -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [TyThing] runDeclsWithLocation source line_num input = do hsc_env <- getSession decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) @@ -258,18 +258,17 @@ runDeclsWithLocation source line_num input = do -- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. -- Useful when doing preprocessing on the AST before execution, e.g. in GHCi -- (see GHCi.UI.runStmt). -runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] +runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [TyThing] runParsedDecls decls = do - hsc_env <- getSession - (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) - + hsc_env <- getSession + (tyThings, ic) <- liftIO $ hscParsedDecls hsc_env decls setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env setSession hsc_env' - return $ filter (not . isDerivedOccName . nameOccName) + return $ filter (not . isDerivedOccName . nameOccName . getName) -- For this filter, see Note [What to show to users] - $ map getName tyThings + $ tyThings {- Note [What to show to users] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -316,7 +315,8 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' - return (ExecComplete (Right final_names) allocs) + let improved_final_ids = filter (`elem` final_ids) [ i | AnId i <- ic_tythings $ hsc_IC hsc_env' ] -- just to test + return (ExecComplete (Right improved_final_ids {- TODO: THESE MUST BE IMPROVED BEFORE RETURNED -}) allocs) -- Completed with an exception EvalComplete alloc (EvalException e) -> @@ -327,7 +327,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let span = mkGeneralSrcSpan (fsLit "<unknown>") - (hsc_env1, names) <- liftIO $ + (hsc_env1, break_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing let resume = Resume @@ -346,7 +346,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak names Nothing) + return (ExecBreak break_ids Nothing resume) -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint -- @@ -374,7 +374,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control -- and simply resume execution from here until we hit a breakpoint we do want to stop at. - (hsc_env1, names) <- liftIO $ + (hsc_env1, final_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) let resume = Resume @@ -392,7 +392,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do } hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak names (Just ibi)) + return (ExecBreak final_ids (Just ibi) resume) else do -- resume with the same step type let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) @@ -500,13 +500,13 @@ getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do ( ld_st' , ba ) -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +back :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +forward :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist :: GhcMonad m => (Int -> Int) -> m ([Id], Int, SrcSpan) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of @@ -530,7 +530,7 @@ moveHist fn = do let hug = hsc_HUG hsc_env brks <- readIModBreaks hug ibi getBreakLoc (readIModModBreaks hug) ibi brks - (hsc_env1, names) <- + (hsc_env1, final_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } @@ -538,7 +538,7 @@ moveHist fn = do setSession hsc_env1{ hsc_IC = ic' } - return (names, new_ix, span) + return (final_ids, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to @@ -564,7 +564,7 @@ bindLocalsAtBreakpoint -> ForeignHValue -> SrcSpan -> Maybe InternalBreakpointId - -> IO (HscEnv, [Name]) + -> IO (HscEnv, [Id]) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to @@ -584,7 +584,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do interp = hscInterp hsc_env -- Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) + return (hsc_env{ hsc_IC = ictxt1 }, [exn_id]) -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. @@ -645,7 +645,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names) + let improved_final_ids = filter (`elem` final_ids) [ i | AnId i <- ic_tythings $ hsc_IC hsc_env1 ] -- just to test + return (hsc_env1, improved_final_ids {-TODO: IMPROVE RTTI -}) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings @@ -692,12 +693,10 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] - foldM improveTypes hsc_env (map idName incompletelyTypedIds) + foldM improveTypes hsc_env incompletelyTypedIds where noSkolems = noFreeVarsOfType . idType - improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - id = expectJust $ find (\i -> idName i == name) tmp_ids + improveTypes hsc_env@HscEnv{hsc_IC=ic} id = do if noSkolems id then return hsc_env else do @@ -706,7 +705,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do case mb_new_ty of Nothing -> return hsc_env Just new_ty -> do - case improveRTTIType hsc_env old_ty new_ty of + case improveRTTIType old_ty new_ty of Nothing -> warnPprTrace True (":print failed to calculate the " ++ "improvement for a type") (vcat [ text "id" <+> ppr id ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -21,7 +21,6 @@ import GHCi.Message (EvalExpr) import GHC.ByteCode.Types (InternalBreakpointId(..)) import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id -import GHC.Types.Name import GHC.Types.TyThing import GHC.Types.Name.Reader import GHC.Types.SrcLoc @@ -160,7 +159,7 @@ data ExecResult -- | Execution is complete with either an exception or the list of -- user-visible names that were brought into scope. = ExecComplete - { execResult :: Either SomeException [Name] + { execResult :: Either SomeException [Id] , execAllocation :: Word64 } @@ -171,8 +170,10 @@ data ExecResult -- subsequently deciding whether to really stop here. -- `ExecBreak` always means GHCi breaks. | ExecBreak - { breakNames :: [Name] + { breakNames :: [Id] , breakPointId :: Maybe InternalBreakpointId + , breakResume :: Resume + -- ^ to resume this thread blocked on this break } -- | Essentially a GlobalRdrEnv, but with additional cached values to allow ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -1160,8 +1160,8 @@ findPtrTyss i tys = foldM step (i, []) tys -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst -improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty +improveRTTIType :: RttiType -> RttiType -> Maybe Subst +improveRTTIType base_ty new_ty = U.tcUnifyDebugger base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] -- Given the result type ty of a constructor application (D a b c :: ty) ===================================== ghc/GHCi/UI.hs ===================================== @@ -1473,7 +1473,7 @@ runOneCommand eh gCmd = do -- runStmt wrapper for temporarily overridden line-number runStmtWithLineNum :: Int -> String -> SingleStep - -> GHCi (Maybe GHC.ExecResult) + -> GHCi (Maybe RunResult) runStmtWithLineNum lnum stmt step = do st0 <- getGHCiState setGHCiState st0 { line_number = lnum } @@ -1538,7 +1538,7 @@ enqueueCommands cmds = do -- | Entry point to execute some haskell code from user. -- The return value True indicates success, as in `runOneCommand`. -runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult) +runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe RunResult) runStmt input step = do dflags <- GHC.getInteractiveDynFlags let pflags = initParserOpts dflags @@ -1560,7 +1560,7 @@ runStmt input step = do case mb_stmt of Nothing -> -- empty statement / comment - return (Just exec_complete) + return (Just (RunDeclsResult [])) Just stmt -> run_stmt stmt @@ -1583,8 +1583,6 @@ runStmt input step = do run_imports imports run_decls decls where - exec_complete = GHC.ExecComplete (Right []) 0 - run_imports imports = mapM_ (addImportToContext . unLoc) imports set_pragmas pflags sec supported = @@ -1593,12 +1591,12 @@ runStmt input step = do opts = unLoc <$> loc_opts in setOptions opts - run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult) + run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe RunResult) run_stmt stmt = do m_result <- GhciMonad.runStmt stmt input step case m_result of Nothing -> return Nothing - Just result -> Just <$> afterRunStmt step result + Just result -> Just <$> afterRunStmt (RunStmtResult result) -- `x = y` (a declaration) should be treated as `let x = y` (a statement). -- The reason is because GHCi wasn't designed to support `x = y`, but then @@ -1614,7 +1612,7 @@ runStmt input step = do -- -- Instead of dealing with all these problems individually here we fix this -- mess by just treating `x = y` as `let x = y`. - run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult) + run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe RunResult) -- Only turn `FunBind` and `VarBind` into statements, other bindings -- (e.g. `PatBind`) need to stay as decls. run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind) @@ -1629,8 +1627,8 @@ runStmt input step = do -- a file, otherwise the read buffer can't be flushed). _ <- liftIO $ tryIO $ hFlushAll stdin m_result <- GhciMonad.runDecls' decls - forM m_result $ \result -> - afterRunStmt step (GHC.ExecComplete (Right result) 0) + forM m_result $ \result -> do + afterRunStmt (RunDeclsResult result) mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs mk_stmt loc bind = @@ -1646,32 +1644,33 @@ runStmt input step = do where modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic +data RunResult + = RunStmtResult GHC.ExecResult + | RunDeclsResult [TyThing] + -- | Clean up the GHCi environment after a statement has run -afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before -} - -> GHC.ExecResult -> m GHC.ExecResult -afterRunStmt step run_result = do - resumes <- GHC.getResumeContext +afterRunStmt :: GhciMonad m + => RunResult -> m RunResult +afterRunStmt run_result = do case run_result of - GHC.ExecComplete{..} -> - case execResult of - Left ex -> liftIO $ Exception.throwIO ex - Right names -> do - show_types <- isOptionSet ShowType - when show_types $ printTypeOfNames names - GHC.ExecBreak names mb_info - | first_resume : _ <- resumes - -> do mb_id_loc <- toBreakIdAndLocation mb_info - let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc - if (null bCmd) - then printStoppedAtBreakInfo first_resume names - else enqueueCommands [bCmd] - -- run the command set with ":set stop <cmd>" - st <- getGHCiState - enqueueCommands [stop st] - return () - - | otherwise -> resume step Nothing >>= - afterRunStmt step >> return () + RunDeclsResult things -> do + show_types <- isOptionSet ShowType + when show_types $ printTypeOfThings things + RunStmtResult GHC.ExecComplete{..} -> + case execResult of + Left ex -> liftIO $ Exception.throwIO ex + Right ids -> do + show_types <- isOptionSet ShowType + when show_types $ printTypeOfIds ids + RunStmtResult (GHC.ExecBreak ids mb_info resume) -> do + mb_id_loc <- toBreakIdAndLocation mb_info + let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc + if (null bCmd) + then printStoppedAtBreakInfo resume ids + else enqueueCommands [bCmd] + -- run the command set with ":set stop <cmd>" + st <- getGHCiState + enqueueCommands [stop st] flushInterpBuffers withSignalHandlers $ do @@ -1680,16 +1679,18 @@ afterRunStmt step run_result = do return run_result -runSuccess :: Maybe GHC.ExecResult -> Bool +runSuccess :: Maybe RunResult -> Bool runSuccess run_result - | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True + | Just (RunDeclsResult _) <- run_result = True + | Just (RunStmtResult GHC.ExecComplete { execResult = Right _ }) + <- run_result = True | otherwise = False -runAllocs :: Maybe GHC.ExecResult -> Maybe Integer +runAllocs :: Maybe RunResult -> Maybe Integer runAllocs m = do res <- m case res of - GHC.ExecComplete{..} -> Just (fromIntegral execAllocation) + RunStmtResult GHC.ExecComplete{..} -> Just (fromIntegral execAllocation) _ -> Nothing toBreakIdAndLocation :: GhciMonad m @@ -1703,30 +1704,23 @@ toBreakIdAndLocation (Just inf) = do return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st), breakId loc == bi ] -printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m () -printStoppedAtBreakInfo res names = do +printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [GHC.Id] -> m () +printStoppedAtBreakInfo res ids = do printForUser =<< pprStopped res - -- printTypeOfNames session names - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [i | AnId i <- tythings] + let idsSorted = sortBy (compareNames `on` getName) ids + docs <- mapM pprTypeAndContents idsSorted printForUserPartWay $ vcat docs -printTypeOfNames :: GHC.GhcMonad m => [Name] -> m () -printTypeOfNames names - = mapM_ (printTypeOfName ) $ sortBy compareNames names +printTypeOfIds :: GHC.GhcMonad m => [GHC.Id] -> m () +printTypeOfIds = printTypeOfThings . map AnId + +printTypeOfThings :: GHC.GhcMonad m => [GHC.TyThing] -> m () +printTypeOfThings things + = mapM_ printTyThing $ sortBy (compareNames `on` getName) things compareNames :: Name -> Name -> Ordering compareNames = on compare getOccString S.<> on SrcLoc.leftmost_smallest getSrcSpan -printTypeOfName :: GHC.GhcMonad m => Name -> m () -printTypeOfName n - = do maybe_tything <- GHC.lookupName n - case maybe_tything of - Nothing -> return () - Just thing -> printTyThing thing - - data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand -- | Entry point for execution a ':<command>' input from user @@ -4375,7 +4369,7 @@ doContinue step = doContinue' step Nothing doContinue' :: GhciMonad m => SingleStep -> Maybe Int -> m () doContinue' step mbCnt= do runResult <- resume step mbCnt - _ <- afterRunStmt step runResult + _ <- afterRunStmt (RunStmtResult runResult) return () abandonCmd :: GhciMonad m => String -> m () @@ -4526,9 +4520,9 @@ backCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where back num = withSandboxOnly ":back" $ do - (names, _, pan) <- GHC.back num + (ids, _, pan) <- GHC.back num printForUser $ text "Logged breakpoint at" <+> ppr pan - printTypeOfNames names + printTypeOfIds ids -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] @@ -4540,11 +4534,11 @@ forwardCmd arg | otherwise = liftIO $ putStrLn "Syntax: :forward [num]" where forward num = withSandboxOnly ":forward" $ do - (names, ix, pan) <- GHC.forward num + (ids, ix, pan) <- GHC.forward num printForUser $ (if (ix == 0) then text "Stopped at" else text "Logged breakpoint at") <+> ppr pan - printTypeOfNames names + printTypeOfIds ids -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -381,7 +381,7 @@ runStmt stmt stmt_text step = do (EvalThis fhv) } Just <$> GHC.execStmt' stmt stmt_text opts -runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name]) +runDecls :: GhciMonad m => String -> m (Maybe [GHC.TyThing]) runDecls decls = do st <- getGHCiState reifyGHCi $ \x -> @@ -393,7 +393,7 @@ runDecls decls = do r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls return (Just r) -runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name]) +runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.TyThing]) runDecls' decls = do st <- getGHCiState reifyGHCi $ \x -> ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,7 +1,6 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns #-} -- | -- Execute GHCi messages. @@ -20,6 +19,7 @@ import GHCi.CreateBCO import GHCi.InfoTable #endif +import GHCi.Run.Breakpoints import GHCi.Coverage import qualified GHC.InfoProv as InfoProv import GHCi.Debugger @@ -31,8 +31,6 @@ import GHCi.TH 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 @@ -290,7 +288,7 @@ abandonStmt hvref = do tid <- localRef hvref ResumeContext{..} <- getThreadResumeContext tid killThread tid - withShadowThread tid $ do + withIsolatedThread tid $ do putMVar resumeBreakMVar () _ <- atomically $ readThreadEvalStatus tid @@ -424,13 +422,13 @@ withBreakAction opts tid@(ThreadId tid#) act runIf# singleStep rts_enableStopNextBreakpoint runIf# stepOut rts_enableStopAfterReturn - runIf isolateThreadBreaks setShadowThread + runIf isolateThreadBreaks setIsolatedThread resetBreakAction () = do poke exceptionFlag 0 rts_disableStopAfterReturn tid# rts_disableStopNextBreakpoint tid# - runIf isolateThreadBreaks unsetShadowThread + runIf isolateThreadBreaks unsetIsolatedThread -- freeStablePtr stablePtr TODO: we never free the global stablePtr for -- global action. Maybe we should have a de-init for clean up. @@ -484,186 +482,3 @@ clearEvalStatus = \case EvalComplete w (EvalSuccess _) -> EvalComplete w (EvalSuccess ()) EvalBreak ap mb rt rccs -> EvalBreak ap mb rt rccs --------------------------------------------------------------------------------- --- Global Debugger Per-Thread Context --- TODO: when to clean MVar? how to figure out when Threads are dead and we'll never need their mvars again? perhaps a finalizer on the thread id? --- TODO: Move to independent module, and don't expose the global variables at all. move also the global break action maybe. --- Maybe there could even be something in that module for setting the global --- break action on start. maybe just an init function --- --- TODO: Note which explains when things are evacuated from the map, why --- EvalSuccess's don't leak, what is the idea, why have MVar and TVar, why have --- shadowed threads. Must also explain whatever we come up with for Finalizers --- to make sure threads evacuate themselves out of the map. Explain in the note --- as well the status of GHCi multi-threaded, explaining it currently uses --- single-threaded --- --- TODO: Write a blog post about multi-threaded debugging (mby with the contents of the note..) - -globalBreakStablePtr :: StablePtr BreakpointCallback -globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction - -globalBreakAction :: BreakpointCallback -globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do - tid <- myThreadId - ResumeContext{..} <- getThreadResumeContext tid - resume_r <- mkRemoteRef tid - apStack_r <- mkRemoteRef apStack - ccs <- toRemotePtr <$> getCCSOf apStack - breakpoint <- - if is_exception - then pure Nothing - else 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 breakpoint resume_r ccs - - -- Block until this thread is resumed (by the thread which took the - -- `ResumeContext` from the `statusMVar`). - -- - -- The `onBreak` function must have been called from `rts/Interpreter.c` - -- when interpreting a `BRK_FUN`. After taking from the MVar, the function - -- returns to the continuation on the stack which is where the interpreter - -- was stopped. - takeMVar resumeBreakMVar - -getThreadResumeContext :: ThreadId -> IO ResumeContext -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do - case Map.lookup tid gbm0 of - Nothing -> do - r <- ResumeContext <$> newEmptyMVar - let !gbm1 = Map.insert tid r gbm0 - pure (gbm1, r) - Just ctx -> do - pure (gbm0, 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 #-} - -newtype ResumeContext = ResumeContext - { resumeBreakMVar :: MVar () - -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar - -- (gotten from the 'globalBreakActionMap'). - -- The debugger can unblock that thread by signaling its MVar. - } - --- | 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 - 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 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)) - 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 = - atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar $ - GlobalDbgStatus - { threadEvalStatuses = - Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") - tid new threadEvalStatuses - , shadowedThreads } - --- | Brackets 'setShadowThread' -withShadowThread :: ThreadId -> IO a -> IO a -withShadowThread tid = bracket_ (setShadowThread tid) (unsetShadowThread tid) - --- | Make sure that anyone watching for threads hitting breakpoints with --- 'readAnyThreadEvalBreak' ignore the given thread if it ever hits a breakpoint. --- --- 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) -setShadowThread :: ThreadId -> IO () -setShadowThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , shadowedThreads = Set.insert tid shadowedThreads - } - --- | Undoes 'setShadowThread' -unsetShadowThread :: ThreadId -> IO () -unsetShadowThread tid = 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...). --- --- 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'. - , 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. - } ===================================== libraries/ghci/GHCi/Run/Breakpoints.hs ===================================== @@ -0,0 +1,264 @@ +{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, + UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns, BangPatterns #-} +module GHCi.Run.Breakpoints + ( + -- * Global break action + globalBreakStablePtr, globalBreakAction + + -- * Per-thread breakpoints + , readThreadEvalStatus, readAnyThreadEvalBreak + , writeThreadEvalStatus + + -- ** Isolating thread breakpoints + , withIsolatedThread + , setIsolatedThread, unsetIsolatedThread + + -- ** Querying the global thread breakpoint map + , listOtherPausedThreads + + -- * Per-thread resume-ing + , getThreadResumeContext, ResumeContext(..) + + ) + where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHCi.Debugger +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 ) + +-------------------------------------------------------------------------------- +-- * Global break action +-------------------------------------------------------------------------------- +-- Global Debugger Per-Thread Context +-- TODO: when to clean MVar? how to figure out when Threads are dead and we'll +-- never need their mvars again? perhaps a finalizer on the thread id? +-- +-- TODO: Move to independent module, and don't expose the global variables at all. move also the global break action maybe. +-- Maybe there could even be something in that module for setting the global +-- break action on start. maybe just an init function +-- +-- TODO: Note which explains when things are evacuated from the map, why +-- EvalSuccess's don't leak, what is the idea, why have MVar and TVar, why have +-- isolated threads. Must also explain whatever we come up with for Finalizers +-- to make sure threads evacuate themselves out of the map. Explain in the note +-- as well the status of GHCi multi-threaded, explaining it currently uses +-- single-threaded +-- +-- TODO: Write a blog post about multi-threaded debugging (mby with the contents of the note..) + +-- TODO: Maybe this could be the return value of doing initialization for the +-- debugger, which allocates this stable pointer and sets it in the global action. +-- +-- And de-initialization deallocates this stable pointer and then some other things +globalBreakStablePtr :: StablePtr BreakpointCallback +globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction + +globalBreakAction :: BreakpointCallback +globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do + tid <- myThreadId + ResumeContext{..} <- getThreadResumeContext tid + resume_r <- mkRemoteRef tid + apStack_r <- mkRemoteRef apStack + ccs <- toRemotePtr <$> getCCSOf apStack + mb_breakpoint <- + if is_exception + then pure Nothing + else 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 + + -- Block until this thread is resumed (by the thread which took the + -- `ResumeContext` from the `statusMVar`). + -- + -- The `onBreak` function must have been called from `rts/Interpreter.c` + -- when interpreting a `BRK_FUN`. After taking from the MVar, the function + -- returns to the continuation on the stack which is where the interpreter + -- was stopped. + takeMVar resumeBreakMVar + +-------------------------------------------------------------------------------- +-- * Per-thread breakpoints +-------------------------------------------------------------------------------- + +-- | 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 + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + case Map.lookup tid threadEvalStatuses of + Just r -> do + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it + , isolatedThreads + } + 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 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)) + 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 + +writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO () +writeThreadEvalStatus tid status = + atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar $ + GlobalDbgStatus + { threadEvalStatuses = + Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") + tid status threadEvalStatuses + , isolatedThreads } + + +-- ** Isolating thread breakpoints --------------------------------------------- + +-- | Brackets 'setIsolatedThread' +withIsolatedThread :: ThreadId -> IO a -> IO a +withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread tid) + +-- | Make sure that anyone watching for threads hitting breakpoints with +-- 'readAnyThreadEvalBreak' ignore the given thread if it ever hits a breakpoint. +-- +-- 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) +setIsolatedThread :: ThreadId -> IO () +setIsolatedThread tid = atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses + , isolatedThreads = Set.insert tid isolatedThreads + } + +-- | Undoes 'setIsolatedThread' +unsetIsolatedThread :: ThreadId -> IO () +unsetIsolatedThread tid = atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses + , isolatedThreads = Set.delete tid isolatedThreads + } + +-- ** Querying the global thread breakpoint map -------------------------------- + +-- | List all other threads paused on a breakpoint. +-- +-- We say "other" because this function is meant to be used in the scenario +-- where you are already paused at a breakpoint (which has been popped off of +-- 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) + 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. + } + +-------------------------------------------------------------------------------- +-- * Per-thread resume-ing +-------------------------------------------------------------------------------- + +getThreadResumeContext :: ThreadId -> IO ResumeContext +getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do + case Map.lookup tid gbm0 of + Nothing -> do + r <- ResumeContext <$> newEmptyMVar + let !gbm1 = Map.insert tid r gbm0 + pure (gbm1, r) + Just ctx -> do + pure (gbm0, 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 #-} + +newtype ResumeContext = ResumeContext + { resumeBreakMVar :: MVar () + -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar + -- (gotten from the 'globalBreakActionMap'). + -- The debugger can unblock that thread by signaling its MVar. + } ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -61,6 +61,7 @@ library exposed-modules: GHCi.Coverage GHCi.Run + GHCi.Run.Breakpoints GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82db8234bbbbe11096988b3210d85... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82db8234bbbbe11096988b3210d85... 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