diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs b/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs @@ -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 []) diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -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] + diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs b/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Containers.hs @@ -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 ] diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Text.hs b/haskell-debugger-view/src/GHC/Debugger/View/Text.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/Text.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Text.hs @@ -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 [] diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -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 diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs deleted file mode 100644 --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ /dev/null @@ -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 - diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Run.hs b/haskell-debugger/GHC/Debugger/Run.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Run.hs @@ -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?!?" diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -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 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 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' -- diff --git a/haskell-debugger/GHC/Debugger/Runtime/Compile.hs b/haskell-debugger/GHC/Debugger/Runtime/Compile.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Compile.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs b/haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs @@ -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 _) = "" + 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"]) diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs @@ -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") "." [] diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs @@ -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" ( -> 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") @ 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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs @@ -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") + diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs @@ -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) + diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs @@ -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 + diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Utils.hs b/haskell-debugger/GHC/Debugger/Utils.hs --- a/haskell-debugger/GHC/Debugger/Utils.hs +++ b/haskell-debugger/GHC/Debugger/Utils.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs --- a/hdb/Development/Debug/Adapter/Breakpoints.hs +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb/Development/Debug/Adapter/Evaluation.hs --- a/hdb/Development/Debug/Adapter/Evaluation.hs +++ b/hdb/Development/Debug/Adapter/Evaluation.hs @@ -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 } diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs --- a/hdb/Development/Debug/Adapter/Proxy.hs +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb/Development/Debug/Adapter/Stopped.hs --- a/hdb/Development/Debug/Adapter/Stopped.hs +++ b/hdb/Development/Debug/Adapter/Stopped.hs @@ -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 diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -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) diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -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" diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -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-}) - "" + replaceREs <- traverse (uncurry compileSearchReplace) + [ ( tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-} + , "" ) + , ( "Using cabal specification: .*" + , "Using cabal specification: " ) + ] - let normalising (LT.decodeUtf8 -> txt) = txt *=~/ replaceRE + let normalising (LT.decodeUtf8 -> txt) = foldl' (*=~/) txt replaceREs normalising <$> act diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs --- a/test/haskell/Test/DAP/RunInTerminal.hs +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -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