ghc-debugger 0.1.0.0 → 0.2.0.0

raw patch · 16 files changed

+970/−692 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +1/−1
• ghc-debug-adapter/Development/Debug/Adapter/Init.hs +2/−2
• ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs +2/−6
• ghc-debug-adapter/Main.hs +0/−4
• ghc-debugger.cabal +11/−1
• ghc-debugger/GHC/Debugger.hs +4/−660
• ghc-debugger/GHC/Debugger/Breakpoint.hs +123/−0
• ghc-debugger/GHC/Debugger/Evaluation.hs +157/−0
• ghc-debugger/GHC/Debugger/Interface/Messages.hs +0/−3
• ghc-debugger/GHC/Debugger/Monad.hs +56/−15
• ghc-debugger/GHC/Debugger/Runtime.hs +80/−0
• ghc-debugger/GHC/Debugger/Runtime/Term/Cache.hs +64/−0
• ghc-debugger/GHC/Debugger/Runtime/Term/Key.hs +46/−0
• ghc-debugger/GHC/Debugger/Stopped.hs +270/−0
• ghc-debugger/GHC/Debugger/Stopped/Variables.hs +119/−0
• ghc-debugger/GHC/Debugger/Utils.hs +35/−0

@@ -30,7 +30,7 @@ ``` ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml ghcup install ghc latest-nightly -PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH cabal install exe:ghc-debug-adapter --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc+PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH cabal install ghc-debugger:ghc-debug-adapter --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc ```  To run the debugger, the same nightly version of GHC needs to be in PATH. Make

@@ -72,10 +72,10 @@   -- GHC is found in PATH (by hie-bios as well).   actualVersion <- liftIO $ P.readProcess "ghc" ["--numeric-version"] []   -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):-  when (not $ show __GLASGOW_HASKELL__ `L.isPrefixOf` (filter (/= '.') actualVersion)) $ do+  when (not $ show ( __GLASGOW_HASKELL__ :: Int ) `L.isPrefixOf` (filter (/= '.') actualVersion)) $ do     exitWithMsg $ "Aborting...! The GHC version must be the same which " ++                     "ghc-debug-adapter was compiled against (" ++-                      show __GLASGOW_HASKELL__ +++                      show ( __GLASGOW_HASKELL__ :: Int )++                         "). Instead, got " ++ (init{-drops \n-} actualVersion) ++ "."    Output.console $ T.pack "Discovering session flags with hie-bios..."

@@ -146,12 +146,8 @@     , variableType = Just $ T.pack varType     , variableEvaluateName = Just $ T.pack varName     , variableVariablesReference = fromEnum varRef-    , variableNamedVariables = case varFields of-        LabeledFields xs -> Just $ length xs-        _                -> Nothing-    , variableIndexedVariables = case varFields of-        IndexedFields xs -> Just $ length xs-        _                -> Nothing+    , variableNamedVariables = Nothing+    , variableIndexedVariables = Nothing     , variablePresentationHint = Just defaultVariablePresentationHint         { variablePresentationHintLazy = Just isThunk         }

@@ -2,20 +2,16 @@ module Main where  import System.Environment-import System.Exit import Data.Maybe import Text.Read  import DAP -import GHC.Debugger.Interface.Messages hiding (Command, Response)- import Development.Debug.Adapter.Init import Development.Debug.Adapter.Breakpoints import Development.Debug.Adapter.Stepping import Development.Debug.Adapter.Stopped import Development.Debug.Adapter.Evaluation-import Development.Debug.Adapter.Interface import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles import Development.Debug.Adapter

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               ghc-debugger-version:            0.1.0.0+version:            0.2.0.0 synopsis:     A step-through machine-interface debugger for GHC Haskell @@ -42,6 +42,16 @@ library     import:           warnings     exposed-modules:  GHC.Debugger,+                      GHC.Debugger.Evaluation,+                      GHC.Debugger.Breakpoint,+                      GHC.Debugger.Stopped,+                      GHC.Debugger.Stopped.Variables,+                      GHC.Debugger.Utils,+                      GHC.Debugger.Runtime,++                      GHC.Debugger.Runtime.Term.Key,+                      GHC.Debugger.Runtime.Term.Cache,+                       GHC.Debugger.Monad,                       GHC.Debugger.Interface.Messages     -- other-modules:

