haskell-debugger 0.10.1.0 → 0.11.0.0

raw patch · 37 files changed

+2156/−533 lines, 37 filesdep +attoparsecdep +ghc-heapdep +tasty-expected-failuredep ~dapdep ~haskell-debugger-viewdep ~unixPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, ghc-heap, tasty-expected-failure

Dependency ranges changed: dap, haskell-debugger-view, unix

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs +2/−2
• haskell-debugger-view/src/GHC/Debugger/View/Class.hs +74/−13
• haskell-debugger-view/src/GHC/Debugger/View/Containers.hs +4/−4
• haskell-debugger-view/src/GHC/Debugger/View/Text.hs +2/−2
• haskell-debugger.cabal +26/−7
• haskell-debugger/GHC/Debugger.hs +3/−2
• haskell-debugger/GHC/Debugger/Evaluation.hs +0/−250
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +33/−5
• haskell-debugger/GHC/Debugger/Monad.hs +48/−8
• haskell-debugger/GHC/Debugger/Run.hs +264/−0
• haskell-debugger/GHC/Debugger/Runtime.hs +20/−34
• haskell-debugger/GHC/Debugger/Runtime/Compile.hs +65/−0
• haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs +35/−0
• haskell-debugger/GHC/Debugger/Runtime/Eval.hs +71/−0
• haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs +274/−0
• haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs +82/−0
• haskell-debugger/GHC/Debugger/Runtime/Instances.hs +34/−78
• haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +15/−14
• haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +0/−25
• haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs +396/−0
• haskell-debugger/GHC/Debugger/Runtime/Thread.hs +151/−0
• haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs +42/−0
• haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +199/−0
• haskell-debugger/GHC/Debugger/Session.hs +1/−2
• haskell-debugger/GHC/Debugger/Stopped.hs +138/−20
• haskell-debugger/GHC/Debugger/Stopped/Variables.hs +4/−13
• haskell-debugger/GHC/Debugger/Utils.hs +57/−1
• hdb/Development/Debug/Adapter/Breakpoints.hs +6/−6
• hdb/Development/Debug/Adapter/Evaluation.hs +4/−2
• hdb/Development/Debug/Adapter/Init.hs +18/−2
• hdb/Development/Debug/Adapter/Proxy.hs +9/−3
• hdb/Development/Debug/Adapter/Stopped.hs +30/−28
• hdb/Development/Debug/Interactive.hs +7/−5
• hdb/Main.hs +2/−2
• test/haskell/Main.hs +13/−4
• test/haskell/Test/DAP/RunInTerminal.hs +7/−1

@@ -1,5 +1,25 @@ # Revision history for haskell-debugger +## 0.11.0.0 -- 2026-01-05++* Introduce but don't yet expose infrastructure for debugging multi-threaded+  programs and constructing better callstacks.+* Introduce `RemoteExpr`: A DSL for evaluation on the remote process.+    * This allows us to cache remote expressions at a much greater granularity+      which improves performance and memory usage significantly in the long term.+* Improves logging to Debug Console+* Augment `haskell-debugger-version`, version `0.2.0.0` with+    * This release brings the `Program` DSL which allows the debuggee to be+      queried from a custom instance, making it possible to implement+      visualisations which rely on e.g. evaluatedness of a term.+        * See the `DebugView` instance for `[a]` for an example of a more+          complex instance.+    * `haskell-debugger-0.11.0.0` is only compatible with+      `haskell-debugger-view-0.2.0.0` and will abort if unsupported+      `haskell-debugger-view` versions are found in the dependencies closure+* Bump `dap` minimum version to `0.3.1`+* Various fixes and code improvements+ ## 0.10.1.0 -- 2025-11-21  * Fixes critical bug which prevented debugger from being used with non-boot

@@ -6,6 +6,6 @@ import qualified Data.ByteString    as BS  instance DebugView BS.ByteString where-  debugValue  t = VarValue (show t) False-  debugFields _ = VarFields []+  debugValue  t = simpleValue (show t) False+  debugFields _ = pure (VarFields []) 

@@ -20,7 +20,16 @@   , VarValue(..)   , VarFields(..)   , VarFieldValue(..)+  , simpleValue ++    -- * A 'Program' can describe a more complicated visualisation method which+    -- can query some information from the debugger.+  , Program(..)+  , isThunk+  , ifP++   -- * Utilities   --   -- | These can make it easier to write your own custom instances.@@ -63,17 +72,52 @@   --   -- This method should only be called to get the fields if the corresponding   -- @'VarValue'@ has @'varExpandable' = True@.-  debugFields :: a -> VarFields+  debugFields :: a -> Program VarFields +-- | The 'Program' abstraction allows more complicated 'DebugView' instances+-- to be constructed. The debugger will interpreter a 'Program' lazily when+-- determining how to display a variable.+--+-- At the moment the only interesting query when constructing a program is determining+-- if a value is already evaluated or not. This can be used to only display the evaluated+-- prefix of a list for example.+data Program a where+    -- | Lift a value to a program+    PureProgram :: a -> Program a+    -- | Program application+    ProgramAp :: Program (a -> b) -> Program a -> Program b+    -- | Evaluate the conditional, and branch on the result+    ProgramBranch :: Program Bool -> Program a -> Program a -> Program a+    -- | Is the value a thunk or evaluated?+    ProgramAskThunk :: a -> Program Bool++instance Functor Program where+   fmap f x = ProgramAp (PureProgram f) x++instance Applicative Program where+   pure = PureProgram+   fx <*> fy = ProgramAp fx fy++-- | Construct a 'VarValue' which doesn't require a 'Program'.+simpleValue :: String -> Bool -> VarValue+simpleValue s b = VarValue (pure s) b++-- | Construct a 'Program' which determines if 'a' is a thunk or not.+isThunk :: a -> Program Bool+isThunk = ProgramAskThunk++-- | Construct a program which branches+ifP :: Program Bool -> Program a -> Program a -> Program a+ifP = ProgramBranch+ -- | The representation of the value for some variable on the debugger data VarValue = VarValue   { -- | The value to display inline for this variable-    varValue      :: String+    varValue      :: Program String      -- | Can this variable further be expanded (s.t. @'debugFields'@ is not null?)   , varExpandable :: Bool   }-  deriving (Show, Read)  -- | The representation for fields of a value which is expandable in the debugger newtype VarFields = VarFields@@ -111,8 +155,8 @@ newtype BoringTy a = BoringTy a  instance Show a => DebugView (BoringTy a) where-  debugValue (BoringTy x) = VarValue (show x) False-  debugFields _           = VarFields []+  debugValue (BoringTy x) = simpleValue (show x) False+  debugFields _           = pure $ VarFields []  deriving via BoringTy Int     instance DebugView Int deriving via BoringTy Int8    instance DebugView Int8@@ -131,31 +175,48 @@ deriving via BoringTy String  instance DebugView String  instance DebugView (a, b) where-  debugValue _ = VarValue "( , )" True-  debugFields (x, y) = VarFields+  debugValue _ = simpleValue "( , )" True+  debugFields (x, y) = pure $ VarFields     [ ("fst", VarFieldValue x)     , ("snd", VarFieldValue y) ] +-- | This instance will display up to the first 50 forced elements of a list.+instance {-# OVERLAPPABLE #-} DebugView [a] where+  debugValue [] = simpleValue "[]" False+  debugValue (_:_) = simpleValue "[...]" True+  debugFields v = VarFields <$> go 0 v+    where+      go :: Int -> [a] -> Program [(String, VarFieldValue)]+      go 50 xs = pure [("tail", VarFieldValue xs)]+      go _ [] = pure []+      go n (x:xs) = ((show n, VarFieldValue x) :) <$>+                      (ifP (isThunk xs) (pure $ [("tail", VarFieldValue xs)])+                                        (go (n + 1) xs))+ -------------------------------------------------------------------------------- -- * (Internal) Wrappers required to call `evalStmt` on methods more easily --------------------------------------------------------------------------------  -- | Wrapper to make evaluating from debugger easier data VarValueIO = VarValueIO-  { varValueIO :: IO String+  { varValueIO :: Program (IO String)   , varExpandableIO :: Bool   }  debugValueIOWrapper :: DebugView a => a -> IO [VarValueIO] debugValueIOWrapper x = case debugValue x of   VarValue str b ->-    pure [VarValueIO (pure str) b]+    pure [VarValueIO (pure <$> str) b]  newtype VarFieldsIO = VarFieldsIO-  { varFieldsIO :: [(IO String, VarFieldValue)]+  { varFieldsIO :: Program [(IO String, VarFieldValue)]   }  debugFieldsIOWrapper :: DebugView a => a -> IO [VarFieldsIO]-debugFieldsIOWrapper x = case debugFields x of-  VarFields fls ->-    pure [VarFieldsIO [ (pure fl_s, b) | (fl_s, b) <- fls]]+debugFieldsIOWrapper x = pure [VarFieldsIO (toVarFieldsIO <$> (debugFields x))]++toVarFieldsIO :: VarFields -> [(IO String, VarFieldValue)]+toVarFieldsIO x =+  case x of+    VarFields fls -> [ (pure fl_s, b) | (fl_s, b) <- fls]+

@@ -7,15 +7,15 @@ import qualified Data.Map           as M  instance DebugView (IM.IntMap a) where-  debugValue _ = VarValue "IntMap" True-  debugFields im = VarFields+  debugValue _ = simpleValue "IntMap" True+  debugFields im = pure $ VarFields     [ (show k, VarFieldValue v)     | (k, v) <- IM.toList im     ]  instance Show k => DebugView (M.Map k a) where-  debugValue _ = VarValue "Map" True-  debugFields m = VarFields+  debugValue _ = simpleValue "Map" True+  debugFields m = pure $ VarFields     [ (show k, VarFieldValue v)     | (k, v) <- M.toList m     ]

@@ -6,6 +6,6 @@ import qualified Data.Text          as T  instance DebugView T.Text where-  debugValue  t = VarValue (show (T.unpack t)) False-  debugFields _ = VarFields []+  debugValue  t = simpleValue (show (T.unpack t)) False+  debugFields _ = pure $ VarFields [] 

@@ -1,6 +1,6 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.10.1.0+version:            0.11.0.0 synopsis:     A step-through debugger for GHC Haskell @@ -58,19 +58,33 @@     exposed-modules:  GHC.Debugger,                       GHC.Debugger.Breakpoint,                       GHC.Debugger.Breakpoint.Map,-                      GHC.Debugger.Evaluation,                       GHC.Debugger.Logger,+                      GHC.Debugger.Run,                       GHC.Debugger.Stopped,                       GHC.Debugger.Stopped.Variables,-                      GHC.Debugger.Utils,+                       GHC.Debugger.Runtime,++                      GHC.Debugger.Runtime.Eval,+                      GHC.Debugger.Runtime.Eval.RemoteExpr,+                      GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin,+                       GHC.Debugger.Runtime.Instances,                       GHC.Debugger.Runtime.Instances.Discover, +                      GHC.Debugger.Runtime.Compile,+                      GHC.Debugger.Runtime.Compile.Cache,++                      GHC.Debugger.Runtime.Term.Parser,                       GHC.Debugger.Runtime.Term.Key,                       GHC.Debugger.Runtime.Term.Cache, +                      GHC.Debugger.Runtime.Thread,+                      GHC.Debugger.Runtime.Thread.Stack,+                      GHC.Debugger.Runtime.Thread.Map,+                       GHC.Debugger.Monad,+                      GHC.Debugger.Utils,                        GHC.Debugger.Session,                       GHC.Debugger.Session.Builtin,@@ -81,12 +95,12 @@                       ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,                       ghc-boot-th >= 9.14 && < 9.16,                       ghc-boot >= 9.14 && < 9.16,+                      ghc-heap >= 9.14 && < 9.16,                       array >= 0.5.8 && < 0.6,                       containers >= 0.7 && < 0.9,                       mtl >= 2.3 && < 3,                       binary >= 0.8.9 && < 0.11,                       process >= 1.6.25 && < 1.7,-                      unix >= 2.8.6 && < 2.9,                       filepath >= 1.5.4 && < 1.6,                       directory >= 1.3.9.0 && < 1.4,                       exceptions >= 0.10.9 && < 0.11,@@ -96,14 +110,18 @@                       aeson >= 2.2.3 && < 2.3,                       hie-bios >= 0.15 && < 0.18,                       file-embed >= 0.0.16 && < 0.1,+                      attoparsec >= 0.13 && < 0.15,                       -- Logger dependencies                       time >= 1.14 && < 2,                       prettyprinter >= 1.7.1 && < 2,                       text >= 2.1 && < 2.3,                       co-log-core >= 0.3.2.5 && < 0.4, -                      haskell-debugger-view >= 0.1 && < 1.0+                      haskell-debugger-view >= 0.2 && < 1.0 +    if !os(windows)+        build-depends: unix >= 2.8.6 && < 2.9,+     hs-source-dirs:   haskell-debugger     default-language: GHC2021 @@ -136,7 +154,7 @@         base, ghc,         exceptions, aeson, bytestring,         containers, filepath,-        process, mtl, unix,+        process, mtl,         unordered-containers >= 0.2.19 && < 0.3,          haskell-debugger,@@ -152,7 +170,7 @@         network-run >= 0.4.4,         async >= 2.2.5 && < 2.3,         text >= 2.1 && < 2.3,-        dap >= 0.3 && < 1,+        dap >= 0.3.1 && < 0.4,          haskeline >= 0.8 && < 1,         optparse-applicative >= 0.18 && < 0.20@@ -186,6 +204,7 @@         tasty >= 1.5.3,         tasty-golden >= 2.3.5,         tasty-hunit >= 0.10.2,+        tasty-expected-failure >= 0.12.3,         regex >= 1.1     build-tool-depends: haskell-debugger:hdb     ghc-options: -threaded

@@ -7,7 +7,7 @@ import Control.Monad.IO.Class  import GHC.Debugger.Breakpoint-import GHC.Debugger.Evaluation+import GHC.Debugger.Run import GHC.Debugger.Stopped import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages@@ -26,7 +26,8 @@     DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition)   DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled   GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp-  GetStacktrace -> GotStacktrace <$> getStacktrace+  GetThreads -> GotThreads <$> getThreads+  GetStacktrace i -> GotStacktrace <$> getStacktrace i   GetScopes -> GotScopes <$> getScopes   GetVariables kind -> GotVariables <$> getVariables kind   DoEval exp_s -> DidEval <$> doEval exp_s

