diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/ghc-debug-adapter/Development/Debug/Adapter/Init.hs b/ghc-debug-adapter/Development/Debug/Adapter/Init.hs --- a/ghc-debug-adapter/Development/Debug/Adapter/Init.hs +++ b/ghc-debug-adapter/Development/Debug/Adapter/Init.hs @@ -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..." diff --git a/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs b/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs --- a/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs +++ b/ghc-debug-adapter/Development/Debug/Adapter/Stopped.hs @@ -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 } diff --git a/ghc-debug-adapter/Main.hs b/ghc-debug-adapter/Main.hs --- a/ghc-debug-adapter/Main.hs +++ b/ghc-debug-adapter/Main.hs @@ -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 diff --git a/ghc-debugger.cabal b/ghc-debugger.cabal --- a/ghc-debugger.cabal +++ b/ghc-debugger.cabal @@ -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: diff --git a/ghc-debugger/GHC/Debugger.hs b/ghc-debugger/GHC/Debugger.hs --- a/ghc-debugger/GHC/Debugger.hs +++ b/ghc-debugger/GHC/Debugger.hs @@ -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. -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. - -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 #-} diff --git a/ghc-debugger/GHC/Debugger/Breakpoint.hs b/ghc-debugger/GHC/Debugger/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Breakpoint.hs @@ -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) diff --git a/ghc-debugger/GHC/Debugger/Evaluation.hs b/ghc-debugger/GHC/Debugger/Evaluation.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Evaluation.hs @@ -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 + diff --git a/ghc-debugger/GHC/Debugger/Interface/Messages.hs b/ghc-debugger/GHC/Debugger/Interface/Messages.hs --- a/ghc-debugger/GHC/Debugger/Interface/Messages.hs +++ b/ghc-debugger/GHC/Debugger/Interface/Messages.hs @@ -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. } diff --git a/ghc-debugger/GHC/Debugger/Monad.hs b/ghc-debugger/GHC/Debugger/Monad.hs --- a/ghc-debugger/GHC/Debugger/Monad.hs +++ b/ghc-debugger/GHC/Debugger/Monad.hs @@ -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. diff --git a/ghc-debugger/GHC/Debugger/Runtime.hs b/ghc-debugger/GHC/Debugger/Runtime.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Runtime.hs @@ -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 + + diff --git a/ghc-debugger/GHC/Debugger/Runtime/Term/Cache.hs b/ghc-debugger/GHC/Debugger/Runtime/Term/Cache.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Runtime/Term/Cache.hs @@ -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 diff --git a/ghc-debugger/GHC/Debugger/Runtime/Term/Key.hs b/ghc-debugger/GHC/Debugger/Runtime/Term/Key.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Runtime/Term/Key.hs @@ -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 diff --git a/ghc-debugger/GHC/Debugger/Stopped.hs b/ghc-debugger/GHC/Debugger/Stopped.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Stopped.hs @@ -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. +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. + +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 + diff --git a/ghc-debugger/GHC/Debugger/Stopped/Variables.hs b/ghc-debugger/GHC/Debugger/Stopped/Variables.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Stopped/Variables.hs @@ -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 + diff --git a/ghc-debugger/GHC/Debugger/Utils.hs b/ghc-debugger/GHC/Debugger/Utils.hs new file mode 100644 --- /dev/null +++ b/ghc-debugger/GHC/Debugger/Utils.hs @@ -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 #-} +