@@ -3,54 +3,18 @@    TypeApplications, ScopedTypeVariables, BangPatterns #-} module GHC.Debugger where -import Prelude hiding (exp, span) import System.Exit-import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Catch-import Data.Bits (xor) -import GHC-import GHC.Types.Unique.FM-import GHC.Types.Name.Reader #if MIN_VERSION_ghc(9,13,20250417) import GHC.Types.Name.Occurrence (sizeOccEnv) #endif-import GHC.Unit.Home.ModInfo-import GHC.Unit.Module.ModDetails-import GHC.Types.FieldLabel-import GHC.Types.TypeEnv-import GHC.Data.Maybe (expectJust)-import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS, mkUnboundName)-import GHC.Data.FastString-import GHC.Utils.Error (logOutput)-import GHC.Driver.DynFlags as GHC-import GHC.Driver.Env as GHC-import GHC.Driver.Monad-import GHC.Driver.Ppr as GHC-import GHC.Runtime.Debugger.Breakpoints as GHC-import GHC.Runtime.Eval.Types as GHC-import GHC.Runtime.Eval-import GHC.Core.DataCon-import GHC.Types.Breakpoint-import GHC.Types.Id as GHC-import GHC.Types.Name.Occurrence (mkVarOcc, mkVarOccFS)-import GHC.Types.Name.Reader as RdrName (mkOrig, globalRdrEnvElts, greName)-import GHC.Types.SrcLoc-import GHC.Tc.Utils.TcType-import GHC.Unit.Module.Env as GHC-import GHC.Utils.Outputable as GHC-import GHC.Utils.Misc (zipEqual)-import qualified GHC.Runtime.Debugger as GHCD-import qualified GHC.Runtime.Heap.Inspect as GHCI-import qualified GHCi.Message as GHCi-import qualified GHC.Unit.Home.Graph as HUG -import Data.Maybe-import Control.Monad.Reader-import Data.IORef-+import GHC.Debugger.Breakpoint+import GHC.Debugger.Evaluation+import GHC.Debugger.Stopped import GHC.Debugger.Monad+import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages  --------------------------------------------------------------------------------@@ -86,624 +50,4 @@   TerminateProcess -> liftIO $ do     -- Terminate!     exitWith ExitSuccess------------------------------------------------------------------------------------- * Breakpoints------------------------------------------------------------------------------------- | Remove all module breakpoints set on the given loaded module by path------ If the argument is @Nothing@, clear all function breakpoints instead.-clearBreakpoints :: Maybe FilePath -> Debugger ()-clearBreakpoints mfile = do-  -- It would be simpler to go to all loaded modules and disable all-  -- breakpoints for that module rather than keeping track,-  -- but much less efficient at scale.-  hsc_env <- getSession-  bids <- getActiveBreakpoints mfile-  forM_ bids $ \bid -> do-    GHC.setupBreakpoint hsc_env bid (breakpointStatusInt BreakpointDisabled)--  -- Clear out the state-  bpsRef <- asks activeBreakpoints-  liftIO $ writeIORef bpsRef emptyModuleEnv---- | Find a 'BreakpointId' and its span from a module + line + column.------ Used by 'setBreakpoints' and 'GetBreakpointsAt' requests-getBreakpointsAt :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (BreakIndex, RealSrcSpan))-getBreakpointsAt modl lineNum columnNum = do-  -- TODO: Cache moduleLineMap.-  mticks <- makeModuleLineMap (ms_mod modl)-  let mbid = do-        ticks <- mticks-        case columnNum of-          Nothing -> findBreakByLine lineNum ticks-          Just col -> findBreakByCoord (lineNum, col) ticks-  return mbid---- | Set a breakpoint in this session-setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound-setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do-  mmodl <- getModuleByPath path-  case mmodl of-    Left e -> do-      displayWarnings [e]-      return BreakNotFound-    Right modl -> do-      mbid <- getBreakpointsAt modl lineNum columnNum--      case mbid of-        Nothing -> return BreakNotFound-        Just (bix, span) -> do-          let bid = BreakpointId { bi_tick_mod = ms_mod modl-                                 , bi_tick_index = bix }-          changed <- registerBreakpoint bid bp_status ModuleBreakpointKind-          return $ BreakFound-            { changed = changed-            , sourceSpan = realSrcSpanToSourceSpan span-            , breakId = bid-            }-setBreakpoint FunctionBreak{function} bp_status = do-  logger <- getLogger-  resolveFunctionBreakpoint function >>= \case-    Left e -> error (showPprUnsafe e)-    Right (modl, mod_info, fun_str) -> do-      let modBreaks = GHC.modInfoModBreaks mod_info-          applyBreak (bix, span) = do-            let bid = BreakpointId { bi_tick_mod = modl-                                   , bi_tick_index = bix }-            changed <- registerBreakpoint bid bp_status FunctionBreakpointKind-            return $ BreakFound-              { changed = changed-              , sourceSpan = realSrcSpanToSourceSpan span-              , breakId = bid-              }-      case findBreakForBind fun_str modBreaks of-        []  -> do-          liftIO $ logOutput logger (text $ "No breakpoint found by name " ++ function ++ ". Ignoring...")-          return BreakNotFound-        [b] -> applyBreak b-        bs  -> do-          liftIO $ logOutput logger (text $ "Ambiguous breakpoint found by name " ++ function ++ ": " ++ show bs ++ ". Setting breakpoints in all...")-          ManyBreaksFound <$> mapM applyBreak bs-setBreakpoint exception_bp bp_status = do-  let ch_opt | BreakpointDisabled <- bp_status-             = gopt_unset-             | otherwise-             = gopt_set-      opt | OnUncaughtExceptionsBreak <- exception_bp-          = Opt_BreakOnError-          | OnExceptionsBreak <- exception_bp-          = Opt_BreakOnException-  dflags <- GHC.getInteractiveDynFlags-  let-    -- changed if option is ON and bp is OFF (breakpoint disabled), or if-    -- option is OFF and bp is ON (i.e. XOR)-    breakOn = bp_status /= BreakpointDisabled-    didChange = gopt opt dflags `xor` breakOn-  GHC.setInteractiveDynFlags $ dflags `ch_opt` opt-  return (BreakFoundNoLoc didChange)------------------------------------------------------------------------------------- * Evaluation------------------------------------------------------------------------------------- | Run a program with debugging enabled-debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult-debugExecution entry args = do--  -- consider always using :trace like ghci-dap to always have a stacktrace?-  -- better solution could involve profiling stack traces or from IPE info?--  (entryExp, exOpts) <- case entry of--    MainEntry nm -> do-      let prog = fromMaybe "main" nm-      wrapper <- mkEvalWrapper prog args -- bit weird that the prog name is the expression but fine-      let execWrap' fhv = GHCi.EvalApp (GHCi.EvalThis wrapper) (GHCi.EvalThis fhv)-          opts = GHC.execOptions {execWrap = execWrap'}-      return (prog, opts)--    FunctionEntry fn ->-      -- TODO: if "args" is unescaped (e.g. "some", "thing"), then "some" and-      -- "thing" will be interpreted as variables. To pass strings it needs to-      -- be "\"some\"" "\"things\"".-      return (fn ++ " " ++ unwords args, GHC.execOptions)--  GHC.execStmt entryExp exOpts >>= handleExecResult--  where-    -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run-    mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue-    mkEvalWrapper progname' args' =-      runInternal $ GHC.compileParsedExprRemote-      $ evalWrapper' `GHC.mkHsApp` nlHsString progname'-                     `GHC.mkHsApp` nlList (map nlHsString args')-      where-        nlHsString = nlHsLit . mkHsString-        evalWrapper' =-          GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper"))--    -- run internal here serves to overwrite certain flags while executing the-    -- internal "evalWrapper" computation which is not relevant to the user.-    runInternal :: GhcMonad m => m a -> m a-    runInternal =-        withTempSession mkTempSession-      where-        mkTempSession = hscUpdateFlags (\dflags -> dflags-          { -- Disable dumping of any data during evaluation of GHCi's internal expressions. (#17500)-            dumpFlags = mempty-          }-              -- We depend on -fimplicit-import-qualified to compile expr-              -- with fully qualified names without imports (gHC_INTERNAL_GHCI_HELPERS above).-              `gopt_set` Opt_ImplicitImportQualified-          )----- | Resume execution of the stopped debuggee program-doContinue :: Debugger EvalResult-doContinue = do-  leaveSuspendedState-  GHC.resumeExec RunToCompletion Nothing-    >>= handleExecResult---- | Resume execution but only take a single step.-doSingleStep :: Debugger EvalResult-doSingleStep = do-  leaveSuspendedState-  GHC.resumeExec SingleStep Nothing-    >>= handleExecResult---- | Resume execution but stop at the next tick within the same function.------ To do a local step, we get the SrcSpan of the current suspension state and--- get its 'enclosingTickSpan' to use as a filter for breakpoints in the call--- to 'resumeExec'. Execution will only stop at breakpoints whose span matches--- this enclosing span.-doLocalStep :: Debugger EvalResult-doLocalStep = do-  leaveSuspendedState-  mb_span <- getCurrentBreakSpan-  case mb_span of-    Nothing -> error "not stopped at a breakpoint?!"-    Just (UnhelpfulSpan _) -> do-      liftIO $ putStrLn "Stopped at an exception. Forcing step into..."-      GHC.resumeExec SingleStep Nothing >>= handleExecResult-    Just loc -> do-      md <- fromMaybe (error "doLocalStep") <$> getCurrentBreakModule-      -- TODO: Cache moduleLineMap.-      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md-      let current_toplevel_decl = enclosingTickSpan ticks loc-      GHC.resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult---- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context).-doEval :: String -> Debugger EvalResult-doEval exp = do-  excr <- (Right <$> GHC.execStmt exp GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e))-  case excr of-    Left err -> pure $ EvalAbortedWith err-    Right ExecBreak{} -> continueToCompletion >>= handleExecResult-    Right r@ExecComplete{} -> handleExecResult r---- | Turn a GHC's 'ExecResult' into an 'EvalResult' response-handleExecResult :: GHC.ExecResult -> Debugger EvalResult-handleExecResult = \case-    ExecComplete {execResult} -> do-      case execResult of-        Left e -> return (EvalException (show e) "SomeException")-        Right [] -> return (EvalCompleted "" "") -- Evaluation completed without binding any result.-        Right (n:_ns) -> inspectName n >>= \case-          Just VarInfo{varValue, varType} -> return (EvalCompleted varValue varType)-          Nothing     -> liftIO $ fail "doEval failed"-    ExecBreak {breakNames = _, breakPointId = Nothing} ->-      -- Stopped at an exception-      -- TODO: force the exception to display string with Backtrace?-      return EvalStopped{breakId = Nothing}-    ExecBreak {breakNames = _, breakPointId} ->-      return EvalStopped{breakId = toBreakpointId <$> breakPointId}--{--Note [Don't crash if not stopped]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Requests such as `stacktrace`, `scopes`, or `variables` may end up-coming after the execution of a program has terminated. For instance,-consider this interleaving:--1. SENT Stopped event         <-- we're stopped-2. RECEIVED StackTrace req    <-- client issues after stopped event-3. RECEIVED Next req          <-- user clicks step-next-4. <program execution resumes and fails>-5. SENT Terminate event       <-- execution failed and we report it to exit cleanly-6. RECEIVED Scopes req        <-- happens as a sequence of 2 that wasn't canceled-7. <used to crash! because we're no longer at a breakpoint>--Now, we simply returned empty responses when these requests come in-while we're no longer at a breakpoint. The client will soon come to a halt-because of the termination event we sent.--}------------------------------------------------------------------------------------- * Stack trace------------------------------------------------------------------------------------- | Get the stack frames at the point we're stopped at-getStacktrace :: Debugger [StackFrame]-getStacktrace = GHC.getResumeContext >>= \case-  [] ->-    -- See Note [Don't crash if not stopped]-    return []-  r:_-    | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)-    -> return-        [ StackFrame-          { name = GHC.resumeDecl r-          , sourceSpan = realSrcSpanToSourceSpan ss-          }-        ]-    | otherwise ->-        -- No resume span; which should mean we're stopped on an exception.-        -- No info for now.-        return []------------------------------------------------------------------------------------- * Scopes------------------------------------------------------------------------------------- | Get the stack frames at the point we're stopped at-getScopes :: Debugger [ScopeInfo]-getScopes = GHC.getCurrentBreakSpan >>= \case-  Nothing ->-    -- See Note [Don't crash if not stopped]-    return []-  Just span-    | Just rss <- srcSpanToRealSrcSpan span-    , let sourceSpan = realSrcSpanToSourceSpan rss-    -> do-      -- It is /very important/ to report a number of variables (numVars) for-      -- larger scopes. If we just say "Nothing", then all variables of all-      -- scopes will be fetched at every stopped event.-      curr_modl <- expectJust <$> getCurrentBreakModule-      hsc_env <- getSession-      in_mod <- getTopEnv curr_modl-      imported <- getTopImported curr_modl-      return-        [ ScopeInfo { kind = LocalVariablesScope-                    , expensive = False-                    , numVars = Nothing-                    , sourceSpan-                    }-        , ScopeInfo { kind = ModuleVariablesScope-                    , expensive = True-                    , numVars = Just (sizeUFM in_mod)-                    , sourceSpan-                    }-        , ScopeInfo { kind = GlobalVariablesScope-                    , expensive = True-#if MIN_VERSION_ghc(9,13,20250417)-                    , numVars = Just (sizeOccEnv imported)-#else-                    , numVars = Nothing-#endif-                    , sourceSpan-                    }-        ]-    | otherwise ->-      -- No resume span; which should mean we're stopped on an exception-      -- TODO: Use exception context to create source span, or at least-      -- return the source span null to have Scopes at least.-      return []------------------------------------------------------------------------------------- * Variables------------------------------------------------------------------------------------ Note [Variables Requests]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- We can receive a Variables request for three different reasons------ 1. To get the variables in a certain scope--- 2. To inspect the value of a lazy variable--- 3. To expand the structure of a variable------ The replies are, respectively:------ (VARR)--- (a) All the variables in the request scope--- (b) ONLY the variable requested--- (c) The fields of the variable requested but NOT the original variable---- | Get variables using a variable/variables reference------ If the Variable Request ends up being case (VARR)(b), then we signal the--- request forced the variable and return @Left varInfo@. Otherwise, @Right vis@.------ See Note [Variables Requests]-getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])-getVariables vk = do-  hsc_env <- getSession-  GHC.getResumeContext >>= \case-    [] ->-      -- See Note [Don't crash if not stopped]-      return (Right [])-    r:_ -> case vk of--      -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)-      -- (VARR)(b,c)-      SpecificVariable i -> do-        lookupVarByReference i >>= \case-          Nothing -> error "lookupVarByReference failed"-          Just (n, term) -> do-            let ty = GHCI.termType term-            term' <- if isBoringTy ty-                        then deepseqTerm term -- deepseq boring types like String, because it is more helpful to print them whole than their structure.-                        else seqTerm term-            -- insertVarReference i n term' -- update with evaluated term?-            vi <- termToVarInfo n term'-            case term {- original term -} of--              -- (VARR)(b)-              Suspension{} -> do-                -- Original Term was a suspension:-                -- It is a "lazy" DAP variable, so our reply can ONLY include-                -- this single variable. So we erase the @varFields@ after the fact.-                return (Left vi{varFields = NoFields})--              -- (VARR)(c)-              _ -> Right <$> do-                -- Original Term was already something other than a Suspension;-                -- Meaning the @SpecificVariable@ request means to inspect the structure.-                -- Return ONLY the fields-                case varFields vi of-                  NoFields -> return []-                  LabeledFields xs -> return xs-                  IndexedFields xs -> return xs--      -- (VARR)(a) from here onwards--      LocalVariables -> fmap Right $-        -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)-        mapM (tyThingToVarInfo defaultDepth) =<< GHC.getBindings--      ModuleVariables -> Right <$> do-        case ibi_tick_mod <$> GHC.resumeBreakpointId r of-          Nothing -> return []-          Just curr_modl -> do-            things <- typeEnvElts <$> getTopEnv curr_modl-            mapM (\tt -> do-              nameStr <- display (getName tt)-              vi <- tyThingToVarInfo 1 tt-              return vi{varName = nameStr}) things--      GlobalVariables -> Right <$> do-        case ibi_tick_mod <$> GHC.resumeBreakpointId r of-          Nothing -> return []-          Just curr_modl -> do-            hsc_env <- getSession-            names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl-            mapM (\n-> do-              nameStr <- display n-              liftIO (GHC.lookupType hsc_env n) >>= \case-                Nothing ->-                  return VarInfo-                    { varName = nameStr-                    , varType = ""-                    , varValue = ""-                    , isThunk = False-                    , varRef = NoVariables-                    , varFields = NoFields-                    }-                Just tt -> do-                  vi <- tyThingToVarInfo 1 tt {- don't look deep for global and mod vars -}-                  return vi{varName = nameStr}-              ) names--      NoVariables -> Right <$> do-        return []--defaultDepth =  5 -- the depth determines how much of the structure is traversed.-                  -- using a small value like 5 here is what causes the-                  -- structure to be improperly rendered inline with many underscores.-                  -- Note: GHCi uses depth=100-                  -- TODO: Investigate why this isn't fast enough to use 100.-                  -- TODO: We need a new metric to determine how much we force.-                  -- Depth is not good enough because e.g for a very broad-                  -- recursive type it will be exponentially many nodes to-                  -- visit-                  -- For now, try depth=5------------------------------------------------------------------------------------- * GHC Utilities------------------------------------------------------------------------------------- | All top-level things from a module, including unexported ones.-getTopEnv :: Module -> Debugger TypeEnv-getTopEnv modl = do-  hsc_env <- getSession-  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case-    Nothing -> return emptyTypeEnv-    Just HomeModInfo-      { hm_details = ModDetails-        { md_types = things-        }-      } -> return things---- | All bindings imported at a given module-getTopImported :: Module -> Debugger GlobalRdrEnv-getTopImported modl = do-  hsc_env <- getSession-  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case-    Nothing -> return emptyGlobalRdrEnv-#if MIN_VERSION_ghc(9,13,20250417)-    Just hmi -> mkTopLevImportedEnv hsc_env hmi-#else-    Just hmi -> return emptyGlobalRdrEnv-#endif---- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'.-inspectName :: Name -> Debugger (Maybe VarInfo)-inspectName n = do-  GHC.lookupName n >>= \case-    Nothing -> do-      liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n)-      pure Nothing-    Just tt -> Just <$> tyThingToVarInfo defaultDepth tt---- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the--- value of the thing (as in @True = :force@, @False = :print@)-tyThingToVarInfo :: Int {-^ Depth -} -> TyThing -> Debugger VarInfo-tyThingToVarInfo depth0 = \case-  t@(AConLike c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields-  t@(ATyCon c)   -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields-  t@(ACoAxiom c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables <*> pure NoFields-  AnId i -> do-    -- For boring types we want to get the value as it is (by traversing it to-    -- the end), rather than stopping short and returning a suspension (e.g.-    -- for the string tail), because boring types are printed whole rather than-    -- being represented by an expandable structure.-    let depth1 = if isBoringTy (GHC.idType i) then maxBound else depth0-    term <- GHC.obtainTermFromId depth1 False{-don't force-} i-    termToVarInfo (GHC.idName i) term---- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds-termToVarInfo :: Name -> Term -> Debugger VarInfo-termToVarInfo top_name top_term = do--  -- Make a VarInfo for the top term.-  top_vi <- go top_name top_term--  sub_vis <- case top_term of-      -- Boring types don't get subfields-      _ | isBoringTy (GHCI.termType top_term) ->-        return NoFields--      -- Make 'VarInfo's for the first layer of subTerms only.-      Term{dc=Right dc, subTerms} -> do-        case dataConFieldLabels dc of-          -- Not a record type,-          -- Use indexed fields-          [] -> do-            let names = zipWith (\ix _ -> mkIndexVar ix) [1..] (dataConOrigArgTys dc)-            IndexedFields <$> mapM (uncurry go) (zipEqual names subTerms)-          -- Is a record type,-          -- Use field labels-          dataConFields -> do-            let names = map flSelector dataConFields-            LabeledFields <$> mapM (uncurry go) (zipEqual names subTerms)-      NewtypeWrap{dc=Right dc, wrapped_term} -> do-        case dataConFieldLabels dc of-          [] -> do-            let name = mkIndexVar 1-            wvi <- go name wrapped_term-            return (IndexedFields [wvi])-          [fld] -> do-            let name = flSelector fld-            wvi <- go name wrapped_term-            return (LabeledFields [wvi])-          _ -> error "unexpected number of Newtype fields: larger than 1"-      _ -> return NoFields--  return top_vi{varFields = sub_vis}--  where-    -- Make a VarInfo for a term, but don't recurse into the fields and return-    -- @NoFields@ for 'varFields'.-    ---    -- We do this because we don't want to recursively return all sub-fields ---    -- only the first layer of fields for the top term.-    go n term = do-      let-        varFields = NoFields-        isThunk-          -- to have more information we could match further on @Heap.ClosureType@-         | Suspension{} <- term = True-         | otherwise = False-        ty = GHCI.termType term--        -- We scrape the subterms to display as the var's value. The structure is-        -- displayed in the editor itself by expanding the variable sub-fields-        -- (`varFields`). -        termHead t-          -- But show strings and lits in full-          | isBoringTy ty = t-          | otherwise     = case t of-             Term{}                    -> t{subTerms = []}-             NewtypeWrap{wrapped_term} -> t{wrapped_term = termHead wrapped_term}-             _                         -> t-      varName <- display n-      varType <- display ty-      varValue <- display =<< GHCD.showTerm (termHead term)-      -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)--      -- The VarReference allows user to expand variable structure and inspect its value.-      -- Here, we do not want to allow expanding a term that is fully evaluated.-      -- We only want to return @SpecificVariable@ (which allows expansion) for-      -- values with sub-fields or thunks.-      varRef <- do-        if GHCI.isFullyEvaluatedTerm term-           -- Even if it is already evaluated, we do want to display a-           -- structure as long if it is not a "boring type" (one that does not-           -- provide useful information from being expanded)-           -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)-           && (isBoringTy ty || not (hasDirectSubTerms term))-         then-            return NoVariables-         else do-            ir <- freshInt-            insertVarReference ir n term-            return (SpecificVariable ir)--      return VarInfo{..}--    hasDirectSubTerms = \case-      Suspension{}   -> False-      Prim{}         -> False-      NewtypeWrap{}  -> True-      RefWrap{}      -> True-      Term{subTerms} -> not $ null subTerms--    mkIndexVar ix = mkUnboundName (mkVarOcc ("_" ++ show @Int ix))---- | A boring type is one for which we don't care about the structure and would--- rather see "whole" when being inspected. Strings and literals are a good--- example, because it's more useful to see the string value than it is to see--- a linked list of characters where each has to be forced individually.-isBoringTy :: Type -> Bool-isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t-                || isIntegerTy t || isNaturalTy t || isCharTy t---- | Whenever we run a request that continues execution from the current--- suspended state, such as Next,Step,Continue, this function should be called--- to delete the variable references that become invalid as we leave the--- suspended state.------ In particular, @'varReferences'@ is reset.------ See also section "Lifetime of Objects References" in the DAP specification.-leaveSuspendedState :: Debugger ()-leaveSuspendedState = do-  -- TODO:-  --  [ ] Preserve bindings introduced by evaluate requests-  ioref <- asks varReferences-  liftIO $ writeIORef ioref mempty---- | Convert a GHC's src span into an interface one-realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan-realSrcSpanToSourceSpan ss = SourceSpan-  { file = unpackFS $ srcSpanFile ss-  , startLine = srcSpanStartLine ss-  , startCol = srcSpanStartCol ss-  , endLine = srcSpanEndLine ss-  , endCol = srcSpanEndCol ss-  }------------------------------------------------------------------------------------- * General utilities------------------------------------------------------------------------------------- | Display an Outputable value as a String-display :: Outputable a => a -> Debugger String-display x = do-  dflags <- getDynFlags-  return $ showSDoc dflags (ppr x)-{-# INLINE display #-} 