@@ -1,250 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-module GHC.Debugger.Evaluation where--import GHC.Utils.Outputable-import Control.Monad.IO.Class-import Control.Monad.Catch-import Control.Monad.Reader-import Data.IORef-import qualified Data.List as List-import Data.Maybe-import System.FilePath-import System.Directory-import qualified Prettyprinter as Pretty--import GHC-import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)-import GHC.Unit.Types-import GHC.Data.FastString-import GHC.Driver.DynFlags as GHC-import GHC.Driver.Monad as GHC-import GHC.Driver.Env as GHC-import GHC.Runtime.Debugger.Breakpoints as GHC-import qualified GHC.Unit.Module.ModSummary as GHC-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 qualified GHC.Data.Strict as Strict--import GHC.Debugger.Stopped.Variables-import GHC.Debugger.Monad-import GHC.Debugger.Utils-import GHC.Debugger.Interface.Messages-import GHC.Debugger.Logger as Logger-import qualified GHC.Debugger.Breakpoint.Map as BM--data EvalLog-  = LogEvalModule GHC.Module--instance Pretty EvalLog where-  pretty = \ case-    LogEvalModule modl -> "Eval Module Context:" Pretty.<+> pretty (GHC.showSDocUnsafe (ppr modl))------------------------------------------------------------------------------------- * Evaluation------------------------------------------------------------------------------------- | Run a program with debugging enabled-debugExecution :: Recorder (WithSeverity EvalLog) -> FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult-debugExecution recorder entryFile 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?-  modSummaryOfEntryFile <- findUnitIdOfEntryFile entryFile-  let modOfEntryFile = GHC.ms_mod modSummaryOfEntryFile-      unitIdOfEntryFile = GHC.ms_unitid modSummaryOfEntryFile--  let-    evalModule = mkModule (RealUnit (Definite unitIdOfEntryFile))-                                         (moduleName modOfEntryFile)--  logWith recorder Info $ LogEvalModule evalModule-  old_context <- GHC.getContext-  GHC.setContext [GHC.IIModule evalModule]--  (entryExp, exOpts) <- case entry of-    MainEntry nm -> do-      let prog = fromMaybe "main" nm-      -- the wrapper is equivalent to GHCi's `:main arg1 arg2 arg3`-      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)--  exec_res <- GHC.execStmt entryExp exOpts-  GHC.setContext old_context -- restore context after running `main`-  handleExecResult exec_res-  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-          )--    findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary-    findUnitIdOfEntryFile fp = do-      afp <- normalise <$> liftIO (makeAbsolute fp)-      modSums <- getAllLoadedModules-      let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location-      case List.find ((Just afp ==) . normalisedModLoc) modSums of-        Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums)-        Just summary -> pure summary---- | 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--doStepOut :: Debugger EvalResult-doStepOut = do-  leaveSuspendedState-  mb_span <- getCurrentBreakSpan-  case mb_span of-    Nothing ->-      GHC.resumeExec (GHC.StepOut Nothing) Nothing-        >>= handleExecResult-    Just loc -> do-      md <- fromMaybe (error "doStepOut") <$> getCurrentBreakModule-      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md-      let current_toplevel_decl = enclosingTickSpan ticks loc-      GHC.resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) 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---- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.------ We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.-continueToCompletion :: Debugger GHC.ExecResult-continueToCompletion = do-  execr <- GHC.resumeExec GHC.RunToCompletion Nothing-  case execr of-    GHC.ExecBreak{} -> continueToCompletion-    GHC.ExecComplete{} -> return execr---- | 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 "" "" NoVariables) -- Evaluation completed without binding any result.-        Right (n:_ns) -> inspectName n >>= \case-          Just VarInfo{varValue, varType, varRef} -> do-            return (EvalCompleted varValue varType varRef)-          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 = Just bid} -> do-      bm <- liftIO . readIORef =<< asks activeBreakpoints-      case BM.lookup bid bm of-        -- todo: BreakpointAfterCountCond is not handled yet.-        Just (BreakpointWhenCond cond, _) -> do-          let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..."-          let resume = GHC.resumeExec GHC.RunToCompletion Nothing >>= handleExecResult-          doEval cond >>= \case-            EvalStopped{} -> error "impossible for doEval"-            EvalCompleted { resultVal, resultType } ->-              if resultType == "Bool" then do-                if resultVal == "True" then-                  return EvalStopped{breakId = Just bid}-                else-                  resume-              else do-                logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"")-                resume-            EvalException { resultVal } -> do-              logSDoc Logger.Warning (evalFailedMsg resultVal)-              resume-            EvalAbortedWith e -> do-              logSDoc Logger.Warning (evalFailedMsg e)-              resume--        -- Unconditionally 'EvalStopped' in all other cases-        _ -> return EvalStopped{breakId = Just bid}---- | 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-

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- TODO: drop this and Show GHC.InternalBreakpointId... {-# LANGUAGE LambdaCase,              StandaloneDeriving,              OverloadedStrings,@@ -39,8 +40,11 @@   -- | Clear all function breakpoints   | ClearFunctionBreakpoints +  -- | Get all threads+  | GetThreads+   -- | Get the evaluation stacktrace until the current breakpoint.-  | GetStacktrace+  | GetStacktrace RemoteThreadId    -- | Get the list of available scopes at the current breakpoint   | GetScopes@@ -208,7 +212,8 @@   | DidContinue EvalResult   | DidStep EvalResult   | DidExec EvalResult-  | GotStacktrace [StackFrame]+  | GotThreads [DebuggeeThread]+  | GotStacktrace [DbgStackFrame]   | GotScopes [ScopeInfo]   | GotVariables (Either VarInfo [VarInfo])   | Aborted String@@ -234,6 +239,16 @@   | ManyBreaksFound [BreakFound]   deriving (Show) +-- | A reference to a remote thread by remote id+-- See 'getRemoteThreadId'.+newtype RemoteThreadId = RemoteThreadId+    { remoteThreadIntRef :: Int+    -- ^ The number identifier of the thread on the (remote) interpreter. To+    -- find the proper remote 'ThreadId' corresponding to this numeric+    -- identifier, lookup the 'remoteThreadIntRef' in the 'ThreadMap'+    }+    deriving (Show, Eq, Ord)+ data EvalResult   = EvalCompleted { resultVal :: String                   , resultType :: String@@ -243,13 +258,26 @@                   -- that the user can expand as a normal variable.                   }   | EvalException { resultVal :: String, resultType :: String }-  | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }+  | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId+                  -- ^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)?+                  , breakThread :: RemoteThreadId+                  -- ^ In which thread did we hit the breakpoint?+                  }   -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped.   | EvalAbortedWith String   deriving (Show) -data StackFrame-  = StackFrame+data DebuggeeThread+  = DebuggeeThread+    { tId :: !RemoteThreadId+    -- ^ An identifier for a thread on the (possibly remote) debuggee process+    , tName :: !(Maybe String)+    -- ^ Thread label, if there is one+    }+    deriving (Show)++data DbgStackFrame+  = DbgStackFrame     { name :: String     -- ^ Title of stack frame     , sourceSpan :: SourceSpan

@@ -18,9 +18,12 @@ import Data.Function import Data.IORef import Data.Maybe+import Data.Version (makeVersion, showVersion) import Prelude hiding (mod) import System.IO+#ifdef MIN_VERSION_unix import System.Posix.Signals+#endif import qualified Data.IntMap as IM import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty@@ -46,6 +49,7 @@ import GHC.Types.SourceText import GHC.Types.Unique.Supply as GHC import GHC.Unit.Module.Graph+import GHC.Unit.State import GHC.Unit.Module.ModSummary as GHC import GHC.Unit.Types import GHC.Utils.Logger as GHC@@ -58,7 +62,9 @@ import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session import GHC.Debugger.Session.Builtin+import GHC.Debugger.Runtime.Compile.Cache import qualified GHC.Debugger.Breakpoint.Map as BM+import qualified GHC.Debugger.Runtime.Thread.Map as TM  import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache) @@ -87,12 +93,15 @@       -- The TermKeyMap map is a reverse lookup map to find which references       -- already exist for given names -      , termCache         :: IORef TermCache-      -- ^ TermCache-       , rtinstancesCache :: IORef RuntimeInstancesCache       -- ^ RuntimeInstancesCache +      , threadMap         :: IORef TM.ThreadMap+      -- ^ 'ThreadMap' for threads spawned by the debuggee++      , compCache         :: IORef CompCache+      -- ^ Cache loaded and compiled expressions.+       , genUniq           :: IORef Int       -- ^ Generates unique ints @@ -164,8 +173,10 @@ runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do   let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'   GHC.runGhc (Just libdir) $ do+#ifdef MIN_VERSION_unix     -- Workaround #4162     _ <- liftIO $ installHandler sigINT Default Nothing+#endif     dflags0 <- GHC.getSessionDynFlags     let dflags1 = dflags0           { GHC.ghcMode = GHC.CompManager@@ -175,7 +186,9 @@           , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks           }           -- Default debugger settings+          `GHC.xopt_set` LangExt.TypeApplications           `GHC.xopt_set` LangExt.PackageImports+          `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile           `GHC.gopt_set` GHC.Opt_ImplicitImportQualified           `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges           `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges@@ -220,7 +233,7 @@      -- Setup base HomeUnitGraph     setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)-    -- Downsweep user-given modules first +    -- Downsweep user-given modules first     mod_graph_base <- doDownsweep Nothing      if_cache <- Just <$> liftIO newIfaceCache@@ -403,6 +416,8 @@ -- See also comment on the @'hsDbgViewUnitId'@ field of @'DebuggerState'@ findHsDebuggerViewUnitId :: ModuleGraph -> GHC.Ghc (Maybe UnitId) findHsDebuggerViewUnitId mod_graph = do+  hsc_env <- getSession+  let unitState = hsc_units hsc_env    -- Only looks at unit-nodes, this is not robust!   -- TODO: Better lookup of unit-id@@ -410,12 +425,26 @@         [ uid         | UnitNode _deps uid <- mg_mss mod_graph         , "haskell-debugger-view" `L.isPrefixOf` unitIdString uid+            || "hskll-dbggr-vw" `L.isPrefixOf` unitIdString uid         ] +      -- If the haskell-debugger-view is in the dependency graph, it must have+      -- one of the versions the debugger is known to support:+      supported_versions+        = [ makeVersion [0, 2, 0, 0] ]+   case hskl_dbgr_vws of-    [hdv_uid] ->+    [hdv_uid] -> do       -- In transitive closure, use that one.-      return (Just hdv_uid)+      -- Check that the version is exactly 0.2.0.0+      case lookupUnit unitState (RealUnit (Definite hdv_uid)) of+        Just unitInfo -> do+          let version = unitPackageVersion unitInfo+          if version `elem` supported_versions+            then return (Just hdv_uid)+            else throwM UnsupportedHsDbgViewVersion{supportedVersions=supported_versions, actualVersion=version}+        Nothing ->+          error "Could not find unit info for haskell-debugger-view"     [] -> do       return Nothing     _  ->@@ -480,8 +509,9 @@ initialDebuggerState l hsDbgViewUid =   DebuggerState <$> liftIO (newIORef BM.empty)                 <*> liftIO (newIORef mempty)-                <*> liftIO (newIORef mempty)                 <*> liftIO (newIORef emptyRuntimeInstancesCache)+                <*> liftIO (newIORef TM.emptyThreadMap)+                <*> liftIO (newIORef emptyCompCache)                 <*> liftIO (newIORef 0)                 <*> pure hsDbgViewUid                 <*> pure l@@ -490,12 +520,22 @@ liftGhc :: GHC.Ghc a -> Debugger a liftGhc = Debugger . ReaderT . const +--------------------------------------------------------------------------------+ data DebuggerFailedToLoad = DebuggerFailedToLoad instance Exception DebuggerFailedToLoad instance Show DebuggerFailedToLoad where   show DebuggerFailedToLoad = "Failed to compile and load user project." ---------------------------------------------------------------------------------+data UnsupportedHsDbgViewVersion = UnsupportedHsDbgViewVersion+  { supportedVersions :: [ Version ]+  , actualVersion :: Version+  }+instance Exception UnsupportedHsDbgViewVersion+instance Show UnsupportedHsDbgViewVersion where+  show (UnsupportedHsDbgViewVersion supported actual) =+    "Cannot use unsupported haskell-debugger-view version found in the transitive closure: " ++ showVersion actual +++    " (supported: " ++ L.intercalate ", " (map showVersion supported) ++ ")"  -------------------------------------------------------------------------------- -- * Modules

@@ -0,0 +1,264 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Debugger.Run where++import GHC.Utils.Outputable+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Reader+import Data.IORef+import qualified Data.List as List+import Data.Maybe+import System.FilePath+import System.Directory+import qualified Prettyprinter as Pretty++import GHC+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Driver.DynFlags as GHC+import GHC.Driver.Monad as GHC+import GHC.Driver.Env as GHC+import GHC.Runtime.Debugger.Breakpoints as GHC+import qualified GHC.Unit.Module.ModSummary as GHC+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 qualified GHC.Data.Strict as Strict++import GHC.Debugger.Stopped.Variables+import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Logger as Logger+import qualified GHC.Debugger.Breakpoint.Map as BM+import GHC.Debugger.Runtime.Thread++data EvalLog+  = LogEvalModule GHC.Module++instance Pretty EvalLog where+  pretty = \ case+    LogEvalModule modl -> "Eval Module Context:" Pretty.<+> pretty (GHC.showSDocUnsafe (ppr modl))++--------------------------------------------------------------------------------+-- * Evaluation+--------------------------------------------------------------------------------++-- | Run a program with debugging enabled+debugExecution :: Recorder (WithSeverity EvalLog) -> FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution recorder entryFile 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?+  modSummaryOfEntryFile <- findUnitIdOfEntryFile entryFile+  let modOfEntryFile = GHC.ms_mod modSummaryOfEntryFile+      unitIdOfEntryFile = GHC.ms_unitid modSummaryOfEntryFile++  let+    evalModule = mkModule (RealUnit (Definite unitIdOfEntryFile))+                                         (moduleName modOfEntryFile)++  logWith recorder Info $ LogEvalModule evalModule+  old_context <- GHC.getContext+  GHC.setContext [GHC.IIModule evalModule]++  (entryExp, exOpts) <- case entry of+    MainEntry nm -> do+      let prog = fromMaybe "main" nm+      -- the wrapper is equivalent to GHCi's `:main arg1 arg2 arg3`+      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)++  exec_res <- GHC.execStmt entryExp exOpts+  GHC.setContext old_context -- restore context after running `main`+  handleExecResult exec_res+  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+          )++    findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary+    findUnitIdOfEntryFile fp = do+      afp <- normalise <$> liftIO (makeAbsolute fp)+      modSums <- getAllLoadedModules+      let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location+      case List.find ((Just afp ==) . normalisedModLoc) modSums of+        Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums)+        Just summary -> pure summary++-- | 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++doStepOut :: Debugger EvalResult+doStepOut = do+  leaveSuspendedState+  mb_span <- getCurrentBreakSpan+  case mb_span of+    Nothing ->+      GHC.resumeExec (GHC.StepOut Nothing) Nothing+        >>= handleExecResult+    Just loc -> do+      md <- fromMaybe (error "doStepOut") <$> getCurrentBreakModule+      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md+      let current_toplevel_decl = enclosingTickSpan ticks loc+      GHC.resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) 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++-- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.+--+-- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.+continueToCompletion :: Debugger GHC.ExecResult+continueToCompletion = do+  execr <- GHC.resumeExec GHC.RunToCompletion Nothing+  case execr of+    GHC.ExecBreak{} -> continueToCompletion+    GHC.ExecComplete{} -> return execr++-- | 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 "" "" NoVariables) -- Evaluation completed without binding any result.+        Right (n:_ns) -> inspectName n >>= \case+          Just VarInfo{varValue, varType, varRef} -> do+            return (EvalCompleted varValue varType varRef)+          Nothing     -> liftIO $ fail "doEval failed"+    ExecBreak {breakNames = _, breakPointId = Nothing} -> do+      -- Stopped at an exception+      -- TODO: force the exception to display string with Backtrace?+      rt_id <- getRemoteThreadIdFromContext+      return EvalStopped{ breakId = Nothing+                        , breakThread = rt_id }+    ExecBreak {breakNames = _, breakPointId = Just bid} -> do+      bm <- liftIO . readIORef =<< asks activeBreakpoints+      case BM.lookup bid bm of+        -- todo: BreakpointAfterCountCond is not handled yet.+        Just (BreakpointWhenCond cond, _) -> do+          let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..."+          let resume = GHC.resumeExec GHC.RunToCompletion Nothing >>= handleExecResult+          doEval cond >>= \case+            EvalStopped{} -> error "impossible for doEval"+            EvalCompleted { resultVal, resultType } ->+              if resultType == "Bool" then do+                if resultVal == "True" then do+                  rt_id <- getRemoteThreadIdFromContext+                  return EvalStopped{ breakId = Just bid+                                    , breakThread = rt_id }+                else+                  resume+              else do+                logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"")+                resume+            EvalException { resultVal } -> do+              logSDoc Logger.Warning (evalFailedMsg resultVal)+              resume+            EvalAbortedWith e -> do+              logSDoc Logger.Warning (evalFailedMsg e)+              resume++        -- Unconditionally 'EvalStopped' in all other cases+        _ -> do+          rt_id <- getRemoteThreadIdFromContext+          return EvalStopped{ breakId = Just bid+                            , breakThread = rt_id }++-- | 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++getRemoteThreadIdFromContext :: Debugger RemoteThreadId+getRemoteThreadIdFromContext = do+  GHC.getResumeContext >>= \case+    resume1:_ ->+      getRemoteThreadIdFromRemoteContext $ GHC.resumeContext resume1+    _ -> error "No resumes but stopped?!?"

@@ -1,7 +1,6 @@ {-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns, TemplateHaskellQuotes #-} module GHC.Debugger.Runtime where -import Data.IORef import Control.Monad.Reader import qualified Data.List as L @@ -12,7 +11,6 @@ import GHC.Runtime.Heap.Inspect  import GHC.Debugger.Runtime.Term.Key-import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Monad  -- | Obtain the runtime 'Term' from a 'TermKey'.@@ -23,39 +21,27 @@ obtainTerm :: TermKey -> Debugger Term obtainTerm key = do   hsc_env <- getSession-  tc_ref  <- asks termCache-  tc      <- liftIO $ readIORef tc_ref-  case lookupTermCache key tc of-    -- cache miss: reconstruct, then store.-    Nothing ->-      let-        -- Recursively get terms until we hit the desired key.-        getTerm = \case-          FromId i -> GHC.obtainTermFromId defaultDepth False{-don't force-} i-          FromPath k pf -> do-            term <- obtainTerm k-            liftIO $ expandTerm hsc_env $ 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-                    Nothing -> error "Couldn't find labeled field in dataConFieldLabels"-              NewtypeWrap{wrapped_term} ->-                wrapped_term -- regardless of PathFragment-              RefWrap{wrapped_term} ->-                wrapped_term -- regardless of PathFragment-              _ -> error ("Unexpected term for the given TermKey because <term> should have been expanded before and we're getting a path fragment!\n" ++ showPprUnsafe (ppr key <+> ppr k <+> ppr pf))-          FromCustomTerm _key _name ctm -> do-            -- For custom terms return them straightaway.-            liftIO $ expandTerm hsc_env ctm-       in do-        term <- getTerm key-        liftIO $ modifyIORef tc_ref (insertTermCache key term)-        return term+   -- Recursively get terms until we hit the desired key.+  case key of+     FromId i -> GHC.obtainTermFromId defaultDepth False{-don't force-} i+     FromPath k pf -> do+       term <- obtainTerm k+       liftIO $ expandTerm hsc_env $ 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+               Nothing -> error "Couldn't find labeled field in dataConFieldLabels"+         NewtypeWrap{wrapped_term} ->+           wrapped_term -- regardless of PathFragment+         RefWrap{wrapped_term} ->+           wrapped_term -- regardless of PathFragment+         _ -> error ("Unexpected term for the given TermKey because <term> should have been expanded before and we're getting a path fragment!\n" ++ showPprUnsafe (ppr key <+> ppr k <+> ppr pf))+     FromCustomTerm _key _name ctm -> do+       -- For custom terms return them straightaway.+       liftIO $ expandTerm hsc_env ctm -    -- cache hit-    Just hit -> return hit  -- | Before returning a 'Term' we want to expand its heap representation up to the 'defaultDepth' --

@@ -0,0 +1,65 @@+-- | A interface to compiling and loading expressions/values/variables into the+-- debuggee runtime.+--+-- You should prefer this interface to the GHC's 'compileExprRemote' whenever+-- the loaded expression would benefit from being cached and re-used, to avoid+-- recompilation and loading.+--+-- Even better, you should **always prefer** to use the 'RemoteExpr' abstraction+-- for constructing and evaluating expressions on the remote debuggee process.+-- In it, there is finer grained caching and a good interface for constructing+-- (possibly complex) expressions.+module GHC.Debugger.Runtime.Compile+  ( compileVar+  , compileRaw+  )+  where++import Control.Monad.Reader+import Data.IORef+import GHC++import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Runtime.Compile.Cache+import GHC.Debugger.Logger as Logger++-- | Compile and load a fully qualified external variable, potentially applied+-- to a few type arguments (i.e. by specializing it). E.g. @"GHC.Base" "pure" ["IO"]+--+-- The loaded (specialized) expression is cached.+compileVar :: ModuleName -> String -> [String] -> Debugger ForeignHValue+compileVar mod_name var_name ty_args =+  let raw_expr =+        ("(" ++ moduleNameString mod_name+             ++ "." ++ var_name ++ ") "+             ++ unwords (map ('@':) ty_args))+   in compileRaw raw_expr++-- | Compile and load a raw expression string.+--+-- Note: it is easy to wrongly cache arbitrary compilation strings. You+-- shouldn't use 'copmileRaw' lightly since these arbitrary strings typically+-- are not very cacheable (there won't be many if any hits).+--+-- If you need an expression more complex than a single variable specialized at+-- a few types, or even then, you should just prefer to use @'RemoteExpr'@ to+-- describe and load that remote expression. 'RemoteExpr' will cache the+-- relevant bits (loading of external names) at the right granularity while not+-- caching, say, chains of function applications, which can be trivially+-- executed on the remote process in a single go without any compilation.+--+-- User beware!+compileRaw :: String -> Debugger ForeignHValue+compileRaw raw_expr = do+  compCacheRef <- asks compCache+  compCacheVal <- liftIO $ readIORef compCacheRef++  case lookupCompRaw raw_expr compCacheVal of+    Just fhv -> do+      logSDoc Logger.Debug (text "Cache hit! on" <+> text raw_expr)+      return fhv+    Nothing  -> do+      fhv <- compileExprRemote raw_expr+      liftIO $ modifyIORef' compCacheRef (insertCompRaw raw_expr fhv)+      return fhv

@@ -0,0 +1,35 @@+-- | A compilation cache which allows us to re-use an already loaded+-- expression/variable rather than recompiling it from scratch.+module GHC.Debugger.Runtime.Compile.Cache+  ( CompCache+  , insertCompRaw+  , lookupCompRaw+  , emptyCompCache+  ) where++import GHC++import qualified Data.Map as M++-- | Mapping from compile expressions (as strings) to their @ForeignHValue@s+newtype CompCache = CompCache (M.Map String ForeignHValue)++-- | Store the result of compiling and loading a raw expression string.+--+-- Note: it is easy to wrongly cache arbitrary compilation strings. You+-- shouldn't do this lightly since these arbitrary strings typically are not+-- very cacheable (there won't be many if any hits).+--+-- **Instead, one should always prefer to use @'RemoteExpr'@ to describe and load+-- remote expression, which will be implicitly cached but at a much finer+-- grained level.**+insertCompRaw :: String -> ForeignHValue -> CompCache -> CompCache+insertCompRaw s v (CompCache m) = CompCache (M.insert s v m)++-- | Look if the raw string value of an expression has already been compiled and loaded+lookupCompRaw :: String -> CompCache -> Maybe ForeignHValue+lookupCompRaw s (CompCache m) = M.lookup s m++-- | Nothing in it+emptyCompCache :: CompCache+emptyCompCache = CompCache M.empty

@@ -0,0 +1,71 @@+{-# LANGUAGE LambdaCase, DataKinds, TypeFamilies #-}++-- | Higher-level interface to evaluating things in the (possibly remote) debuggee process+module GHC.Debugger.Runtime.Eval+  ( evalExpr+  , handleSingStatus+  , BadEvalStatus(..)+  ) where++import GHC+import GHC.Runtime.Interpreter as Interp+import GHCi.RemoteTypes+import GHCi.Message+import Control.Exception+import GHC.Driver.Env+import GHC.Driver.Config+import Control.Monad.IO.Class++import GHC.Debugger.Utils+import GHC.Debugger.Monad+import GHC.Debugger.Logger as Logger++-- * Evaluating things on debuggee ---------------------------------------------++-- | Evaluate a raw 'EvalExpr' which represents a debuggee expression of type @IO [a]@+evalExpr :: EvalExpr ForeignHValue -> Debugger (Either BadEvalStatus [ForeignHValue])+evalExpr eval_expr = do+  logSDoc Logger.Debug (text "evalExpr:" <+> (text (show (mkUnit eval_expr))))+  hsc_env <- getSession+  let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone+  handleMultiStatus <$>+    liftIO (evalStmt (hscInterp hsc_env) eval_opts eval_expr)+  where+    mkUnit :: EvalExpr a -> EvalExpr ()+    mkUnit EvalThis{} = EvalThis ()+    mkUnit (EvalApp a b) = mkUnit a `EvalApp` mkUnit b++-- ** Handling evaluation results ----------------------------------------------++-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a single value+handleSingStatus :: Either BadEvalStatus [ForeignHValue] -> Either BadEvalStatus ForeignHValue+handleSingStatus status =+  case status of+    Right [sing]  -> Right sing+    Right []      -> Left EvalReturnedNoResults+    Right (_:_:_) -> Left EvalReturnedTooManyResults+    Left e -> Left e++-- | Handle the 'EvalStatus_' of an evaluation using 'EvalStepNone' which returns a list of values+handleMultiStatus :: EvalStatus_ [ForeignHValue] [HValueRef] -> Either BadEvalStatus [ForeignHValue]+handleMultiStatus status =+  case status of+    EvalComplete _ (EvalSuccess res) -> Right res+    EvalComplete _ (EvalException e) ->+      Left (EvalRaisedException (fromSerializableException e))+    EvalBreak {} ->+      --TODO: Could we accidentally hit this if we set a breakpoint regardless of whether EvalStep=None? perhaps.+      Left EvalHitUnexpectedBreakpoint++--------------------------------------------------------------------------------+-- * Exceptions+--------------------------------------------------------------------------------++data BadEvalStatus+  = EvalRaisedException SomeException+  | EvalHitUnexpectedBreakpoint+  | EvalReturnedNoResults+  | EvalReturnedTooManyResults+  deriving Show++instance Exception BadEvalStatus

@@ -0,0 +1,274 @@+{-# LANGUAGE LambdaCase, GADTs, DataKinds, MagicHash, StandaloneKindSignatures #-}+-- | A DSL for evaluating remote expressions on the (possibly) remote debuggee process+--+-- Meant to be imported qualified @as Remote@ for use with @QualifiedDo@.+--+-- @+-- import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr)+-- import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+-- @+module GHC.Debugger.Runtime.Eval.RemoteExpr+  (+  -- * Building remote expressions+    RemoteExpr+  , var, ref, untypedRef+  , lit, raw+  , app, appRef+  , withUnboxed+  , fmap, (<$>)+  , pure, return+  , (>>=), (>>)++  -- * Evaluating remote expressions+  , eval, evalIO, evalString, evalIOList, evalIOString+  ) where++import Prelude hiding (pure, return, (>>=), (>>), fmap, (<$>))+import qualified Prelude+import qualified Data.Kind as Kind+import Control.Monad.Except+import GHC.Exts+import GHC+import GHC.Driver.Env+import GHC.Runtime.Interpreter as Interp hiding (evalIO, evalString)+import qualified GHC.Runtime.Interpreter as Interp+import Control.Monad.Reader+import GHCi.RemoteTypes++import GHC.Debugger.Logger as Logger+import GHC.Debugger.Monad+import GHC.Debugger.Utils+import GHC.Debugger.Runtime.Eval as Raw+import GHC.Debugger.Runtime.Compile++--------------------------------------------------------------------------------+-- * Higher-level: eDSL for (possibly) remote evaluation on the debuggee+--------------------------------------------------------------------------------++-- | A remote expression to be evaluated on the debuggee process.+-- Note: the remote expression must have a boxed representation type.+type RemoteExpr :: forall l. TYPE (BoxedRep l) -> Kind.Type+data RemoteExpr t where++  -- | Parse, compile, and load a raw expression string onto the remote process.+  -- This is a low-level escape hatch; prefer using the other constructors.+  -- The loaded expression is cached by its string.+  RemRaw    :: String -> RemoteExpr a++  -- | A top-level or in-another-module name (aka external name) in the debuggee process.+  -- The list of strings is the list of (fully-qualified) types the expression+  -- should be applied to.+  RemVar    :: -- forall {l} (a :: TYPE (BoxedRep l))+             ModuleName -> String -> [String] -> RemoteExpr a++  -- | A reference to a value in the debuggee heap+  RemRef    :: forall {l} (a :: TYPE (BoxedRep l))+             . ForeignHValue -> RemoteExpr a++  -- | An Int literal (@Int@)+  RemInt    :: Int -> RemoteExpr Int++  -- | Apply a remote function to a remote argument to get a remote result+  --+  -- Note: the result type @b@ must have a BoxedRep!+  RemApp    :: forall {l} (a :: TYPE (BoxedRep l)) b+             . RemoteExpr (a -> b) -> RemoteExpr a -> RemoteExpr b++  -- | IO monadic bind on the remote process+  RemBindIO :: RemoteExpr (IO a) -> (RemoteExpr a -> RemoteExpr (IO b)) -> RemoteExpr (IO b)++-- | Apply a remote function to a remote argument to get a remote result+var :: -- forall {l} (a :: TYPE (BoxedRep l))+     ModuleName -> String -> [String] -> RemoteExpr a+var = RemVar++-- | A reference to a value in the debuggee heap+ref :: ForeignRef a -> RemoteExpr a+ref = RemRef . castForeignRef++-- | A reference to a value in the debuggee heap+untypedRef :: forall {l} (a :: TYPE (BoxedRep l))+            . ForeignHValue -> RemoteExpr a+untypedRef = RemRef++-- | A literal unboxed int+lit :: Int -> RemoteExpr Int+lit = RemInt++-- | A raw expression string to be parsed, compiled, and loaded onto the remote process+raw :: String -> RemoteExpr a+raw = RemRaw++-- | Apply a remote function to a remote argument to get a remote result+app :: forall {l} (a :: TYPE (BoxedRep l)) b+     . RemoteExpr (a -> b) -> RemoteExpr a -> RemoteExpr b+app = RemApp++-- | Apply a remote function to a remote 'ForeignRef' to get a remote result+appRef :: RemoteExpr (a -> b) -> ForeignRef a -> RemoteExpr b+appRef rf = RemApp rf . ref++-- | Apply a remote function after unboxing a remote int argument+-- (We need to unbox the Int on the debuggee side)+withUnboxed :: RemoteExpr Int -> (RemoteExpr (Int# -> b)) -> RemoteExpr b+withUnboxed i f = (RemRaw "\\f i -> case i of GHC.Exts.I# i# -> f i#")+                    `RemApp` f `RemApp` i++-- | IO fmap on the remote process+fmap :: (RemoteExpr a -> RemoteExpr b) -> (RemoteExpr (IO a) -> RemoteExpr (IO b))+fmap f io_x = io_x >>= \x -> pure (f x)++-- | IO fmap on the remote process+(<$>) :: (RemoteExpr a -> RemoteExpr b) -> (RemoteExpr (IO a) -> RemoteExpr (IO b))+(<$>) = fmap++-- | IO pure on the remote process+pure :: RemoteExpr a -> RemoteExpr (IO a)+pure = RemApp (var (mkModuleName "GHC.Base") "pure" ["IO"])++-- | IO return on the remote process+return :: RemoteExpr a -> RemoteExpr (IO a)+return = pure++-- | IO monadic bind on the remote process+(>>=) :: RemoteExpr (IO a) -> (RemoteExpr a -> RemoteExpr (IO b)) -> RemoteExpr (IO b)+(>>=) = RemBindIO++-- | IO monadic bind on the remote process+(>>) :: RemoteExpr (IO a) -> RemoteExpr (IO b) -> RemoteExpr (IO b)+(>>) ma mb = app (app andThen ma) mb+  where+    andThen :: RemoteExpr (IO a -> IO b -> IO b)+    andThen = var (mkModuleName "GHC.Base") ">>" ["IO"]++--------------------------------------------------------------------------------+-- * Evaluation of 'RemoteExprs' (higher level)+--------------------------------------------------------------------------------++-- | Evaluate a @a@ expression on the remote process and return the foreign+-- reference to the result.+eval :: RemoteExpr a -> Debugger (Either BadEvalStatus (ForeignRef a))+eval expr = evalIO (pure expr)++-- | Run an @IO a@ computation in the remote process and return the foreign+-- reference to the returned @a@+evalIO :: RemoteExpr (IO a) -> Debugger (Either BadEvalStatus (ForeignRef a))+evalIO expr = do+  r <- evalIOList (fmap singletonList expr)+  case r of+    Left e    -> Prelude.return (Left e)+    Right [x] -> Prelude.return (Right x)+    Right []  -> Prelude.return (Left EvalReturnedNoResults)+    Right _   -> Prelude.return (Left EvalReturnedTooManyResults)++-- | Evaluate a string expression on the remote process and return the string+-- to the debugger+evalString :: RemoteExpr String -> Debugger (Either BadEvalStatus String)+evalString expr = evalIOString (pure expr)++{- |+Evaluate a 'RemoteExpr' for a remote @IO [a]@ and return a list of+'ForeignHValue' with one element per returned @a@.++=== __Example__++@+Remote.evalIOList $ Remote.do+  clonedStack <- Remote.cloneThreadStack `Remote.appRef` threadIdRef+  frames      <- Remote.decodeStack      `Remote.app`    clonedStack+  return (Remote.ssc_stack `Remote.app` frames)+@+-}+evalIOList :: RemoteExpr (IO [a]) -> Debugger (Either BadEvalStatus [ForeignRef a])+evalIOList expr = runExceptT $ do+  lift $ logSDoc Logger.Debug (text "evalIOList" <+> text (show expr))++  res_fv <- debuggeeEval expr++  r <- lift $ Raw.evalExpr (EvalThis (castForeignRef res_fv))+  liftEither (map castForeignRef Prelude.<$> r)++-- | Execute an @IO String@ on the remote process and serialize the string back to the debugger.+evalIOString :: RemoteExpr (IO String) -> Debugger (Either BadEvalStatus String)+evalIOString expr = runExceptT $ do+  lift $ logSDoc Logger.Debug (text "evalIOString" <+> text (show expr))+  res_fv <- debuggeeEval expr+  hsc_env <- lift getSession+  liftIO (Interp.evalString (hscInterp hsc_env) (castForeignRef res_fv))++--------------------------------------------------------------------------------+-- ** Recursive evaluation of 'RemoteExpr' (lower-level)+--------------------------------------------------------------------------------++-- | Get the foreign reference to a heap value of type @a@ in the debuggee+-- process from the given remote expr.+--+-- The result can't be (@ForeignRef a@) because of levity polymorphism, so we+-- return the untyped foreign ref.+debuggeeEval :: RemoteExpr a -> ExceptT BadEvalStatus Debugger (ForeignRef a)+debuggeeEval expr = do+    eval_expr <- go (pure (singletonList expr))+    r <- lift $ handleSingStatus Prelude.<$> Raw.evalExpr eval_expr+    liftEither (castForeignRef Prelude.<$> r)+  where++    -- Construct the largest possible EvalExpr and then evaluate it all at once.+    -- When we find an IO action we execute it.+    go :: forall {l'} (a' :: TYPE (BoxedRep l'))+        . RemoteExpr a' -> ExceptT BadEvalStatus Debugger (EvalExpr ForeignHValue)+    go = \case+      RemRaw s -> do+        fhv <- lift $ compileRaw s+        Prelude.return (EvalThis fhv)+      RemVar mod_name var_name ty_args -> do+        fhv <- lift $ compileVar mod_name var_name ty_args+        Prelude.return (EvalThis fhv)+      RemRef r -> Prelude.return (EvalThis r)+      RemInt i ->+        -- todo: interpreter message for unboxed literals+        -- TODO: lookup in the cache if we loaded this int already.+        EvalThis Prelude.<$> lift (compileRaw (show i ++ ":: Int"))+      RemApp f arg -> do+        arg_e <- go arg+        f_e   <- go f+        Prelude.return (f_e `EvalApp` arg_e)+      RemBindIO iox k -> do++        expr_arg_io_fv <- go (fmapIO singletonListVar iox)++        e_arg_fv <- lift $ handleSingStatus Prelude.<$> Raw.evalExpr expr_arg_io_fv+        arg_fv   <- liftEither (castForeignRef Prelude.<$> e_arg_fv)+        go (k (ref arg_fv))++instance Show (RemoteExpr (a :: TYPE (BoxedRep l))) where+  show (RemRaw s) = "(" ++ s ++ ")"+  show (RemVar mod_name var_name ty_args) =+    "(" ++ moduleNameString mod_name ++ "." ++ var_name ++ ")"+        ++ (if null ty_args then "" else " ")+        ++ unwords (map ('@':) ty_args)+  show (RemRef _) = "<foreign ref>"+  show (RemInt i) = show i+  show (RemApp f arg) =+    "(" ++ show f ++ " " ++ show arg ++ ")"+  show (RemBindIO iox k) =+    let k_str = k (var (mkModuleName "Dummy") "dummy" [])+     in show iox ++ ">>= (\\dummy -> " ++ show k_str ++ ")"++--------------------------------------------------------------------------------+-- ** Builtins that are needed here too.++-- | Remote 'Data.List.singleton' (applied)+singletonList :: RemoteExpr a -> RemoteExpr [a]+singletonList = app singletonListVar++-- | Remote 'Data.List.singleton'+singletonListVar :: RemoteExpr (a -> [a])+singletonListVar = var (mkModuleName "Data.List") "singleton" []++-- | Remote 'fmap' for IO. Only works with @RemoteExpr (a -> b)@, not+-- @RemoteExpr a -> RemoteExpr b@ (unlike 'fmap').+--+-- We need it to avoid defining the evaluator for @RemBindIO@ in terms of+-- itself.+fmapIO :: RemoteExpr (a -> b) -> RemoteExpr (IO a) -> RemoteExpr (IO b)+fmapIO = app . app (var (mkModuleName "Data.Functor") "fmap" ["IO"])

@@ -0,0 +1,82 @@+{-# LANGUAGE MagicHash #-}++-- | A module providing various remote external variables which are available+-- by default in any session.+--+-- A good way to check whether some function or variable can be added here is+-- if you can successfully ask for the type of its fully qualified name on @ghci@+-- (e.g. @:t Data.List.singleton@)+--+-- Meant to be imported qualified @as Remote@:+-- @+-- import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr)+-- import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+-- import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote+-- @+module GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin where++import GHC.Exts+import Data.Word+import Foreign.C.String+import GHC.Conc.Sync+import GHC.Unit.Module+import GHC.Stack.CloneStack+import GHC.Exts.Heap+import GHC.Exts.Heap.Closures+import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr)+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote++-- | Remote 'GHC.Stack.CloneStack.cloneThreadStack'+cloneThreadStack :: RemoteExpr ThreadId -> RemoteExpr (IO StackSnapshot)+cloneThreadStack = Remote.app $ Remote.var (mkModuleName "GHC.Stack.CloneStack") "cloneThreadStack" []++-- | Remote 'GHC.Stack.CloneStack.decode'+decode :: RemoteExpr StackSnapshot -> RemoteExpr (IO [StackEntry])+decode = Remote.app $ Remote.var (mkModuleName "GHC.Stack.CloneStack") "decode" []++-- | Remote 'GHC.Exts.Stack.decodeStack'+decodeStack :: RemoteExpr StackSnapshot -> RemoteExpr (IO StgStackClosure)+decodeStack = Remote.app $ Remote.var (mkModuleName "GHC.Exts.Stack") "decodeStack" []++-- | Remote 'GHC.Exts.Heap.Closures.ssc_stack'+ssc_stack :: RemoteExpr StgStackClosure -> RemoteExpr [StackFrame]+ssc_stack = Remote.app $ Remote.var (mkModuleName "GHC.Exts.Heap.Closures") "ssc_stack" []++-- | Remote 'GHC.Exts.Heap.getClosureData'+getClosureData :: RemoteExpr StgStackClosure -> RemoteExpr (IO Closure)+getClosureData = Remote.app $ Remote.var (mkModuleName "GHC.Exts.Heap") "getClosureData" ["GHC.Exts.LiftedRep", "_"]++-- | Remote 'GHC.Conc.Sync.fromThreadId'+fromThreadId :: RemoteExpr ThreadId -> RemoteExpr Word64+fromThreadId = Remote.app $ Remote.var (mkModuleName "GHC.Conc.Sync") "fromThreadId" []++-- | Remote 'GHC.Conc.Sync.threadStatus'+threadStatus :: RemoteExpr ThreadId -> RemoteExpr (IO ThreadStatus)+threadStatus = Remote.app $ Remote.var (mkModuleName "GHC.Conc.Sync") "threadStatus" []++-- | Remote 'GHC.Conc.Sync.listThreads'+listThreads :: RemoteExpr (IO [ThreadId])+listThreads = Remote.var (mkModuleName "GHC.Conc.Sync") "listThreads" []++-- | Remote 'GHC.Conc.Sync.threadLabel'+threadLabel :: RemoteExpr ThreadId -> RemoteExpr (IO (Maybe String))+threadLabel = Remote.app $ Remote.var (mkModuleName "GHC.Conc.Sync") "threadLabel" []++-- | Remote 'Foreign.C.String.peekCString'+peekCString :: RemoteExpr CString -> RemoteExpr (IO String)+peekCString = Remote.app $ Remote.var (mkModuleName "Foreign.C.String") "peekCString" []++-- | Remote 'GHC.Base.indexAddrArray#'+indexAddrArray :: RemoteExpr ByteArray# -> RemoteExpr (Int# -> Ptr a)+indexAddrArray = Remote.app $+  Remote.raw "\\b i -> GHC.Ptr.Ptr (GHC.Base.indexAddrArray# b i)"++-- | Remote 'Data.Maybe.maybeToList'+maybeToList :: RemoteExpr (Maybe a) -> RemoteExpr [a]+maybeToList = Remote.app $ Remote.var (mkModuleName "Data.Maybe") "maybeToList" []++-- | Function composition on the remote process+compose :: RemoteExpr (b -> c) -> RemoteExpr (a -> b) -> RemoteExpr (a -> c)+f `compose` g = Remote.app (Remote.app composeVar f) g where+  composeVar :: RemoteExpr ((b -> c) -> (a -> b) -> (a -> c))+  composeVar = Remote.var (mkModuleName "GHC.Base") "." []

@@ -1,29 +1,29 @@-{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, OrPatterns #-} module GHC.Debugger.Runtime.Instances where -import Control.Monad-import Control.Monad.Reader- import GHC import GHC.Driver.Env-import GHC.Plugins import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter as Interp+import GHC.Utils.Outputable+import Control.Monad.Reader  import GHC.Debugger.Monad-import GHC.Debugger.View.Class-+import GHC.Debugger.Logger as Logger import GHC.Debugger.Runtime.Instances.Discover+import GHC.Debugger.Runtime.Term.Parser +data VarValueResult = VarValueResult { varValueResult :: String, varValueResultExpandable :: Bool }+ -------------------------------------------------------------------------------- -- * High level interface for 'DebugView' on 'Term's --------------------------------------------------------------------------------  -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugValue' method if there is one.-debugValueTerm :: Term -> Debugger (Maybe VarValue)-debugValueTerm term = do+debugValueTerm :: Term -> Debugger (Maybe VarValueResult)+debugValueTerm term@(Suspension{} ; Term{}) = do   hsc_env <- getSession   let interp = hscInterp hsc_env   let ty = termType term@@ -38,33 +38,28 @@             return Nothing           Right transformed_v -> do -            liftIO (cvObtainTerm hsc_env maxBound True varValueIOTy transformed_v) >>= \case+            obtainParsedTerm "VarValue" maxBound True varValueIOTy transformed_v varValueParser >>= \case+              Left _ ->+                return Nothing+              Right (strTerm, valBool) -> do+                case strTerm of+                  (Suspension{} ; Term{}) -> do+                    valStr <- liftIO $+                      evalString interp (val strTerm {- whose type is IO String, from varValueIO -}) -              -- Get the Term of the VarValue to decode fields-              Term{ ty=_{-assert==VarValueIO-}-                  , subTerms=[strTerm, boolTerm]-                  } -> do+                    return $ Just VarValueResult+                      { varValueResult = valStr+                      , varValueResultExpandable = valBool+                      }+                  _ -> do+                    logSDoc Logger.Warning (text "debugValueTerm(2): Expecting" <+> ppr strTerm <+> text "to be a Term or Suspension.")+                    return Nothing+debugValueTerm term = do+  logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.")+  return Nothing -                valStr <- liftIO $-                  evalString interp (val strTerm {- whose type is IO String, from varValueIO -}) -                let valBool = case boolTerm of-                      Term{dc=Left "False"} -> False-                      Term{dc=Left "True"}  -> True-                      Term{dc=Right dc}-                        | falseDataCon == dc -> False-                      Term{dc=Right dc}-                        | trueDataCon == dc -> True-                      _ -> error "Decoding of VarValue failed" -                return $ Just VarValue-                  { varValue = valStr-                  , varExpandable = valBool-                  }-              _ ->-                -- Unexpected; the Term of VarValue should always be Term.-                return Nothing- -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugFields' method if there is one. --@@ -73,9 +68,7 @@ -- -- Returns @Nothing@ if no instance was found for the type of the given term debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)])-debugFieldsTerm term = do-  hsc_env <- getSession-  let interp = hscInterp hsc_env+debugFieldsTerm term@(Suspension{} ; Term{}) = do   let ty = termType term   mbInst <- getDebugViewInstance ty   case mbInst of@@ -88,46 +81,9 @@             return Nothing           Right transformed_v -> do -            liftIO (cvObtainTerm hsc_env 2 True varFieldsIOTy transformed_v) >>= \case--              -- Get the Term of the VarFieldsIO-              NewtypeWrap-                { wrapped_term=fieldsListTerm-                } -> do--                fieldsTerms <- listTermToTermsList fieldsListTerm--                -- Process each term for the instance fields-                Just <$> forM fieldsTerms \fieldTerm0 -> liftIO $ do-                  -- Expand @(IO String, VarFieldValue)@ tuple term for each field-                  seqTerm hsc_env fieldTerm0 >>= \case-                    Term{subTerms=[ioStrTerm, varFieldValTerm]} -> do--                      fieldStr <- evalString interp (val ioStrTerm)--                      -- Expand VarFieldValue term-                      seqTerm hsc_env varFieldValTerm >>= \case-                        Term{subTerms=[unexpandedValueTerm]} -> do-                          actualValueTerm <- liftIO $ do-                            let val_ty = termType unexpandedValueTerm-                            cvObtainTerm hsc_env defaultDepth False{-don't force-} val_ty (val unexpandedValueTerm)-                          return (fieldStr, actualValueTerm)--                        _ -> error "impossible; expected VarFieldValue"-                    _ -> error "impossible; expected 2-tuple term"-              _ -> error "debugFields instance returned something other than VarFields"---- | Convert a Term representing a list @[a]@ to a list of the terms of type--- @a@, where @a@ is the given @'Type'@ arg.------ PRE-CON: Term represents a @[a]@-listTermToTermsList :: Term -> Debugger [Term]-listTermToTermsList Term{subTerms=[head_term, tail_term]}-  = do-    hsc_env <- getSession-    -- Expand next term:-    tail_term' <- liftIO $-      seqTerm hsc_env tail_term-    (head_term:) <$> listTermToTermsList tail_term'-listTermToTermsList _ = pure []-+            obtainParsedTerm "VarFields" 2 True varFieldsIOTy transformed_v varFieldsParser >>= \case+              Left _ -> pure Nothing+              Right res -> pure (Just res)+debugFieldsTerm term = do+  logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.")+  return Nothing

@@ -7,6 +7,9 @@   , RuntimeInstancesCache   , getDebugViewInstance   , emptyRuntimeInstancesCache++  -- * Finding runtime instances utils+  , compileAndLoadMthd   ) where  import Data.IORef@@ -105,7 +108,7 @@   case mhdv_uid of     Just hdv_uid -> do       let modl = mkModule (RealUnit (Definite hdv_uid)) debuggerViewClassModName-      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr)+      let mthdRdrName mthStr = mkOrig modl (mkVarOcc mthStr) :: RdrName        (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ do @@ -119,16 +122,16 @@          -- Try to compile and load an expression for all methods of `DebugView`         -- applied to the dictionary for the given Type (`needle_ty`)-        let debugValueMN  = mthdRdrName "debugValueIOWrapper"-            debugFieldsMN = mthdRdrName "debugFieldsIOWrapper"+        let debugValueME  = nlHsVar $ mthdRdrName "debugValueIOWrapper"+            debugFieldsME = nlHsVar $ mthdRdrName "debugFieldsIOWrapper"             debugValueWrapperMT =               mkVisFunTyMany needle_ty $                 mkTyConApp ioTyCon [mkListTy varValueIOTy]             debugFieldsWrapperMT =               mkVisFunTyMany needle_ty $                 mkTyConApp ioTyCon [mkListTy varFieldsIOTy]-        !debugValue_fval  <- compileAndLoadMthd debugValueMN  debugValueWrapperMT-        !debugFields_fval <- compileAndLoadMthd debugFieldsMN debugFieldsWrapperMT+        !debugValue_fval  <- compileAndLoadMthd debugValueME  debugValueWrapperMT+        !debugFields_fval <- compileAndLoadMthd debugFieldsME debugFieldsWrapperMT          let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone             interp    = hscInterp hsc_env@@ -170,18 +173,16 @@  -- | Try to compile and load a class method for the given type. ----- E.g. @compileAndLoadMthd "debugValue" (<ty> -> VarValue)@ returns the--- foreign value for an expression @debugValue@ applied to the dictionary for--- the requested type.-compileAndLoadMthd :: RdrName -- ^ Name of method/name of function that takes dictionary-                   -> Type    -- ^ The final type of expr when funct is alredy applied to dict+-- E.g. @compileAndLoadMthd (nlHsVar "foo") <ty>@ returns the+-- foreign value for an expression @foo@ applied to the dictionary required to+-- produce the final requested type+compileAndLoadMthd :: LHsExpr GhcPs -- ^ Expr of method/expr that takes dictionary+                   -> Type         -- ^ The final type of expr when funct is alredy applied to dict                    -> TcM ForeignHValue-compileAndLoadMthd mthName mthTy = do+compileAndLoadMthd expr mthTy = do   hsc_env <- getTopEnv -  let expr = nlHsVar mthName--  -- Rn, Tc, desugar applied to DebugView dictionary+  -- Rn, Tc, desugar applied to dictionary   (expr', _)    <- rnExpr (unLoc expr)   (expr'', wcs) <- captureConstraints $ tcExpr expr' (Check mthTy)   ev            <- simplifyTop wcs

@@ -1,37 +1,12 @@ {-# LANGUAGE GADTs, DataKinds #-} module GHC.Debugger.Runtime.Term.Cache where -import GHC.Runtime.Eval 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

@@ -0,0 +1,396 @@+{-# LANGUAGE LambdaCase, BlockArguments, OrPatterns #-}+-- | This module contains the 'TermParser' abstraction, which provides utilities for+-- interpreting and parsing 'Term's+module GHC.Debugger.Runtime.Term.Parser where++import Data.Functor+import Control.Applicative+import Control.Monad++import GHC+import GHC.Driver.Env+import GHC.Core.DataCon (dataConName)+import GHC.Plugins (falseDataCon, trueDataCon, splitFunTy, boolTy)+import GHC.Runtime.Eval+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter as Interp+import GHC.Types.Name (nameOccName)+import GHC.Types.Name.Occurrence (occNameString)+import qualified GHC.Debugger.Logger as Logger+import GHC.Utils.Outputable (text, (<+>), ppr)+import Control.Monad.Reader+import GHC.Core.TyCo.Compare+import GHC.Stack++import GHC.Debugger.Monad+import GHC.Debugger.Utils (expectRight)++import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import qualified GHC.Debugger.Runtime.Compile as Comp++-- | The main entry point for running the 'TermParser'.+obtainParsedTerm+  :: String+  -> Int+  -> Bool+  -> Type+  -> ForeignHValue+  -> TermParser a+  -> Debugger (Either [TermParseError] a)+obtainParsedTerm label depth force ty fhv term_parser = do+  hsc_env <- getSession+  term <- liftIO $ cvObtainTerm hsc_env depth force ty fhv+  runTermParserLogged label (checkType ty *> term_parser) term+++--------------------------------------------------------------------------------+-- * Term parser abstraction+--------------------------------------------------------------------------------++data TermParseError = TermParseError { getTermErrorMessage :: String }+  deriving (Eq, Show)++newtype TermParser a = TermParser { runTermParser :: Term -> Debugger (Either [TermParseError] a) }++liftDebugger :: Debugger a -> TermParser a+liftDebugger action = TermParser $ \_ -> Right <$> action++instance MonadIO TermParser where+  liftIO action = TermParser $ \_ -> Right <$> liftIO action++instance Functor TermParser where+  fmap f (TermParser p) = TermParser $ \term -> fmap (fmap f) (p term)++instance Applicative TermParser where+  pure x = TermParser $ \_ -> pure (Right x)+  TermParser pf <*> TermParser pa = TermParser $ \term -> do+    ef <- pf term+    case ef of+      Left err -> pure (Left err)+      Right f -> fmap (fmap f) (pa term)++instance Monad TermParser where+  TermParser pa >>= f = TermParser $ \term -> do+    ea <- pa term+    case ea of+      Left err -> pure (Left err)+      Right a -> runTermParser (f a) term++instance Alternative TermParser where+  empty = parseError (TermParseError "TermParser.empty")+  TermParser p1 <|> TermParser p2 = TermParser $ \term -> do+    res <- p1 term+    case res of+      Left e1 -> attachErrors e1 $ p2 term+      success -> pure success++instance MonadFail TermParser where+  fail s = parseError . TermParseError $ s++attachErrors :: [TermParseError] -> Debugger (Either [TermParseError] a)+                                 -> Debugger (Either [TermParseError] a)+attachErrors errs term_parser = do+  pres <- term_parser+  case pres of+    Left new_errs -> pure (Left $ errs ++ new_errs)+    Right res -> pure (Right res)++parseError :: TermParseError -> TermParser a+parseError err = TermParser $ \_ -> pure (Left [err])++termTag :: Term -> String+termTag Term{}         = "Term"+termTag Prim{}         = "Prim"+termTag Suspension{}   = "Suspension"+termTag NewtypeWrap{}  = "NewtypeWrap"+termTag RefWrap{}      = "RefWrap"++anyTerm :: TermParser Term+anyTerm = TermParser $ \term -> pure (Right term)++ensureTerm :: TermParser Term+ensureTerm = do+  t <- anyTerm+  case t of+    Term{} -> pure t+    other -> parseError (TermParseError $ "expected Term, got " <> termTag other)++checkType :: Type -> TermParser ()+checkType ty = do+  t <- anyTerm+  unless (termType t `eqType` ty) (parseError (TermParseError "ty mismatch"))++traceTerm :: TermParser ()+traceTerm = do+  t <- anyTerm+  liftDebugger $ logSDoc Logger.Debug (ppr t)++-- | Evaluate the currently focused term+seqTermP :: HasCallStack => TermParser a -> TermParser a+seqTermP term_parser = do+  t <- anyTerm+  hsc_env <- liftDebugger $ getSession+  focus (liftIO $ seqTerm hsc_env t)+        term_parser++-- | If a term is a suspension, make sure that it's a thunk and not just that we+-- reached the depth limit.+refreshTerm :: TermParser Term+refreshTerm = do+  t <- anyTerm+  case t of+    Suspension {} -> do+      t' <- foreignValueToTerm (ty t) (val t)+      return t'+    _ -> return t+++-- | Change the focus of the term parser onto the specified term.+focus :: TermParser Term -> TermParser a -> TermParser a+focus parse_term term_parser =+  parse_term >>= \t ->+    TermParser $ \_ -> runTermParser term_parser t++-- | Focus on a new subtree, after forcing it to WHNF.+focusSeq :: HasCallStack => TermParser Term -> TermParser a -> TermParser a+focusSeq parse_term term_parser = focus parse_term (seqTermP term_parser)++-- | Choose the nth subterm+subtermTerm :: Int -> TermParser Term+subtermTerm idx = do+  t <- anyTerm+  case t of+    Term{subTerms}+      | idx < length subTerms -> do+          liftDebugger $ logSDoc Logger.Debug (ppr subTerms)+          focus (pure (subTerms !! idx)) refreshTerm+      | otherwise -> parseError (TermParseError $ "missing subterm index " <> show idx)+    other -> parseError (TermParseError $ "expected Term with subterms, got " <> termTag other)++-- | Choose the nth subterm, force it to WHNF and run the supplied parser on it.+subtermWith :: Int -> TermParser a -> TermParser a+subtermWith idx term_parser = do+  focusSeq (subtermTerm idx) term_parser++matchOccNameTerm :: String -> a -> TermParser a+matchOccNameTerm occName result = do+  Term{dc} <- ensureTerm+  case dc of+    Left name | name == occName -> pure result+    _ -> empty++matchDataConTerm :: DataCon -> a -> TermParser a+matchDataConTerm dataCon result = do+  Term{dc} <- ensureTerm+  case dc of+    Right dc' | dc' == dataCon -> pure result+    _ -> empty++matchConstructorTerm :: String -> TermParser ()+matchConstructorTerm ctorName = do+  term <- anyTerm+  case term of+    t@Term{} | constructorName (dc t) == ctorName -> return ()+             | otherwise ->+                parseError (TermParseError ("expected: "+                                            ++ ctorName+                                            ++ " got: "+                                            ++ constructorName (dc t)))+    other ->+      parseError (TermParseError ("expected Program term, got " <> termTag other))++constructorName :: Either String DataCon -> String+constructorName = \case+  Left name -> name+  Right dataCon -> occNameString . nameOccName $ dataConName dataCon++newtypeWrapParser :: TermParser Term+newtypeWrapParser = do+  t <- anyTerm+  case t of+    NewtypeWrap{wrapped_term} -> pure wrapped_term+    other -> parseError (TermParseError $ "expected NewtypeWrap, got " <> termTag other)++-- | Parse a primitive value as a single word (Prim term)+primParser :: TermParser Word+primParser = do+  t <- anyTerm+  case t of+    Prim{valRaw=[w64_tid]} -> pure w64_tid+    other -> do+      parseError (TermParseError $ "expected a Prim term, got " <> termTag other)++-- | Is the current focus a suspension?+isSuspension :: TermParser Bool+isSuspension = focus refreshTerm $ do+  t <- anyTerm+  traceTerm+  case t of+    Suspension{} -> pure True+    other -> do+      liftDebugger $ logSDoc Logger.Debug (text $ termTag other)+      return False++-- | Obtain a Term from a ForeignHValue+foreignValueToTerm :: Type -> ForeignHValue -> TermParser Term+foreignValueToTerm ty fhv =+  liftDebugger $ do+    hsc_env <- getSession+    liftIO $ cvObtainTerm hsc_env 2 False ty fhv++--------------------------------------------------------------------------------+-- * Logging parsers+--------------------------------------------------------------------------------++logTermParserMsg :: String -> String -> Debugger ()+logTermParserMsg label msg =+  logSDoc Logger.Debug (text "[TermParser]" <+> text label <+> text msg)++runTermParserLogged+  :: String+  -> TermParser a+  -> Term+  -> Debugger (Either [TermParseError] a)+runTermParserLogged label term_parser term = do+  logTermParserMsg label "start"+  res <- runTermParser term_parser term+  case res of+    Left errs -> do+      logTermParserMsg label ("failed: " ++ unlines (map getTermErrorMessage errs))+      pure (Left errs)+    Right a -> do+      logTermParserMsg label "succeeded"+      pure (Right a)++--------------------------------------------------------------------------------+-- * Base parsers+--------------------------------------------------------------------------------++tuple2Of :: TermParser a -> TermParser b -> TermParser (a, b)+tuple2Of parserA parserB = (,) <$> subtermWith 0 parserA <*> subtermWith 1 parserB++boolParser :: TermParser Bool+boolParser =+  matchOccNameTerm "False" False+    <|> matchOccNameTerm "True" True+    <|> matchDataConTerm falseDataCon False+    <|> matchDataConTerm trueDataCon True+    <|> parseError (TermParseError "expected Bool term")++-- | Parse a list, given a parser for each element.+-- The whole list will be forced.+parseList :: TermParser a -> TermParser [a]+parseList item_parser =+        (matchConstructorTerm "[]" *> pure [])+    <|> (matchConstructorTerm ":" *> ((:) <$> subtermWith 0 item_parser <*> subtermWith 1 (parseList item_parser)))++-- | Parse an 'Int'+intParser :: TermParser Int+intParser = fromIntegral <$> wordParser++-- | Parse a 'Word'+wordParser :: TermParser Word+wordParser = subtermWith 0 primParser++-- | Parse a 'String' term+stringParser :: TermParser String+stringParser = do+  Term{val=string_fv} <- anyTerm+  liftDebugger $+    expectRight =<< Remote.evalString (Remote.untypedRef string_fv)++-- | Parse a 'Maybe' something+maybeParser :: TermParser a -> TermParser (Maybe a)+maybeParser just_p = do+  (matchConstructorTerm "Nothing" $> Nothing)+  <|> (matchConstructorTerm "Just" *> (Just <$> subtermWith 0 just_p))++--------------------------------------------------------------------------------+-- * VarValue+--------------------------------------------------------------------------------++-- | Parse a term which is a 'ValValue'+varValueParser :: TermParser (Term, Bool)+varValueParser =+  (,) <$> subtermWith 0 programTermParser <*> subtermWith 1 boolParser++--------------------------------------------------------------------------------+-- * VarFields+--------------------------------------------------------------------------------++-- | Parse a term which is a 'Program VarFields'+varFieldsParser :: TermParser [(String, Term)]+varFieldsParser =+  focusSeq newtypeWrapParser $+    -- Program [(IO String, VarFieldValue)]+    focusSeq programTermParser $+        -- [(IO String, VarFieldValue)]+        parseList parseFieldItem++  where+    -- Parses an item of type (IO String, VarFieldValue)+    parseFieldItem :: TermParser (String, Term)+    parseFieldItem = (,) <$> subtermWith 0 parseFieldLabel <*> subtermWith 1 varFieldValueParser++    parseFieldLabel :: TermParser String+    parseFieldLabel = do+      ioStrTerm <- anyTerm+      interp <- liftDebugger $ hscInterp <$> getSession+      case ioStrTerm of+        (Suspension{} ; Term{})+          -> liftIO $ evalString interp (val ioStrTerm)+        _ -> parseError (TermParseError "parseFieldLabel expected a val")++varFieldTupleParser :: TermParser (Term, Term)+varFieldTupleParser = tuple2Of anyTerm anyTerm++varFieldValueParser :: TermParser Term+varFieldValueParser = subtermTerm 0++--------------------------------------------------------------------------------+-- * Program Parser+--------------------------------------------------------------------------------++-- | Parses and evaluates a "Program" term.+programTermParser :: TermParser Term+programTermParser =+        programPureParser+    <|> programApParser+    <|> programBranchParser+    <|> programAskThunkParser+  where+    programPureParser = do+      matchConstructorTerm "PureProgram"+      subtermTerm 0++    programApParser = do+      matchConstructorTerm "ProgramAp"+      p1 <- subtermWith 0 programTermParser+      p2 <- subtermWith 1 programTermParser+      case (p1, p2) of+        ( (Suspension{} ; Term{}), (Suspension{} ; Term{}) ) -> do+          let (_, _arg_ty, res_ty) = splitFunTy (termType p1)+          res <- liftDebugger $+            expectRight =<< Remote.eval+              (Remote.untypedRef (val p1) `Remote.app` Remote.untypedRef (val p2))+          foreignValueToTerm res_ty res+        _ -> parseError (TermParseError "programApParser: expected two vals")++    programBranchParser = do+      matchConstructorTerm "ProgramBranch"+      cond <- subtermWith 0 (focusSeq programTermParser boolParser)+      if cond then do+            subtermWith 1 programTermParser+           else do+            subtermWith 2 programTermParser++    programAskThunkParser = do+      matchConstructorTerm "ProgramAskThunk"+      -- Get what we need to check THUNKiness for+      is_thunk <- focus (subtermTerm 1) isSuspension+      bool_fv <- liftDebugger $ reifyBool is_thunk+      foreignValueToTerm boolTy bool_fv++reifyBool :: Bool -> Debugger ForeignHValue+reifyBool b = Comp.compileRaw (show b ++ ":: Bool")+

@@ -0,0 +1,151 @@+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE OrPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- TODO+-- - [] Consider caching once and forall the expressions we dynamically compile and load in this module.+module GHC.Debugger.Runtime.Thread+  ( getRemoteThreadIdFromRemoteContext+  , getRemoteThreadId+  , getRemoteThreadsLabels+  , listAllLiveRemoteThreads+  ) where++import Data.Maybe+import Data.Functor+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.IORef+import GHC.Conc.Sync++import GHC.Builtin.Types+import GHC.Runtime.Heap.Inspect+import GHC.Utils.Outputable++import GHCi.Message+import GHCi.RemoteTypes++import GHC.Debugger.Utils+import GHC.Debugger.Logger as Logger+import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Runtime.Term.Parser+import GHC.Debugger.Runtime.Thread.Map++import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote++-- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak'+getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId+getRemoteThreadIdFromRemoteContext fctxt = do+  -- Get the ResumeContext term and fetch the resumeContextThreadId field+  parsed_threadid <- obtainParsedTerm "RemoteContext's ThreadId" 2 True anyTy (castForeignRef fctxt)+                        (subtermWith 2{-RemoteContext's ThreadId-} anyTerm)+  case parsed_threadid of+    Left errs -> do+      logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+      liftIO $ fail "Failed to parse remote ResumeContext's thread id"+    Right Term{val=threadIdVal} -> do+      getRemoteThreadId (castForeignRef threadIdVal)+    _ -> liftIO $ fail "Expected threadIdTerm to be a Term!"++getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId+getRemoteThreadId threadIdRef = do+  thread_id_fv <- expectRight =<< Remote.eval+    (Remote.fromThreadId (Remote.ref threadIdRef))++  parsed_int <-+    obtainParsedTerm "ThreadId's Int value" 2 True wordTy{-really, Word64, but we won't look at the type-} (castForeignRef thread_id_fv) intParser++  case parsed_int of+    Left errs -> do+      logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+      liftIO $ fail "Failed to parse remote thread id on fromThreadId result!"+    Right tid_int -> do++      tmap_ref <- asks threadMap+      -- unconditionally write to the map the foreign ref (it should always+      -- refer to the same ThreadId as a possible existing entry)+      liftIO $ modifyIORef' tmap_ref $+        insertThreadMap tid_int threadIdRef++      return (RemoteThreadId tid_int)++-- | Is the remote thread running or blocked (NOT finished NOR dead)?+getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus+getRemoteThreadStatus threadIdRef = do+  status_fv  <- expectRight =<< Remote.evalIO+    (Remote.threadStatus (Remote.ref threadIdRef))+  status_parsed <-+    obtainParsedTerm "ThreadStatus" 2 True anyTy{-..no..-} (castForeignRef status_fv) threadStatusParser++  case status_parsed of+    Left errs -> do+      logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+      liftIO $ fail "Failed to parse ThreadStatus"+    Right thrdStatus ->+      return thrdStatus++isRemoteThreadLive :: ForeignRef ThreadId -> Debugger Bool+isRemoteThreadLive r = getRemoteThreadStatus r <&> \case+  (ThreadRunning ; ThreadBlocked{}) -> True+  (ThreadDied    ; ThreadFinished)  -> False++-- | Call 'listThreads' on the (possibly) remote debuggee process to get the+-- list of threads running on the debuggee. Filter by running threads+-- This may include the debugger threads if using the internal interpreter.+listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ForeignRef ThreadId)]+listAllLiveRemoteThreads = do+  threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads+  catMaybes <$> do+    forM threads_fvs $ \(castForeignRef -> thread_fv) -> do+      isLive <- isRemoteThreadLive thread_fv+      if isLive then do+        tid <- getRemoteThreadId thread_fv+        pure $ Just (tid, thread_fv)+      else do+        pure Nothing++-- | Get the label of a Thread in a remote process. Returns one element per+-- given Thread with @Just string@ if a label was found.+getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String]+getRemoteThreadsLabels threadIdRefs = do++  forM threadIdRefs $ \threadIdRef -> do+    +    r <- Remote.evalIOList $ Remote.do+      mb_str <- Remote.threadLabel (Remote.ref threadIdRef)+      Remote.return (Remote.maybeToList mb_str)++    expectRight r >>= \case+      []          -> pure Nothing+      [io_lbl_fv] -> Just <$> (expectRight =<< Remote.evalString (Remote.ref io_lbl_fv))+      _ -> liftIO $ fail "Unexpected result from evaluating \"threadLabel\""++--------------------------------------------------------------------------------+-- * TermParsers+--------------------------------------------------------------------------------++-- ** Threads ------------------------------------------------------------------++threadStatusParser :: TermParser ThreadStatus+threadStatusParser = do+        (matchConstructorTerm "ThreadRunning"  $> ThreadRunning)+    <|> (matchConstructorTerm "ThreadFinished" $> ThreadFinished)+    <|> (matchConstructorTerm "ThreadDied"     $> ThreadDied)+    <|> (matchConstructorTerm "ThreadBlocked"  *> (ThreadBlocked <$> subtermWith 0 blockedReasonParser))++blockedReasonParser :: TermParser BlockReason+blockedReasonParser = do+        (matchConstructorTerm "BlockedOnMVar"        $> BlockedOnMVar)+    <|> (matchConstructorTerm "BlockedOnBlackHole"   $> BlockedOnBlackHole)+    <|> (matchConstructorTerm "BlockedOnException"   $> BlockedOnException)+    <|> (matchConstructorTerm "BlockedOnSTM"         $> BlockedOnSTM)+    <|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall)+    <|> (matchConstructorTerm "BlockedOnOther"       $> BlockedOnOther)+

@@ -0,0 +1,42 @@+-- | A map to track and manage the debuggee runtime threads+module GHC.Debugger.Runtime.Thread.Map+  ( ThreadMap+  , emptyThreadMap++  -- * Operations+  , insertThreadMap+  , lookupThreadMap++  , threadMapToList++  -- can we detect when a thread has died? what happens if we have a reference+  -- to a ThreadId which has been GC'd?+  ) where++import Control.Concurrent+import Data.Coerce++import GHCi.RemoteTypes+import qualified Data.IntMap as IM++-- | A thread map maintains a mapping between the int thread identifier, which+-- uniquely identifies a thread spawned by the debuggee, and the (possibly+-- remote) reference to the thread (i.e. the corresponding ThreadId)+type ThreadMap = IM.IntMap (ForeignRef ThreadId)++-- | Insert a remote 'ThreadId' at this unique Int thread identifier+insertThreadMap :: Int -> ForeignRef ThreadId -> ThreadMap -> ThreadMap+insertThreadMap = IM.insert++-- | Lookup a remote 'ThreadId' by its unique Int identifier+lookupThreadMap :: Int -> ThreadMap -> Maybe (ForeignRef ThreadId)+lookupThreadMap = IM.lookup++-- | > It's empty, what did you expect?+emptyThreadMap :: ThreadMap+emptyThreadMap = IM.empty++-- | Get all the remote thread references from the ThreadMap+threadMapToList :: ThreadMap -> [(Int, ForeignRef ThreadId)]+threadMapToList = coerce . IM.toList+

@@ -0,0 +1,199 @@+{-# LANGUAGE OrPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++-- | Decoding the stack of a thread at runtime+module GHC.Debugger.Runtime.Thread.Stack+  ( getRemoteThreadStackCopy+  , getRemoteThreadIPEStack+  ) where++import Data.Bits+import Data.Maybe+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import GHC.Stack.CloneStack+import GHC.Exts.Heap.ClosureTypes+import GHC.Utils.Encoding.UTF8++import GHC+import GHC.Builtin.Types+import GHC.Runtime.Heap.Inspect++import GHC.Driver.Env+import GHC.Runtime.Interpreter as Interp+import GHC.Utils.Outputable++import GHCi.Message+import GHCi.RemoteTypes++import GHC.Debugger.Utils+import GHC.Debugger.Logger as Logger+import GHC.Debugger.Monad+import GHC.Debugger.Runtime.Term.Parser+import GHC.Debugger.Runtime.Eval+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote++-- | Clone the stack of the given remote thread and get the breakpoint ids of available frames+getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [InternalBreakpointId]+getRemoteThreadStackCopy threadIdRef = do++  l <- Remote.evalIOList $ Remote.do+    clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)+    frames      <- Remote.decodeStack      clonedStack+    Remote.return (Remote.ssc_stack frames)++  case l of+    Left (EvalRaisedException e) -> do+      logSDoc Logger.Info (text "Failed to decode the stack with" <+> text (show e) $$ text "This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace will be returned...")+      return []+    Left e -> do+      logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")+      return []+    Right stack_frames_fvs -> fmap (catMaybes . catMaybes) $+      forM stack_frames_fvs $ \stack_frame_fv ->+        obtainParsedTerm "ghc-heap:StackFrame" 2 True anyTy{-todo:stackframety?-} (castForeignRef stack_frame_fv)+          ((Just <$> retBCOParser) <|> pure Nothing) >>= \case+            Left errs -> do+              logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+              return Nothing+            Right tm ->+              return tm++-- | Try to get an IPE stacktrace.+--+-- At the moment, we assume IPE stacktraces are always empty @[]@ for threads+-- with interpreter frames.+--+-- Really, as long as there is IPE information, this function should return+-- StackEntries for all frames, including the interpreter ones, since these are+-- typically be interleaved with "normal" frames.+--+getRemoteThreadIPEStack :: ForeignRef ThreadId -> Debugger [StackEntry]+getRemoteThreadIPEStack threadIdRef = do+  l <- Remote.evalIOList $ Remote.do+    clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)+    Remote.decode clonedStack+  case l of+    Left (EvalRaisedException e) -> do+      logSDoc Logger.Info (text "Failed to decode the stack with" <+> text (show e) $$ text "This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace could be produced...")+      return []+    Left e -> do+      logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")+      return []+    Right entries_fvs -> do+      mapM (\entry_fv -> do+          stack_entry <- obtainParsedTerm "StackEntry" 2 True anyTy{-stackentry, but we won't look at the ty...-} entry_fv stackEntryParser+          case stack_entry of+            Left errs -> do+              logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+              liftIO $ fail "Failed to parse @StackEntry@ from decoding thread stack!"+            Right se ->+              pure se+        ) (map castForeignRef entries_fvs)++--------------------------------------------------------------------------------+-- ** Decoding Stack Frames ----------------------------------------------------+--------------------------------------------------------------------------------++stackEntryParser :: TermParser StackEntry+stackEntryParser = do+    StackEntry <$> subtermWith 0 stringParser <*> subtermWith 1 stringParser <*> subtermWith 2 stringParser <*> pure INVALID_OBJECT{-this is a stub-}++retBCOParser :: TermParser (Maybe InternalBreakpointId)+retBCOParser = do+  -- Match against "RetBCO" frames and extract the BCOClosure information+  Suspension{val, ctype=BCO}+    {-"the otherwise case: Unknown closure", hence Suspension-}+      <- matchConstructorTerm "RetBCO" *> subtermWith 1 (subtermWith 0{-take from Box-} anyTerm)+  liftDebugger $ do++    -- Decode the BCO closure using 'getClosureData' on the foreign heap+    bco_closure_fv <- expectRight =<< Remote.evalIO+      (Remote.getClosureData (Remote.ref (castForeignRef val)))++    r <- obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId+    case r of+      Left err -> liftIO $ fail (show err)+      Right t  -> return t++-- | Parse an 'InternalBreakpointId' out of a 'BCOClosure' term.+bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId)+bcoInternalBreakpointId = do+  mbcpIxs <- bcoBreakPointInfoParser+  case mbcpIxs of+    Nothing -> return Nothing+    Just BCOBreakPointInfo{..} -> do+      mod_name <- bcoLiteralString info_mod_name_ix+      mod_id   <- bcoLiteralString info_mod_id_ix++      return $ Just $ evalBreakpointToId EvalBreakpoint+        { eb_info_mod      = mod_name+        , eb_info_mod_unit = utf8EncodeShortByteString mod_id+        , eb_info_index    = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo+        }++-- | Parse a literal 'String' from a BCO given a valid index into the literals array+bcoLiteralString :: Word -> TermParser String+bcoLiteralString ix = do+  Term{val=literals_fv} <- subtermWith 2 (subtermTerm 0{-Box's field-})+  liftDebugger $ do++    r <- Remote.evalIOString $+        Remote.peekCString $+          Remote.withUnboxed (Remote.lit (fromIntegral ix))+            (Remote.indexAddrArray (Remote.untypedRef literals_fv))++    expectRight r++-- | The indexes found in the BRK_FUN instruction+data BCOBreakPointInfo = BCOBreakPointInfo+  { brk_array_ix     :: !Word+  , info_mod_name_ix :: !Word+  , info_mod_id_ix   :: !Word+  , brk_info_ix_hi   :: !Word+  , brk_info_ix_lo   :: !Word+  }+  deriving Show++-- | Parses a 'BCOBreakPoint' if the current term is a 'BCOClosure' headed by a+-- BRK_FUN bytecode instruction.+-- Returns Nothing if the 'BCOClosure' instructions are headed by a BRK_FUN.+bcoBreakPointInfoParser :: TermParser (Maybe BCOBreakPointInfo)+bcoBreakPointInfoParser = do+  Term{val=instrs_array_fv} <- subtermWith 1{-instrs field-} (subtermTerm 0{-Box's field-})+  -- highly internals dependent...+  -- find the BCI at index 0. bci is word16. the first 8bits are for flags+  -- something something BCO_READ_LARGE_ARG with (index_at 0#) rather than always BCO_NEXT?+  liftDebugger $ do+    hsc_env <- getSession++    -- The BRK_FUN is the first instruction, unless BCO_NAME is enabled, in+    -- which case it's the second.+    let bRK_FUN_offset+          | gopt Opt_AddBcoName (hsc_dflags hsc_env) = 2 -- BCO_NAME + ptrs ix.+          | otherwise = 0 :: Int++    let find_ixs_fv = Remote.raw $+          "\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " ++ show bRK_FUN_offset ++ "#)) " +++                   "in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then \+                        Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#) \+                      else Nothing"+    rs_fv <- expectRight =<< Remote.eval+      (find_ixs_fv `Remote.app` Remote.untypedRef instrs_array_fv)++    mparsed_bco_brk <- obtainParsedTerm "Ixs" maxBound True anyTy rs_fv $+      maybeParser $ BCOBreakPointInfo <$>+        subtermWith 0 wordParser <*> subtermWith 1 wordParser <*> subtermWith 2 wordParser+                                 <*> subtermWith 3 wordParser <*> subtermWith 4 wordParser+    case mparsed_bco_brk of+      Left errs -> do+        logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))+        liftIO $ fail "Failed to parse BCOClosure's BRK_FUN"+      Right r -> return r

@@ -163,8 +163,7 @@   initial_home_graph <- createUnitEnvFromFlags dflags0 unitDflags   let home_units = unitEnv_keys initial_home_graph   init_home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do-    let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv-        dflags = homeUnitEnv_dflags homeUnitEnv+    let dflags = homeUnitEnv_dflags homeUnitEnv         old_hpt = homeUnitEnv_hpt homeUnitEnv     (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags Nothing home_units     updated_dflags <- GHC.updatePlatformConstants dflags mconstants

@@ -3,7 +3,10 @@    TypeApplications, ScopedTypeVariables, BangPatterns #-} module GHC.Debugger.Stopped where +import Control.Monad import Control.Monad.Reader+import Data.IORef+import GHC.Stack.CloneStack as Stack  import GHC import GHC.Types.Unique.FM@@ -13,18 +16,23 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Module.ModDetails import GHC.Types.TypeEnv-import GHC.Data.Maybe (expectJust)+import GHC.Data.Maybe import GHC.Driver.Env as GHC import GHC.Runtime.Debugger.Breakpoints as GHC import GHC.Runtime.Eval import GHC.Types.SrcLoc+import GHC.Utils.Outputable as Ppr import qualified GHC.Unit.Home.Graph as HUG  import GHC.Debugger.Stopped.Variables import GHC.Debugger.Runtime+import GHC.Debugger.Runtime.Thread+import GHC.Debugger.Runtime.Thread.Stack+import GHC.Debugger.Runtime.Thread.Map import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages import GHC.Debugger.Utils+import qualified GHC.Debugger.Logger as Logger  {- Note [Don't crash if not stopped]@@ -47,29 +55,139 @@ -}  ----------------------------------------------------------------------------------- * Stack trace+-- * Threads -------------------------------------------------------------------------------- --- | 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+getThreads :: Debugger [DebuggeeThread]+getThreads = do+  -- TODO: we want something more like 'listThreads', but ensure that we only+  -- report the threads of the debuggee (and not the debugger, if they+  -- are the same process). Perhaps the solution is to not allow them to be in+  -- the same process, in which case 'listThreads' would be correct as is by+  -- construction.+  --+  -- For now, we approximate by just listing out the ThreadsMap, under the+  -- assumption the debugger client will only care about threads we've already+  -- stopped at (which are the only ones we've inserted in the threads map),+  -- but for full multi threaded debugging we need the listThreads.+  --+  -- tmap <- liftIO . readIORef =<< asks threadMap+  -- let (t_ids, remote_refs) = unzip (threadMapToList tmap)+  --+  -- Oh, try the listThreads just for fun.+  (t_ids, remote_refs) <- unzip <$> listAllLiveRemoteThreads+  t_labels             <- getRemoteThreadsLabels remote_refs+  let+    _mkDebuggeeThread tid tlbl+      = DebuggeeThread+        { tId = tid+        , tName = tlbl+        }+    _all_threads+      = zipWith _mkDebuggeeThread t_ids t_labels++  -- TODO: We ignore _all_threads and report only the main execution thread for now.+  GHC.getResumeContext >>= \case+    [] ->+      -- See Note [Don't crash if not stopped]+      return []+    r:_ -> do+      r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)+      return+        [ DebuggeeThread+          { tId = r_tid+          , tName = Just "Main Thread"           }         ]-    | otherwise ->-        -- No resume span; which should mean we're stopped on an exception.-        -- No info for now.-        return []  --------------------------------------------------------------------------------+-- * Stack trace+--------------------------------------------------------------------------------++-- | Get the stack frames at the point we're stopped at+getStacktrace :: RemoteThreadId -> Debugger [DbgStackFrame]+getStacktrace req_tid = do++  tm <- liftIO . readIORef =<< asks threadMap+  let m_f_tid = lookupThreadMap (remoteThreadIntRef req_tid) tm+  ipe_stack <- case m_f_tid of+    Nothing -> pure []+    Just f_tid -> do+      -- For now, assume that if we can get an IPE backtrace then this thread+      -- is compiled and doesn't have any interpreter frames.+      -- Of course, this isn't true since we should also be able to get an IPE+      -- backtrace for interpreter threads. Just not yet.+      --+      -- If IPE is empty => it's not an interpreter thread => the IPE backtrace+      --  is the best we can do, so just return that.+      getRemoteThreadIPEStack f_tid++  case ipe_stack of+    [] -> do+      _decoded_frames <- case m_f_tid of+        Nothing -> pure []+        Just f_tid -> do+          hsc_env <- getSession+          ibis <- getRemoteThreadStackCopy f_tid+          let hug = hsc_HUG hsc_env+          forM ibis $ \ibi -> do+            info_brks <- liftIO $ readIModBreaks hug ibi+            let modl  = getBreakSourceMod ibi info_brks+            srcSpan   <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks++            -- Find function name+            -- TODO: Cache moduleLineMap?+            ticks <- fromMaybe (error "getStacktrace:getTicks") <$> makeModuleLineMap modl+            let current_toplevel_decl = enclosingTickSpan ticks srcSpan++            modl_str  <- display modl+            return DbgStackFrame+              { name = modl_str ++ "." -- ++ Stack.functionName stack_entry+              , sourceSpan = realSrcSpanToSourceSpan $ current_toplevel_decl -- realSrcSpan srcSpan+              }++      -- Try decoding a stack with interpreter continuation frames (RetBCOs) and use the BRK_FUN src locations.+      -- Add the latest resume context at the head.+      head_frame <- GHC.getResumeContext >>= \case+        [] ->+          -- See Note [Don't crash if not stopped]+          return Nothing+        r:_+          | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)+          -> do+            r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)+            if r_tid == req_tid then+              -- We're getting the stacktrace for the thread we're stopped at.+              return $+                Just DbgStackFrame+                  { name = GHC.resumeDecl r+                  , sourceSpan = realSrcSpanToSourceSpan ss+                  }+            else+             return Nothing+          | otherwise ->+              -- No resume span; which should mean we're stopped on an exception.+              -- No info for now.+              return Nothing+      -- TODO: Currently, only display head_frame+      -- return (maybe id (:) head_frame $ decoded_frames)+      return (maybe [] (:[]) head_frame)+    ipe_frames -> catMaybes <$> do+      forM ipe_frames $ \stack_entry -> do+        case srcSpanStringToSourceSpan (Stack.srcLoc stack_entry) of+          Left err -> do+            -- Couldn't parse. The srcLoc may be invalid so just keep this as info, not warning.+            logSDoc Logger.Info $+              text "Couldn't parse StackEntry srcLoc \"" Ppr.<> text (Stack.srcLoc stack_entry)+                                                         Ppr.<> text "\":" <+> text err+            return Nothing+          Right sourceSpan ->+            return $ Just DbgStackFrame+              { name = Stack.moduleName stack_entry ++ "." ++ Stack.functionName stack_entry+              , sourceSpan = sourceSpan+              }++-------------------------------------------------------------------------------- -- * Scopes -------------------------------------------------------------------------------- @@ -167,7 +285,7 @@                 -- It is a "lazy" DAP variable: our reply can ONLY include                 -- this single variable. -                term' <- forceTerm key term+                term' <- forceTerm term                  vi <- termToVarInfo key term' @@ -185,7 +303,7 @@        -- (VARR)(a) from here onwards -      LocalVariables -> fmap Right $+      LocalVariables -> fmap Right $ do         -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)         mapM tyThingToVarInfo =<< GHC.getBindings 

@@ -3,7 +3,6 @@    TypeApplications, ScopedTypeVariables, BangPatterns, DerivingVia, TypeAbstractions #-} module GHC.Debugger.Stopped.Variables where -import Data.IORef import Control.Monad.Reader  import GHC@@ -16,14 +15,11 @@ import qualified GHC.Runtime.Debugger     as GHCD import qualified GHC.Runtime.Heap.Inspect as GHCI -import GHC.Debugger.View.Class hiding (VarFields)- import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime import GHC.Debugger.Runtime.Instances import GHC.Debugger.Runtime.Term.Key-import GHC.Debugger.Runtime.Term.Cache import GHC.Debugger.Utils  -- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the@@ -164,7 +160,7 @@             , isThunk = False             , varValue, varRef } -        Just VarValue{varExpandable, varValue=value} -> do+        Just VarValueResult{varValueResultExpandable=varExpandable, varValueResult=value} -> do            varRef <-             if varExpandable@@ -191,13 +187,8 @@ -- | Forces a term to WHNF -- -- The term is updated in the cache at the given key.-forceTerm :: TermKey -> Term -> Debugger Term-forceTerm key term = do+forceTerm :: Term -> Debugger Term+forceTerm term = do   hsc_env <- getSession--  term' <- liftIO $ seqTerm hsc_env term--  -- update cache with the forced term right away instead of invalidating it.-  asks termCache >>= \r -> liftIO $ modifyIORef' r (insertTermCache key term')-  return term'+  liftIO $ seqTerm hsc_env term 

@@ -7,14 +7,22 @@   , module GHC.Utils.Trace   ) where +import Control.Applicative+import Control.Monad.IO.Class+import Control.Exception+ import GHC import GHC.Data.FastString import GHC.Driver.DynFlags import GHC.Driver.Ppr-import GHC.Utils.Outputable+import GHC.Utils.Outputable hiding (char) import GHC.Utils.Trace+import qualified Data.Text as T +import Data.Attoparsec.Text+ import GHC.Debugger.Monad+import GHC.Debugger.Logger as Logger import GHC.Debugger.Interface.Messages  --------------------------------------------------------------------------------@@ -37,4 +45,52 @@   dflags <- getDynFlags   return $ showSDoc dflags (ppr x) {-# INLINE display #-}++--------------------------------------------------------------------------------+-- * More utils+--------------------------------------------------------------------------------++expectRight :: Exception e => Either e a -> Debugger a+expectRight s = case s of+  Left e -> do+    logSDoc Logger.Error (text $ displayException e)+    liftIO $ throwIO e+  Right a -> do+    pure a++--------------------------------------------------------------------------------+-- * Parsing+--------------------------------------------------------------------------------++-- | Takes a 'srcLoc' string from 'StackEntry' and returns a 'SourceSpan'.+--+-- === Example strings+--+-- - @hdb/Development/Debug/Adapter/Init.hs:(188,15)-(197,48)@+-- - @hdb/Development/Debug/Adapter/Proxy.hs:93:34-37@+srcSpanStringToSourceSpan :: String -> Either String SourceSpan+srcSpanStringToSourceSpan s = parseOnly pSrcSpan (T.pack s)+  where+    pSrcSpan = do+      fp <- pFile <* char ':'+      pParenStyle fp <|> pColonStyle fp++    -- file:(l1,c1)-(l2,c2)+    pParenStyle fp = do+      (l1, c1) <- (,) <$> (char '(' *> num <* char ',') <*> (num <* char ')') <* char '-'+      (l2, c2) <- (,) <$> (char '(' *> num <* char ',') <*> (num <* char ')')+      pure (SourceSpan fp l1 l2 c1 c2)++    -- file:l1:c1-c2+    pColonStyle fp = do+      l1 <- num <* char ':'+      c1 <- num <* char '-'+      c2 <- num+      pure (SourceSpan fp l1 l1 c1 c2)++    pFile :: Parser FilePath+    pFile = T.unpack <$> takeTill (== ':')++    num :: Parser Int+    num = decimal 

@@ -21,11 +21,11 @@ commandBreakpointLocations :: DebugAdaptor () commandBreakpointLocations = do   BreakpointLocationsArguments{..} <- getArguments-  file <- fileFromSourcePath breakpointLocationsArgumentsSource+  filePath <- fileFromSourcePath breakpointLocationsArgumentsSource    DidGetBreakpoints mspan <-     sendSync $ GetBreakpointsAt-      ModuleBreak { path      = file+      ModuleBreak { path      = filePath                   , lineNum   = breakpointLocationsArgumentsLine                   , columnNum = breakpointLocationsArgumentsColumn                   }@@ -47,17 +47,17 @@ commandSetBreakpoints :: DebugAdaptor () commandSetBreakpoints = do   SetBreakpointsArguments {..} <- getArguments-  file <- fileFromSourcePath setBreakpointsArgumentsSource+  filePath <- fileFromSourcePath setBreakpointsArgumentsSource   let breaks_wanted = fromMaybe [] setBreakpointsArgumentsBreakpoints    -- Clear existing module breakpoints-  DidClearBreakpoints <- sendSync (ClearModBreakpoints file)+  DidClearBreakpoints <- sendSync (ClearModBreakpoints filePath)    -- Set requested ones   breaks <- forM breaks_wanted $ \bp -> do     DidSetBreakpoint bf <-       sendSync $ SetBreakpoint-        ModuleBreak { path      = file+        ModuleBreak { path      = filePath                     , lineNum   = DAP.sourceBreakpointLine bp                     , columnNum = DAP.sourceBreakpointColumn bp                     }@@ -81,7 +81,7 @@   breaks <- forM breaks_wanted $ \bp -> do     DidSetBreakpoint bf <-       sendSync $ SetBreakpoint-        FunctionBreak { function  = T.unpack $ fromJust {- not optional! -} $ DAP.functionBreakpointName bp }+        FunctionBreak { function  = T.unpack $ DAP.functionBreakpointName bp }         (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp))         (T.unpack <$> DAP.functionBreakpointCondition bp)     registerBreakFound bf

@@ -90,14 +90,15 @@     Output.stderr (T.pack resultVal)     sendTerminatedEvent defaultTerminatedEvent     sendExitedEvent (ExitedEvent 42)-  EvalStopped {breakId = Nothing} ->+  EvalStopped {breakId = Nothing, breakThread} ->     sendStoppedEvent       defaultStoppedEvent {         stoppedEventAllThreadsStopped = True       , stoppedEventReason = StoppedEventReasonException       , stoppedEventHitBreakpointIds = []+      , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread       }-  EvalStopped {breakId = Just bid} -> do+  EvalStopped {breakId = Just bid, breakThread} -> do     DAS{breakpointMap} <- getDebugSession     sendStoppedEvent       defaultStoppedEvent {@@ -108,5 +109,6 @@                         else StoppedEventReasonBreakpoint       , stoppedEventHitBreakpointIds           = maybe [] IS.toList (M.lookup bid breakpointMap)+      , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread       } 

@@ -26,6 +26,7 @@ import Control.Monad.Catch import Control.Exception (SomeAsyncException, throwIO) import Control.Concurrent+import GHC.Conc.Sync (labelThread) import Control.Monad import Data.Aeson as Aeson import GHC.Generics@@ -34,7 +35,7 @@  import Development.Debug.Adapter import Development.Debug.Adapter.Exit-import GHC.Debugger.Logger+import GHC.Debugger.Logger as Logger import qualified Development.Debug.Adapter.Output as Output  import qualified GHC.Debugger as Debugger@@ -167,6 +168,8 @@ -- write to stdout, but always write to the appropiate handle. stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () stdoutCaptureThread runInTerminal syncOut withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stdin Capture Thread"   withInterceptedStdout $ \_ interceptedStdout -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStdout@@ -179,6 +182,8 @@ -- | Like 'stdoutCaptureThread' but for stderr stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () stderrCaptureThread runInTerminal syncErr withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stderr Capture Thread"   withInterceptedStderr $ \_ interceptedStderr -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStderr@@ -198,6 +203,8 @@  stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () stdinForwardThread runInTerminal syncIn _withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stdin Forward Thread"   when runInTerminal $ do     -- We need to hijack stdin to write to it @@ -257,7 +264,16 @@    catches     (do-      Debugger.runDebugger (cmapWithSev DebuggerMonadLog recorder) writeDebuggerOutput rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do+      -- The logger should log things starting from Info to the debugger output+      -- handle as well, so the user sees it in the Console.+      debugAdapterLogger <- handleLogger writeDebuggerOutput+      let final_logger = cmapWithSev DebuggerMonadLog recorder <>+                         applyVerbosity (Verbosity Logger.Info)+                          (cmap renderPrettyWithSeverity (fromCologAction debugAdapterLogger))+      Debugger.runDebugger final_logger writeDebuggerOutput rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do+        liftIO $ do+          tid <- myThreadId+          labelThread tid "Main Debugger Thread"         liftIO $ signalInitialized (Right ())         forever $ do           req <- takeMVar requests & liftIO

@@ -17,6 +17,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Concurrent+import GHC.Conc.Sync (labelThread) import qualified Data.List.NonEmpty as NE  import qualified Data.Text as T@@ -63,6 +64,7 @@   port <- liftIO $ socketPort sock    _ <- liftIO $ forkIO $ ignoreIOException $ do+    myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server"     runTCPServerWithSocket sock $ \scket -> do        logWith l Info $ ProxyLog $ T.pack $ "Connected to client on port " ++ show port ++ "...!"@@ -70,6 +72,8 @@        -- -- Read stdout from chan and write to socket       _ <- forkIO $ ignoreIOException $ do+        tid <- myThreadId+        labelThread tid "Debug/Adapter/Proxy: Forward stdout"         forever $ do           bs <- readChan dbOut           logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket: " ++ BS8.unpack bs@@ -77,6 +81,8 @@        -- Read stderr from chan and write to socket       _ <- forkIO $ ignoreIOException $ do+        tid <- myThreadId+        labelThread tid "Debug/Adapter/Proxy: Forward stderr"         forever $ do           bs <- readChan dbErr           logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs@@ -124,7 +130,7 @@         catch (forever $ do           str <- BS8.hGetLine stdin           NBS.sendAll sock (str <> BS8.pack "\n")-          ) $ \(e::IOException) -> return () -- connection dropped, just exit.+          ) $ \(_e::IOException) -> return () -- connection dropped, just exit.        -- Forward stdout from sock       catch (forever $ do@@ -135,9 +141,9 @@             close sock             exitSuccess           else BS8.hPut stdout msg >> hFlush stdout-        ) $ \(e::IOException) -> return () -- connection dropped, just exit.+        ) $ \(_e::IOException) -> return () -- connection dropped, just exit. -    ) $ \(e::IOException) -> do+    ) $ \(_e::IOException) -> do       hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?"  -- | Send a 'runInTerminal' reverse request to the DAP client

@@ -14,6 +14,7 @@ -- @ module Development.Debug.Adapter.Stopped where +import Control.Monad import qualified Data.Text as T  import DAP@@ -28,13 +29,15 @@  -- | Command to get thread information at current stopped point commandThreads :: DebugAdaptor ()-commandThreads = do -- TODO-  sendThreadsResponse [+commandThreads = do+  GotThreads ts <- sendSync GetThreads+  sendThreadsResponse $+    map (\t ->       Thread-        { threadId    = 0-        , threadName  = T.pack "dummy thread"+        { threadId    = remoteThreadIntRef t.tId+        , threadName  = maybe (T.pack $ "Thread #" ++ show (remoteThreadIntRef t.tId)) T.pack t.tName         }-    ]+      ) ts  -------------------------------------------------------------------------------- -- * StackTrace@@ -44,29 +47,28 @@ commandStackTrace :: DebugAdaptor () commandStackTrace = do   StackTraceArguments{..} <- getArguments-  GotStacktrace fs <- sendSync GetStacktrace-  case fs of-    []  ->-      -- No frames; should be stopped on exception-      sendStackTraceResponse StackTraceResponse { stackFrames = [], totalFrames = Nothing }-    [f] -> do-      source <- fileToSource f.sourceSpan.file-      let-        topStackFrame = defaultStackFrame-          { stackFrameId = 0-          , stackFrameName = T.pack f.name-          , stackFrameLine = f.sourceSpan.startLine-          , stackFrameColumn = f.sourceSpan.startCol-          , stackFrameEndLine = Just f.sourceSpan.endLine-          , stackFrameEndColumn = Just f.sourceSpan.endCol-          , stackFrameSource = Just source-          }-      sendStackTraceResponse StackTraceResponse-        { stackFrames = [topStackFrame]-        , totalFrames = Just 1-        }-    _ -> error $ "Unexpected multiple frames since implementation doesn't support it yet: " ++ show fs+  GotStacktrace stackFrames <- sendSync (GetStacktrace (RemoteThreadId stackTraceArgumentsThreadId))+  responseFrames <- forM (zip stackFrames [1..]) $ \(stackFrame, stackFrameIx) -> do+    source <- fileToSource stackFrame.sourceSpan.file+    return defaultStackFrame+      { stackFrameId = stackTraceArgumentsThreadId*1000000 + stackFrameIx+      , stackFrameName = T.pack stackFrame.name+      , stackFrameLine = stackFrame.sourceSpan.startLine+      , stackFrameColumn = stackFrame.sourceSpan.startCol+      , stackFrameEndLine = Just stackFrame.sourceSpan.endLine+      , stackFrameEndColumn = Just stackFrame.sourceSpan.endCol+      , stackFrameSource = Just source+      }+  sendStackTraceResponse StackTraceResponse+    { stackFrames = responseFrames+    , totalFrames = if null responseFrames then Nothing else Just (length responseFrames) } +-- | Come up with a unique identifier for a stack frame (only valid while in+-- this stopped environment, see "Lifetime of Objects References" in DAP+-- overview).+--+-- The unique identifier is based on the threadId and index of the stack frame for this thread's stack.+-- mkUniqueStackId ::  -------------------------------------------------------------------------------- -- * Scopes@@ -75,7 +77,7 @@ -- | Command to get scopes for current stopped point commandScopes :: DebugAdaptor () commandScopes = do-  ScopesArguments{scopesArgumentsFrameId=0} <- getArguments+  ScopesArguments{scopesArgumentsFrameId=_IGNORED_BUT_NOW_WE_HAVE_TO_CARE} <- getArguments   GotScopes scopes <- sendSync GetScopes   sendScopesResponse . ScopesResponse =<<     mapM scopeInfoToScope scopes

@@ -5,14 +5,14 @@ import System.Exit import System.Directory import System.Console.Haskeline-import System.Console.Haskeline.Completion+-- import System.Console.Haskeline.Completion import System.FilePath import Control.Monad.Except import Control.Monad.State import Control.Monad.Reader import Control.Monad.RWS import Options.Applicative-import Options.Applicative.BashCompletion+-- import Options.Applicative.BashCompletion  import Development.Debug.Session.Setup @@ -122,14 +122,15 @@   DidContinue er -> outputStrLn $ show er   DidStep er -> printEvalResult recd er   DidExec er -> outputStrLn $ show er+  GotThreads threads -> outputStrLn $ show threads   GotStacktrace stackframes -> outputStrLn $ show stackframes   GotScopes scopeinfos -> outputStrLn $ show scopeinfos   GotVariables vis -> outputStrLn $ show vis -- (Either VarInfo [VarInfo])-  Aborted str -> outputStrLn ("Aborted: " ++ str)+  Aborted err_str -> outputStrLn ("Aborted: " ++ err_str)   Initialised -> pure ()  printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM ()-printEvalResult recd EvalStopped{breakId} = do+printEvalResult recd EvalStopped{breakId=_} = do   out <- lift . lift $ execute recd GetScopes   printResponse recd out printEvalResult _ er = outputStrLn $ show er@@ -191,7 +192,7 @@   -- just "run"   <|> (pure $ DebugExecution (mkEntry entryPoint) entryFile entryArgs)   where-    parseEntry =+    _parseEntry =       fmap mkEntry $       option str         ( long "entry"@@ -269,4 +270,5 @@        in outputStrLn msg >> pure Nothing     _ -> outputStrLn "Unsupported command parsing mode" >> pure Nothing +parserPrefs :: ParserPrefs parserPrefs = prefs (disambiguate <> showHelpOnError <> showHelpOnEmpty)

@@ -176,7 +176,7 @@      -- connection is expected. See #95.      -> Command -> DebugAdaptor () ---------------------------------------------------------------------------------talk l support_rit_var pid_var client_proxy_signal = \ case+talk l support_rit_var _pid_var client_proxy_signal = \ case   CommandInitialize -> do     InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments     let runInTerminal = fromMaybe False supportsRunInTerminalRequest@@ -271,7 +271,7 @@     -> IORef (Maybe Int)     -- ^ Reference to PID of runInTerminal proxy process running     -> ReverseRequestResponse -> DebugAdaptorCont ()-ack l ref rrr = case rrr.reverseRequestCommand of+ack l _ref rrr = case rrr.reverseRequestCommand of   ReverseCommandRunInTerminal -> do     when rrr.success $ do       logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful"

@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes #-}+{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes, CPP #-} module Main (main) where  import Text.RE.TDFA.Text.Lazy@@ -15,6 +15,7 @@ import Control.Exception  import Test.Tasty+import Test.Tasty.ExpectedFailure import Test.Tasty.Golden as G import Test.Tasty.Golden.Advanced as G @@ -25,11 +26,15 @@ main = do   goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden"   defaultMain $+#ifdef mingw32_HOST_OS+    ignoreTestBecause "Testsuite is not enabled on Windows (#149)" $+#endif     testGroup "Tests"       [ testGroup "Golden tests" goldens       , testGroup "Unit tests" unitTests       ] +unitTests :: [TestTree] unitTests =   [ runInTerminalTests   ]@@ -77,10 +82,14 @@   -- Normalise the action producing the output   normalisingAct = do     tmpDir <- getCanonicalTemporaryDirectory-    replaceRE <- compileSearchReplace (tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-})-                                      "<TEMPORARY-DIRECTORY>"+    replaceREs <- traverse (uncurry compileSearchReplace)+      [ ( tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-}+        , "<TEMPORARY-DIRECTORY>" )+      , ( "Using cabal specification: .*"+        , "Using cabal specification: <VERSION>" )+      ] -    let normalising (LT.decodeUtf8 -> txt) = txt *=~/ replaceRE+    let normalising (LT.decodeUtf8 -> txt) = foldl' (*=~/) txt replaceREs      normalising <$> act 

@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-} module Test.DAP.RunInTerminal (runInTerminalTests) where  import Control.Concurrent@@ -17,6 +18,7 @@ import Test.DAP import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.ExpectedFailure import Test.Utils import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LB8@@ -26,7 +28,11 @@  runInTerminalTests =   testGroup "DAP.RunInTerminal"-    [ testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1+    [+#ifdef mingw32_HOST_OS+      ignoreTestBecause "Needs to be fixed for Windows" $+#endif+      testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1     ]  rit_keep_tmp_dirs :: Bool