@@ -0,0 +1,123 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+   TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Breakpoint where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.IORef+import Data.Bits (xor)++import GHC+#if MIN_VERSION_ghc(9,13,20250417)+import GHC.Types.Name.Occurrence (sizeOccEnv)+#endif+import GHC.Utils.Error (logOutput)+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Ppr as GHC+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.Unit.Module.Env as GHC+import GHC.Utils.Outputable as GHC++import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * Breakpoints+--------------------------------------------------------------------------------++-- | Remove all module breakpoints set on the given loaded module by path+--+-- If the argument is @Nothing@, clear all function breakpoints instead.+clearBreakpoints :: Maybe FilePath -> Debugger ()+clearBreakpoints mfile = do+  -- It would be simpler to go to all loaded modules and disable all+  -- breakpoints for that module rather than keeping track,+  -- but much less efficient at scale.+  hsc_env <- getSession+  bids <- getActiveBreakpoints mfile+  forM_ bids $ \bid -> do+    GHC.setupBreakpoint hsc_env bid (breakpointStatusInt BreakpointDisabled)++  -- Clear out the state+  bpsRef <- asks activeBreakpoints+  liftIO $ writeIORef bpsRef emptyModuleEnv++-- | Find a 'BreakpointId' and its span from a module + line + column.+--+-- Used by 'setBreakpoints' and 'GetBreakpointsAt' requests+getBreakpointsAt :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (BreakIndex, RealSrcSpan))+getBreakpointsAt modl lineNum columnNum = do+  -- TODO: Cache moduleLineMap.+  mticks <- makeModuleLineMap (ms_mod modl)+  let mbid = do+        ticks <- mticks+        case columnNum of+          Nothing -> findBreakByLine lineNum ticks+          Just col -> findBreakByCoord (lineNum, col) ticks+  return mbid++-- | Set a breakpoint in this session+setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound+setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do+  mmodl <- getModuleByPath path+  case mmodl of+    Left e -> do+      displayWarnings [e]+      return BreakNotFound+    Right modl -> do+      mbid <- getBreakpointsAt modl lineNum columnNum++      case mbid of+        Nothing -> return BreakNotFound+        Just (bix, spn) -> do+          let bid = BreakpointId { bi_tick_mod = ms_mod modl+                                 , bi_tick_index = bix }+          changed <- registerBreakpoint bid bp_status ModuleBreakpointKind+          return $ BreakFound+            { changed = changed+            , sourceSpan = realSrcSpanToSourceSpan spn+            , breakId = bid+            }+setBreakpoint FunctionBreak{function} bp_status = do+  logger <- getLogger+  resolveFunctionBreakpoint function >>= \case+    Left e -> error (showPprUnsafe e)+    Right (modl, mod_info, fun_str) -> do+      let modBreaks = GHC.modInfoModBreaks mod_info+          applyBreak (bix, spn) = do+            let bid = BreakpointId { bi_tick_mod = modl+                                   , bi_tick_index = bix }+            changed <- registerBreakpoint bid bp_status FunctionBreakpointKind+            return $ BreakFound+              { changed = changed+              , sourceSpan = realSrcSpanToSourceSpan spn+              , breakId = bid+              }+      case findBreakForBind fun_str modBreaks of+        []  -> do+          liftIO $ logOutput logger (text $ "No breakpoint found by name " ++ function ++ ". Ignoring...")+          return BreakNotFound+        [b] -> applyBreak b+        bs  -> do+          liftIO $ logOutput logger (text $ "Ambiguous breakpoint found by name " ++ function ++ ": " ++ show bs ++ ". Setting breakpoints in all...")+          ManyBreaksFound <$> mapM applyBreak bs+setBreakpoint exception_bp bp_status = do+  let ch_opt | BreakpointDisabled <- bp_status+             = gopt_unset+             | otherwise+             = gopt_set+      opt | OnUncaughtExceptionsBreak <- exception_bp+          = Opt_BreakOnError+          | OnExceptionsBreak <- exception_bp+          = Opt_BreakOnException+  dflags <- GHC.getInteractiveDynFlags+  let+    -- changed if option is ON and bp is OFF (breakpoint disabled), or if+    -- option is OFF and bp is ON (i.e. XOR)+    breakOn = bp_status /= BreakpointDisabled+    didChange = gopt opt dflags `xor` breakOn+  GHC.setInteractiveDynFlags $ dflags `ch_opt` opt+  return (BreakFoundNoLoc didChange)

@@ -0,0 +1,157 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+   TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Evaluation where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Data.Maybe++import GHC+#if MIN_VERSION_ghc(9,13,20250417)+import GHC.Types.Name.Occurrence (sizeOccEnv)+#endif+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Data.FastString+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Env as GHC+import GHC.Driver.Monad+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.Types.Breakpoint+import GHC.Types.Name.Occurrence (mkVarOccFS)+import GHC.Types.Name.Reader as RdrName (mkOrig)+import GHC.Utils.Outputable as GHC+import qualified GHCi.Message as GHCi++import GHC.Debugger.Stopped.Variables+import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * Evaluation+--------------------------------------------------------------------------------++-- | Run a program with debugging enabled+debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution entry args = do++  -- consider always using :trace like ghci-dap to always have a stacktrace?+  -- better solution could involve profiling stack traces or from IPE info?++  (entryExp, exOpts) <- case entry of++    MainEntry nm -> do+      let prog = fromMaybe "main" nm+      wrapper <- mkEvalWrapper prog args -- bit weird that the prog name is the expression but fine+      let execWrap' fhv = GHCi.EvalApp (GHCi.EvalThis wrapper) (GHCi.EvalThis fhv)+          opts = GHC.execOptions {execWrap = execWrap'}+      return (prog, opts)++    FunctionEntry fn ->+      -- TODO: if "args" is unescaped (e.g. "some", "thing"), then "some" and+      -- "thing" will be interpreted as variables. To pass strings it needs to+      -- be "\"some\"" "\"things\"".+      return (fn ++ " " ++ unwords args, GHC.execOptions)++  GHC.execStmt entryExp exOpts >>= handleExecResult++  where+    -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run+    mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue+    mkEvalWrapper progname' args' =+      runInternal $ GHC.compileParsedExprRemote+      $ evalWrapper' `GHC.mkHsApp` nlHsString progname'+                     `GHC.mkHsApp` nlList (map nlHsString args')+      where+        nlHsString = nlHsLit . mkHsString+        evalWrapper' =+          GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper"))++    -- run internal here serves to overwrite certain flags while executing the+    -- internal "evalWrapper" computation which is not relevant to the user.+    runInternal :: GhcMonad m => m a -> m a+    runInternal =+        withTempSession mkTempSession+      where+        mkTempSession = hscUpdateFlags (\dflags -> dflags+          { -- Disable dumping of any data during evaluation of GHCi's internal expressions. (#17500)+            dumpFlags = mempty+          }+              -- We depend on -fimplicit-import-qualified to compile expr+              -- with fully qualified names without imports (gHC_INTERNAL_GHCI_HELPERS above).+              `gopt_set` Opt_ImplicitImportQualified+          )+++-- | Resume execution of the stopped debuggee program+doContinue :: Debugger EvalResult+doContinue = do+  leaveSuspendedState+  GHC.resumeExec RunToCompletion Nothing+    >>= handleExecResult++-- | Resume execution but only take a single step.+doSingleStep :: Debugger EvalResult+doSingleStep = do+  leaveSuspendedState+  GHC.resumeExec SingleStep Nothing+    >>= handleExecResult++-- | Resume execution but stop at the next tick within the same function.+--+-- To do a local step, we get the SrcSpan of the current suspension state and+-- get its 'enclosingTickSpan' to use as a filter for breakpoints in the call+-- to 'resumeExec'. Execution will only stop at breakpoints whose span matches+-- this enclosing span.+doLocalStep :: Debugger EvalResult+doLocalStep = do+  leaveSuspendedState+  mb_span <- getCurrentBreakSpan+  case mb_span of+    Nothing -> error "not stopped at a breakpoint?!"+    Just (UnhelpfulSpan _) -> do+      liftIO $ putStrLn "Stopped at an exception. Forcing step into..."+      GHC.resumeExec SingleStep Nothing >>= handleExecResult+    Just loc -> do+      md <- fromMaybe (error "doLocalStep") <$> getCurrentBreakModule+      -- TODO: Cache moduleLineMap.+      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md+      let current_toplevel_decl = enclosingTickSpan ticks loc+      GHC.resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult++-- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context).+doEval :: String -> Debugger EvalResult+doEval expr = do+  excr <- (Right <$> GHC.execStmt expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e))+  case excr of+    Left err -> pure $ EvalAbortedWith err+    Right ExecBreak{} -> continueToCompletion >>= handleExecResult+    Right r@ExecComplete{} -> handleExecResult r++-- | Turn a GHC's 'ExecResult' into an 'EvalResult' response+handleExecResult :: GHC.ExecResult -> Debugger EvalResult+handleExecResult = \case+    ExecComplete {execResult} -> do+      case execResult of+        Left e -> return (EvalException (show e) "SomeException")+        Right [] -> return (EvalCompleted "" "") -- Evaluation completed without binding any result.+        Right (n:_ns) -> inspectName n >>= \case+          Just VarInfo{varValue, varType} -> return (EvalCompleted varValue varType)+          Nothing     -> liftIO $ fail "doEval failed"+    ExecBreak {breakNames = _, breakPointId = Nothing} ->+      -- Stopped at an exception+      -- TODO: force the exception to display string with Backtrace?+      return EvalStopped{breakId = Nothing}+    ExecBreak {breakNames = _, breakPointId} ->+      return EvalStopped{breakId = toBreakpointId <$> breakPointId}++-- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'.+inspectName :: Name -> Debugger (Maybe VarInfo)+inspectName n = do+  GHC.lookupName n >>= \case+    Nothing -> do+      liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n)+      pure Nothing+    Just tt -> Just <$> tyThingToVarInfo tt+

@@ -110,9 +110,6 @@       , varRef   :: VariableReference       -- ^ A reference back to this variable -      , varFields :: VarFields-      -- ^ A 'VarInfo' for each field. These may be named (@Left@) or indexed fields (@Right@).-       -- TODO:       --  memory reference using ghc-debug.       }

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, NamedFieldPuns, TupleSections, LambdaCase, OverloadedRecordDot #-}+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, NamedFieldPuns, TupleSections, LambdaCase, OverloadedRecordDot, TypeApplications #-} module GHC.Debugger.Monad where  import Prelude hiding (mod)@@ -13,6 +13,8 @@ import Control.Monad.Catch  import GHC+import GHC.Types.Name (mkDerivedInternalName)+import GHC.Types.Name.Occurrence (mkVarOcc) import qualified GHCi.BreakArray as BA import GHC.Driver.DynFlags as GHC import GHC.Driver.Phases as GHC@@ -28,6 +30,7 @@ import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Heap.Inspect import GHC.Unit.Module.Env as GHC+import GHC.Types.Name.Env import GHC.Driver.Env  import Data.IORef@@ -39,6 +42,8 @@ import Control.Monad.Reader  import GHC.Debugger.Interface.Messages+import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Runtime.Term.Cache import System.Posix.Signals  -- | A debugger action.@@ -54,13 +59,21 @@       { activeBreakpoints :: IORef (ModuleEnv (IM.IntMap (BreakpointStatus, BreakpointKind)))         -- ^ Maps a 'BreakpointId' in Trie representation to the         -- 'BreakpointStatus' it was activated with.-      , varReferences     :: IORef (IM.IntMap (Name, Term))++      , varReferences     :: IORef (IM.IntMap TermKey, TermKeyMap Int)       -- ^ When we're stopped at a breakpoint, this maps variable reference to       -- Terms to allow further inspection and forcing by reference.       --       -- This map is only valid while stopped in this context. After stepping       -- or resuming evaluation in any available way, this map becomes invalid       -- and should therefore be cleaned.+      --+      -- The TermKeyMap map is a reverse lookup map to find which references+      -- already exist for given names++      , termCache         :: IORef TermCache+      -- ^ TermCache+       , genUniq           :: IORef Int       -- ^ Generates unique ints       }@@ -299,26 +312,51 @@ --------------------------------------------------------------------------------  -- | Find a variable's associated Term and Name by reference ('Int')-lookupVarByReference :: Int -> Debugger (Maybe (Name, Term))+lookupVarByReference :: Int -> Debugger (Maybe TermKey) lookupVarByReference i = do   ioref <- asks varReferences-  rm <- readIORef ioref & liftIO+  (rm, _) <- readIORef ioref & liftIO   return $ IM.lookup i rm --- | Inserts a mapping from the given variable reference to the variable's--- associated Term and the Name it is bound to for display-insertVarReference :: Int -> Name -> Term -> Debugger ()-insertVarReference i name term = do+-- | Finds or creates an integer var reference for the given 'TermKey'.+-- TODO: Arguably, this mapping should be part of the debug-adapter, and+-- ghc-debugger should deal in 'TermKey' terms only.+getVarReference :: TermKey -> Debugger Int+getVarReference key = do+  ioref     <- asks varReferences+  (rm, tkm) <- readIORef ioref & liftIO+  (i, tkm') <- case lookupTermKeyMap key tkm of+    Nothing -> do+      new_i <- freshInt+      return (new_i, insertTermKeyMap key new_i tkm)+    Just existing_i ->+      return (existing_i, tkm)+  let rm' = IM.insert i key rm+  writeIORef ioref (rm', tkm') & liftIO+  return i++-- | Whenever we run a request that continues execution from the current+-- suspended state, such as Next,Step,Continue, this function should be called+-- to delete the variable references that become invalid as we leave the+-- suspended state.+--+-- In particular, @'varReferences'@ is reset.+--+-- See also section "Lifetime of Objects References" in the DAP specification.+leaveSuspendedState :: Debugger ()+leaveSuspendedState = do   ioref <- asks varReferences-  rm <- readIORef ioref & liftIO-  let-    rm' = IM.insert i (name, term) rm-  writeIORef ioref rm' & liftIO+  liftIO $ writeIORef ioref mempty  -------------------------------------------------------------------------------- -- Utilities -------------------------------------------------------------------------------- +defaultDepth :: Int+defaultDepth =  2 -- the depth determines how much of the runtime structure is traversed.+                  -- @obtainTerm@ and friends handle fetching arbitrarily nested data structures+                  -- so we only depth enough to get to the next level of subterms.+ -- | Evaluate a suspended Term to WHNF. -- -- Used in @'getVariables'@ to reply to a variable introspection request.@@ -334,9 +372,11 @@       () <- fromEvalResult r       let         forceThunks = False {- whether to force the thunk subterms -}-        forceDepth  = 5+        forceDepth  = defaultDepth       cvObtainTerm hsc_env forceDepth forceThunks ty val-    NewtypeWrap{wrapped_term} -> seqTerm wrapped_term+    NewtypeWrap{wrapped_term} -> do+      wrapped_term' <- seqTerm wrapped_term+      return term{wrapped_term=wrapped_term'}     _ -> return term  -- | Evaluate a Term to NF@@ -381,7 +421,8 @@ -- | Initialize a 'DebuggerState' initialDebuggerState :: GHC.Ghc DebuggerState initialDebuggerState = DebuggerState <$> liftIO (newIORef emptyModuleEnv)-                                     <*> liftIO (newIORef IM.empty)+                                     <*> liftIO (newIORef mempty)+                                     <*> liftIO (newIORef mempty)                                      <*> liftIO (newIORef 0)  -- | Lift a 'Ghc' action into a 'Debugger' one.

@@ -0,0 +1,80 @@+{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-}+module GHC.Debugger.Runtime where++import Data.IORef+import Control.Monad.Reader+import Control.Monad.IO.Class+import qualified Data.List as L++import GHC+import GHC.Types.Id+import GHC.Types.FieldLabel+import GHC.Tc.Utils.TcType+import GHC.Runtime.Eval+import GHC.Types.Unique.Supply (uniqFromTag)+import GHC.Types.Name.Env++import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Monad++-- | Obtain the runtime 'Term' from a 'TermKey'.+--+-- The 'TermKey' will be looked up in the 'TermCache' to avoid recomputing the+-- 'Term' if possible. On a cache miss the Term will be reconstructed from+-- scratch and stored in the cache.+obtainTerm :: TermKey -> Debugger Term+obtainTerm key = do+  tc_ref <- asks termCache+  tc     <- liftIO $ readIORef tc_ref+  case lookupTermCache key tc of+    -- cache miss: reconstruct, then store.+    Nothing ->+      let+        -- For boring types we want to get the value as it is (by traversing it to+        -- the end), rather than stopping short and returning a suspension (e.g.+        -- for the string tail), because boring types are printed whole rather than+        -- being represented by an expandable structure.+        depth i = if isBoringTy (GHC.idType i) then maxBound else defaultDepth++        -- Recursively get terms until we hit the desired key.+        getTerm = \case+          FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i+          FromPath k pf -> do+            term <- getTerm k >>= \case+              -- When the key points to a Suspension, the real thing should+              -- already be forced. It's just that the shallow depth meant we+              -- returned a Suspension nonetheless while recursing in `getTerm`.+              t@Suspension{} -> do+                t' <- seqTerm t+                -- update term cache with intermediate values?+                -- insertTermCache k t'+                return t'+              t -> return t+            return $ case term of+              Term{dc=Right dc, subTerms} -> case pf of+                PositionalIndex ix -> subTerms !! (ix-1)+                LabeledField fl    ->+                  case L.findIndex (== fl) (map flSelector $ dataConFieldLabels dc) of+                    Just ix -> subTerms !! (ix-1)+                    Nothing -> error "Couldn't find labeled field in dataConFieldLabels"+              NewtypeWrap{wrapped_term} ->+                wrapped_term -- regardless of PathFragment+              _ -> error "Unexpected term for the given TermKey"+       in do+        term <- getTerm key+        liftIO $ writeIORef tc_ref (insertTermCache key term tc)+        return term++    -- cache hit+    Just hit -> return hit++-- | A boring type is one for which we don't care about the structure and would+-- rather see "whole" when being inspected. Strings and literals are a good+-- example, because it's more useful to see the string value than it is to see+-- a linked list of characters where each has to be forced individually.+isBoringTy :: Type -> Bool+isBoringTy t = isDoubleTy t || isFloatTy t || isIntTy t || isWordTy t || isStringTy t+                || isIntegerTy t || isNaturalTy t || isCharTy t++

@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+module GHC.Debugger.Runtime.Term.Cache where++import GHC+import GHC.Types.Id+import GHC.Tc.Utils.TcType+import GHC.Runtime.Eval+import GHC.Types.Unique.Supply (uniqFromTag)+import GHC.Types.Var.Env++import GHC.Debugger.Runtime.Term.Key++import Data.Map (Map)+import qualified Data.Map as M++--------------------------------------------------------------------------------+-- * Term Cache+--------------------------------------------------------------------------------++-- | A term cache maps Names to Terms.+--+-- We use the term cache to avoid redundant computation forcing (unique) names+-- we've already forced before.+--+-- A kind of trie map from 'TermKey's. The Map entry for no-path-fragments is+-- the 'Term' of the original 'Id'.+type TermCache = TermKeyMap Term++-- | Lookup a 'TermKey' in a 'TermCache'.+-- Returns @Nothing@ for a cache miss and @Just@ otherwise.+lookupTermCache :: TermKey -> TermCache -> Maybe Term+lookupTermCache = lookupTermKeyMap++-- | Inserts a 'Term' for the given 'TermKey' in the 'TermCache'.+--+-- Overwrites existing values.+insertTermCache :: TermKey -> Term -> TermCache -> TermCache+insertTermCache = insertTermKeyMap++--------------------------------------------------------------------------------+-- * TermKeyMap+--------------------------------------------------------------------------------++-- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.+type TermKeyMap a = IdEnv (Map [PathFragment] a)++-- | Lookup a 'TermKey' in a 'TermKeyMap'.+lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a+lookupTermKeyMap key tc = do+  let (i, path) = unconsTermKey key+  path_map <- lookupVarEnv tc i+  M.lookup path path_map++-- | Inserts a 'Term' for the given 'TermKey' in the 'TermKeyMap'.+--+-- Overwrites existing values.+insertTermKeyMap :: TermKey -> a -> TermKeyMap a -> TermKeyMap a+insertTermKeyMap key term tc =+  let+    (i, path) = unconsTermKey key+    new_map = case lookupVarEnv tc i of+      Nothing           -> M.singleton path term+      Just existing_map -> M.insert path term existing_map+  in extendVarEnv tc i new_map

@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs, ViewPatterns #-}+module GHC.Debugger.Runtime.Term.Key where++import Prelude hiding ((<>))++import GHC+import GHC.Utils.Outputable+import GHC.Types.Id+import GHC.Tc.Utils.TcType+import GHC.Runtime.Eval+import GHC.Types.Unique.Supply (uniqFromTag)+import GHC.Types.Name.Env++-- | A 'TermKey' serves to fetch a Term in a Debugger session.+-- Note: A 'TermKey' is only valid in the stopped context it was created in.+data TermKey where+  -- | Obtain a term from an Id.+  FromId :: Id -> TermKey++  -- | Append a PathFragment to the current Term Key. Used to construct keys+  -- for indexed and labeled fields.+  FromPath :: TermKey -> PathFragment -> TermKey++-- | A term may be identified by an 'Id' (such as a local variable) plus a list+-- of 'PathFragment's to an arbitrarily nested field.+data PathFragment+  -- | A positional index is an index from 1 to inf+  = PositionalIndex Int+  -- | A labeled field indexes a datacon fields by name+  | LabeledField Name+  deriving (Eq, Ord)++instance Outputable TermKey where+  ppr (FromId i)          = ppr i+  ppr (FromPath _ last_p) = ppr last_p++instance Outputable PathFragment where+  ppr (PositionalIndex i) = text "_" <> ppr i+  ppr (LabeledField n)    = ppr n++-- | >>> unconsTermKey (FromPath (FromPath (FromId hi) (Pos 1)) (Pos 2))+-- (hi, [1, 2])+unconsTermKey :: TermKey -> (Id, [PathFragment])+unconsTermKey = go [] where+  go acc (FromId i) = (i, reverse acc)+  go acc (FromPath k p) = go (p:acc) k

@@ -0,0 +1,270 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+   TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Stopped where++import Data.IORef+import Control.Monad.Reader+import Control.Monad.IO.Class++import GHC+import GHC.Types.Unique.FM+#if MIN_VERSION_ghc(9,13,20250417)+import GHC.Types.Name.Occurrence (sizeOccEnv)+#endif+import GHC.Types.Name.Reader+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails+import GHC.Types.TypeEnv+import GHC.Data.Maybe (expectJust)+import GHC.Driver.Env as GHC+import GHC.Runtime.Debugger.Breakpoints as GHC+import GHC.Runtime.Eval+import GHC.Types.SrcLoc+import qualified GHC.Runtime.Heap.Inspect as GHCI+import qualified GHC.Unit.Home.Graph as HUG++import GHC.Debugger.Stopped.Variables+import GHC.Debugger.Runtime+import GHC.Debugger.Runtime.Term.Cache+import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Utils++{-+Note [Don't crash if not stopped]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Requests such as `stacktrace`, `scopes`, or `variables` may end up+coming after the execution of a program has terminated. For instance,+consider this interleaving:++1. SENT Stopped event         <-- we're stopped+2. RECEIVED StackTrace req    <-- client issues after stopped event+3. RECEIVED Next req          <-- user clicks step-next+4. <program execution resumes and fails>+5. SENT Terminate event       <-- execution failed and we report it to exit cleanly+6. RECEIVED Scopes req        <-- happens as a sequence of 2 that wasn't canceled+7. <used to crash! because we're no longer at a breakpoint>++Now, we simply returned empty responses when these requests come in+while we're no longer at a breakpoint. The client will soon come to a halt+because of the termination event we sent.+-}++--------------------------------------------------------------------------------+-- * Stack trace+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getStacktrace :: Debugger [StackFrame]+getStacktrace = GHC.getResumeContext >>= \case+  [] ->+    -- See Note [Don't crash if not stopped]+    return []+  r:_+    | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)+    -> return+        [ StackFrame+          { name = GHC.resumeDecl r+          , sourceSpan = realSrcSpanToSourceSpan ss+          }+        ]+    | otherwise ->+        -- No resume span; which should mean we're stopped on an exception.+        -- No info for now.+        return []++--------------------------------------------------------------------------------+-- * Scopes+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getScopes :: Debugger [ScopeInfo]+getScopes = GHC.getCurrentBreakSpan >>= \case+  Nothing ->+    -- See Note [Don't crash if not stopped]+    return []+  Just span'+    | Just rss <- srcSpanToRealSrcSpan span'+    , let sourceSpan = realSrcSpanToSourceSpan rss+    -> do+      -- It is /very important/ to report a number of variables (numVars) for+      -- larger scopes. If we just say "Nothing", then all variables of all+      -- scopes will be fetched at every stopped event.+      curr_modl <- expectJust <$> getCurrentBreakModule+      in_mod <- getTopEnv curr_modl+      imported <- getTopImported curr_modl+      return+        [ ScopeInfo { kind = LocalVariablesScope+                    , expensive = False+                    , numVars = Nothing+                    , sourceSpan+                    }+        , ScopeInfo { kind = ModuleVariablesScope+                    , expensive = True+                    , numVars = Just (sizeUFM in_mod)+                    , sourceSpan+                    }+        , ScopeInfo { kind = GlobalVariablesScope+                    , expensive = True+#if MIN_VERSION_ghc(9,13,20250417)+                    , numVars = Just (sizeOccEnv imported)+#else+                    , numVars = Nothing+#endif+                    , sourceSpan+                    }+        ]+    | otherwise ->+      -- No resume span; which should mean we're stopped on an exception+      -- TODO: Use exception context to create source span, or at least+      -- return the source span null to have Scopes at least.+      return []++--------------------------------------------------------------------------------+-- * Variables+--------------------------------------------------------------------------------+-- Note [Variables Requests]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- We can receive a Variables request for three different reasons+--+-- 1. To get the variables in a certain scope+-- 2. To inspect the value of a lazy variable+-- 3. To expand the structure of a variable+--+-- The replies are, respectively:+--+-- (VARR)+-- (a) All the variables in the request scope+-- (b) ONLY the variable requested+-- (c) The fields of the variable requested but NOT the original variable++-- | Get variables using a variable/variables reference+--+-- If the Variable Request ends up being case (VARR)(b), then we signal the+-- request forced the variable and return @Left varInfo@. Otherwise, @Right vis@.+--+-- See Note [Variables Requests]+getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])+getVariables vk = do+  hsc_env <- getSession+  GHC.getResumeContext >>= \case+    [] ->+      -- See Note [Don't crash if not stopped]+      return (Right [])+    r:_ -> case vk of++      -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)+      -- (VARR)(b,c)+      SpecificVariable i -> do+        lookupVarByReference i >>= \case+          Nothing -> do+            -- lookupVarByReference failed.+            -- This may happen if, in a race, we change scope while asking for+            -- variables of the previous scope.+            -- Somewhat similar to the race in Note [Don't crash if not stopped]+            return (Right [])+          Just key -> do+            term <- obtainTerm key++            case term of++              -- (VARR)(b)+              Suspension{} -> do++                -- Original Term was a suspension:+                -- It is a "lazy" DAP variable: our reply can ONLY include+                -- this single variable.++                let ty = GHCI.termType term+                term' <- if isBoringTy ty+                            then deepseqTerm term -- deepseq boring types like String, because it is more helpful to print them whole than their structure.+                            else seqTerm term+                -- update cache with the forced term right away instead of invalidating it.+                -- TODO: is this the best place to have this update? what's the better abstraction?+                asks termCache >>= \r -> liftIO $ modifyIORef' r (insertTermCache key term')+                vi <- termToVarInfo key term'++                return (Left vi)++              -- (VARR)(c)+              _ -> Right <$> do++                -- Original Term was already something other than a Suspension;+                -- Meaning the @SpecificVariable@ request means to inspect the structure.+                -- Return ONLY the fields++                termVarFields key term >>= \case+                  NoFields -> return []+                  LabeledFields xs -> return xs+                  IndexedFields xs -> return xs+++      -- (VARR)(a) from here onwards++      LocalVariables -> fmap Right $+        -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)+        mapM tyThingToVarInfo =<< GHC.getBindings++      ModuleVariables -> Right <$> do+        case ibi_tick_mod <$> GHC.resumeBreakpointId r of+          Nothing -> return []+          Just curr_modl -> do+            things <- typeEnvElts <$> getTopEnv curr_modl+            mapM (\tt -> do+              nameStr <- display (getName tt)+              vi <- tyThingToVarInfo tt+              return vi{varName = nameStr}) things++      GlobalVariables -> Right <$> do+        case ibi_tick_mod <$> GHC.resumeBreakpointId r of+          Nothing -> return []+          Just curr_modl -> do+            names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl+            mapM (\n-> do+              nameStr <- display n+              liftIO (GHC.lookupType hsc_env n) >>= \case+                Nothing ->+                  return VarInfo+                    { varName = nameStr+                    , varType = ""+                    , varValue = ""+                    , isThunk = False+                    , varRef = NoVariables+                    }+                Just tt -> do+                  vi <- tyThingToVarInfo tt+                  return vi{varName = nameStr}+              ) names++      NoVariables -> Right <$> do+        return []++--------------------------------------------------------------------------------+-- Inspect+--------------------------------------------------------------------------------++-- | All top-level things from a module, including unexported ones.+getTopEnv :: Module -> Debugger TypeEnv+getTopEnv modl = do+  hsc_env <- getSession+  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case+    Nothing -> return emptyTypeEnv+    Just HomeModInfo+      { hm_details = ModDetails+        { md_types = things+        }+      } -> return things++-- | All bindings imported at a given module+getTopImported :: Module -> Debugger GlobalRdrEnv+getTopImported modl = do+  hsc_env <- getSession+  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case+    Nothing -> return emptyGlobalRdrEnv+#if MIN_VERSION_ghc(9,13,20250417)+    Just hmi -> mkTopLevImportedEnv hsc_env hmi+#else+    Just hmi -> return emptyGlobalRdrEnv+#endif+

@@ -0,0 +1,119 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+   TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Stopped.Variables where++import Control.Monad++import GHC+import GHC.Types.FieldLabel+import GHC.Runtime.Eval+import GHC.Core.DataCon+import GHC.Types.Id as GHC+import qualified GHC.Runtime.Debugger as GHCD+import qualified GHC.Runtime.Heap.Inspect as GHCI++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Runtime+import GHC.Debugger.Runtime.Term.Key+import GHC.Debugger.Utils++-- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the+-- value of the thing (as in @True = :force@, @False = :print@)+tyThingToVarInfo :: TyThing -> Debugger VarInfo+tyThingToVarInfo = \case+  t@(AConLike c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+  t@(ATyCon c)   -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+  t@(ACoAxiom c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables+  AnId i -> do+    let key = FromId i+    term <- obtainTerm key+    termToVarInfo key term++-- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term'+termVarFields :: TermKey -> Term -> Debugger VarFields+termVarFields top_key top_term =++  -- Make 'VarInfo's for the first layer of subTerms only.+  case top_term of+      -- Boring types don't get subfields+      _ | isBoringTy (GHCI.termType top_term) ->+        return NoFields++      Term{dc=Right dc, subTerms=_{- don't use directly! go through @obtainTerm@ -}} -> do+        case dataConFieldLabels dc of+          -- Not a record type,+          -- Use indexed fields+          [] -> do+            let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConOrigArgTys dc)+            IndexedFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+          -- Is a record data con,+          -- Use field labels+          dataConFields -> do+            let keys = map (FromPath top_key . LabeledField . flSelector) dataConFields+            LabeledFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys+      NewtypeWrap{dc=Right dc, wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do+        case dataConFieldLabels dc of+          [] -> do+            let key = FromPath top_key (PositionalIndex 1)+            wvi <- obtainTerm key >>= termToVarInfo key+            return (IndexedFields [wvi])+          [fld] -> do+            let key = FromPath top_key (LabeledField (flSelector fld))+            wvi <- obtainTerm key >>= termToVarInfo key+            return (LabeledFields [wvi])+          _ -> error "unexpected number of Newtype fields: larger than 1"+      _ -> return NoFields+++-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds+termToVarInfo :: TermKey -> Term -> Debugger VarInfo+termToVarInfo key term = do+  -- Make a VarInfo for a term+  let+    isThunk+     | Suspension{} <- term = True+     | otherwise = False+    ty = GHCI.termType term++    -- We scrape the subterms to display as the var's value. The structure is+    -- displayed in the editor itself by expanding the variable sub-fields+    termHead t+      -- But show strings and lits in full+      | isBoringTy ty = t+      | otherwise     = case t of+         Term{}                    -> t{subTerms = []}+         NewtypeWrap{wrapped_term} -> t{wrapped_term = termHead wrapped_term}+         _                         -> t+  varName <- display key+  varType <- display ty+  varValue <- display =<< GHCD.showTerm (termHead term)+  -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)++  -- The VarReference allows user to expand variable structure and inspect its value.+  -- Here, we do not want to allow expanding a term that is fully evaluated.+  -- We only want to return @SpecificVariable@ (which allows expansion) for+  -- values with sub-fields or thunks.+  varRef <- do+    if GHCI.isFullyEvaluatedTerm term+       -- Even if it is already evaluated, we do want to display a+       -- structure as long if it is not a "boring type" (one that does not+       -- provide useful information from being expanded)+       -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)+       && (isBoringTy ty || not (hasDirectSubTerms term))+     then do+        return NoVariables+     else do+        ir <- getVarReference key+        return (SpecificVariable ir)++  return VarInfo{..}+  where+    hasDirectSubTerms = \case+      Suspension{}   -> False+      Prim{}         -> False+      NewtypeWrap{}  -> True+      RefWrap{}      -> True+      Term{subTerms} -> not $ null subTerms+

@@ -0,0 +1,35 @@+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,+   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,+   TypeApplications, ScopedTypeVariables, BangPatterns #-}+module GHC.Debugger.Utils where++import GHC+import GHC.Data.FastString+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Ppr as GHC+import GHC.Utils.Outputable as GHC++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages++--------------------------------------------------------------------------------+-- * GHC Utilities+--------------------------------------------------------------------------------++-- | Convert a GHC's src span into an interface one+realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan+realSrcSpanToSourceSpan ss = SourceSpan+  { file = unpackFS $ srcSpanFile ss+  , startLine = srcSpanStartLine ss+  , startCol = srcSpanStartCol ss+  , endLine = srcSpanEndLine ss+  , endCol = srcSpanEndCol ss+  }++-- | Display an Outputable value as a String+display :: Outputable a => a -> Debugger String+display x = do+  dflags <- getDynFlags+  return $ showSDoc dflags (ppr x)+{-# INLINE display #-}+