diff options
author | Roland Senn <rsx@bluewin.ch> | 2021-01-16 17:31:45 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2021-03-10 16:59:05 -0500 |
commit | fcfc66e59c81277c1f7c079ad4e0ccd9a69e1fb6 (patch) | |
tree | 378b6b8bebea928fe5fafad2dcf7920253ecbaeb | |
parent | 115cd3c85a8c38f1fe2a10d4ee515f92c96dd5a2 (diff) | |
download | haskell-fcfc66e59c81277c1f7c079ad4e0ccd9a69e1fb6.tar.gz |
Ignore breakpoint for a specified number of iterations. (#19157)
* Implement new debugger command `:ignore` to set an `ignore count`
for a specified breakpoint.
* Allow new optional parameter on `:continue` command to set an
`ignore count` for the current breakpoint.
* In the Interpreter replace the current `Word8` BreakArray with
an `Int` array.
* Change semantics of values in `BreakArray` to:
n < 0 : Breakpoint is disabled.
n == 0 : Breakpoint is enabled.
n > 0 : Breakpoint is enabled, but ignore next `n` iterations.
* Rewrite `:enable`/`:disable` processing as a special case of `:ignore`.
* Remove references to `BreakArray` from `ghc/UI.hs`.
-rw-r--r-- | compiler/GHC.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 8 | ||||
-rw-r--r-- | docs/users_guide/9.2.1-notes.rst | 13 | ||||
-rw-r--r-- | docs/users_guide/ghci.rst | 28 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 123 | ||||
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 6 | ||||
-rw-r--r-- | libraries/ghci/GHCi/BreakArray.hs | 83 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Message.hs | 14 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Run.hs | 8 | ||||
-rw-r--r-- | rts/Interpreter.c | 13 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/T19157.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/T19157.script | 20 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/T19157.stdout | 41 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/all.T | 1 |
15 files changed, 281 insertions, 109 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 5a36987817..7e6d8349b6 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -159,9 +159,10 @@ module GHC ( GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, - BreakInfo(breakInfo_number, breakInfo_module), + BreakInfo(..), GHC.Runtime.Eval.back, GHC.Runtime.Eval.forward, + GHC.Runtime.Eval.setupBreakpoint, -- * Abstract syntax elements diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index fc2f8b8ab3..94a4e775ad 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -23,6 +23,7 @@ module GHC.Runtime.Eval ( getHistorySpan, getModBreaks, getHistoryModule, + setupBreakpoint, back, forward, setContext, getContext, getNamesInScope, @@ -397,8 +398,9 @@ handleRunStatus step expr bindings final_ids status history #endif -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult -resumeExec canLogSpan step +resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int + -> m ExecResult +resumeExec canLogSpan step mbCnt = do hsc_env <- getSession let ic = hsc_IC hsc_env @@ -433,6 +435,10 @@ resumeExec canLogSpan step , resumeSpan = span , resumeHistory = hist } -> withVirtualCWD $ do + when (isJust mb_brkpt && isJust mbCnt) $ do + setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt) + -- When the user specified a break ignore count, set it + -- in the interpreter status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv let prevHistoryLst = fromListBL 50 hist hist' = case mb_brkpt of @@ -443,6 +449,17 @@ resumeExec canLogSpan step fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' +setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m () -- #19157 +setupBreakpoint hsc_env brkInfo cnt = do + let modl :: Module = breakInfo_module brkInfo + breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $ + lookupHpt (hsc_HPT hsc_env) (moduleName modl) + ix = breakInfo_number brkInfo + modBreaks = breaks hsc_env modl + breakarray = modBreaks_flags modBreaks + _ <- liftIO $ GHCi.storeBreakpoint hsc_env breakarray ix cnt + pure () + back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) back n = moveHist (+n) diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index cb13089571..cc5f289f48 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -19,7 +19,7 @@ module GHC.Runtime.Interpreter , mkCostCentres , costCentreStackInfo , newBreakArray - , enableBreakpoint + , storeBreakpoint , breakpointStatus , getBreakpointVar , getClosure @@ -379,10 +379,10 @@ newBreakArray hsc_env size = do breakArray <- iservCmd hsc_env (NewBreakArray size) mkFinalizedHValue hsc_env breakArray -enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () -enableBreakpoint hsc_env ref ix b = +storeBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Int -> IO () +storeBreakpoint hsc_env ref ix cnt = do -- #19157 withForeignRef ref $ \breakarray -> - iservCmd hsc_env (EnableBreakpoint breakarray ix b) + iservCmd hsc_env (SetupBreakpoint breakarray ix cnt) breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool breakpointStatus hsc_env ref ix = diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index 6e36f1dbeb..4fdf6b070b 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -125,9 +125,6 @@ Compiler For more details see :ghc-flag:`-finline-generics` and :ghc-flag:`-finline-generics-aggressively`. -- GHCi's ``:kind!`` command now expands through type synonyms in addition to type - families. See :ghci-cmd:`:kind`. - - GHC now supports a flag, :ghc-flag:`-fprof-callers=⟨name⟩`, for requesting that the compiler automatically insert cost-centres on all call-sites of the named function. @@ -147,6 +144,9 @@ Compiler GHCi ~~~~ +- GHCi's ``:kind!`` command now expands through type synonyms in addition to + type families. See :ghci-cmd:`:kind`. + - GHCi's :ghci-cmd:`:edit` command now looks for an editor in the :envvar:`VISUAL` environment variable before :envvar:`EDITOR`, following UNIX convention. @@ -156,6 +156,13 @@ GHCi ``$HOME/.ghc`` is found it will fallback to the old paths to give you time to migrate. This fallback will be removed in three releases. +- New debugger command :ghci-cmd:`:ignore` to set an ``ignore count`` for a + specified breakpoint. The next ``ignore count`` times the program hits this + breakpoint, the breakpoint is ignored, and the program doesn't stop. + +- New optional parameter added to the command :ghci-cmd:`:continue` to set the + ``ignore count`` for the current breakpoint. + Runtime system ~~~~~~~~~~~~~~ diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst index ac9f33f362..5ffe323f5f 100644 --- a/docs/users_guide/ghci.rst +++ b/docs/users_guide/ghci.rst @@ -2347,10 +2347,14 @@ commonly used commands. ghci> :complete repl 5-10 "map" 0 3 "" -.. ghci-cmd:: :continue +.. ghci-cmd:: :continue; [⟨ignoreCount⟩] Continue the current evaluation, when stopped at a breakpoint. + If an ``⟨ignoreCount⟩`` is specified, the program will ignore + the current breakpoint for the next ``⟨ignoreCount⟩`` iterations. + See command :ghci-cmd:`:ignore`. + .. ghci-cmd:: :ctags; [⟨filename⟩] Generates a "tags" file for Vi-style editors (:ghci-cmd:`:ctags`) or @@ -2459,7 +2463,8 @@ commonly used commands. Enable one or more disabled breakpoints by number (use :ghci-cmd:`:show breaks` to see the number and state of each breakpoint). The ``*`` form enables all the - disabled breakpoints. + disabled breakpoints. Enabling a break point will reset its ``ignore count`` + to 0. (See :ghci-cmd:`:ignore`) .. ghci-cmd:: :etags @@ -2577,6 +2582,20 @@ commonly used commands. current module if omitted). This includes the trust type of the module and its containing package. +.. ghci-cmd:: :ignore; ⟨break⟩ ⟨ignoreCount⟩ + + Set the ignore count of the breakpoint with number ``⟨break⟩`` to + ``⟨ignoreCount⟩``. + + The next ``⟨ignoreCount⟩`` times the program hits the breakpoint + ``⟨break⟩``, this breakpoint is ignored and the program doesn't + stop. Every time the breakpoint is ignored, the ``ignore count`` + is decremented by 1. When the ``ignore count`` is zero, the program + again stops at the break point. + + You can also specify an ``⟨ignoreCount⟩`` on a :ghci-cmd:`:continue` + command when you resume execution of your program. + .. ghci-cmd:: :kind;[!] ⟨type⟩ Infers and prints the kind of ⟨type⟩. The latter can be an arbitrary @@ -2866,8 +2885,9 @@ commonly used commands. *ghci> :def cond \expr -> return (":cmd if (" ++ expr ++ ") then return \"\" else return \":continue\"") *ghci> :set stop 0 :cond (x < 3) - Ignoring breakpoints for a specified number of iterations is also - possible using similar techniques. + To ignore breakpoints for a specified number of iterations use + the :ghci-cmd:`:ignore` or the ``⟨ignoreCount⟩`` parameter of the + :ghci-cmd:`:continue` command. .. ghci-cmd:: :seti; [⟨option⟩ ...] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 10a9cfa71d..d4dbfc7c60 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -43,7 +43,7 @@ import GHC.Runtime.Debugger import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes -import GHCi.BreakArray +import GHCi.BreakArray( breakOn, breakOff ) import GHC.ByteCode.Types import GHC.Core.DataCon import GHC.Core.ConLike @@ -216,6 +216,7 @@ ghciCommands = map mkCmd [ ("info", keepGoing' (info False), completeIdentifier), ("info!", keepGoing' (info True), completeIdentifier), ("issafe", keepGoing' isSafeCmd, completeModule), + ("ignore", keepGoing ignoreCmd, noCompletion), ("kind", keepGoing' (kindOfType False), completeIdentifier), ("kind!", keepGoing' (kindOfType True), completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), @@ -352,7 +353,7 @@ defFullHelpText = " :back [<n>] go back in the history N steps (after :trace)\n" ++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++ " :break <name> set a breakpoint on the specified function\n" ++ - " :continue resume after a breakpoint\n" ++ + " :continue [<count>] resume after a breakpoint [and set break ignore count]\n" ++ " :delete <number> ... delete the specified breakpoints\n" ++ " :delete * delete all breakpoints\n" ++ " :disable <number> ... disable the specified breakpoints\n" ++ @@ -362,6 +363,7 @@ defFullHelpText = " :force <expr> print <expr>, forcing unevaluated parts\n" ++ " :forward [<n>] go forward in the history N step s(after :back)\n" ++ " :history [<n>] after :trace, show the execution history\n" ++ + " :ignore <breaknum> <count> for break <breaknum> set break ignore <count>\n" ++ " :list show the source code around current breakpoint\n" ++ " :list <identifier> show the source code for <identifier>\n" ++ " :list [<module>] <line> show the source code around line number <line>\n" ++ @@ -1323,7 +1325,7 @@ afterRunStmt step_here run_result = do st <- getGHCiState enqueueCommands [stop st] return () - | otherwise -> resume step_here GHC.SingleStep >>= + | otherwise -> resume step_here GHC.SingleStep Nothing >>= afterRunStmt step_here >> return () flushInterpBuffers @@ -3529,7 +3531,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 -- Return all possible bids for a given Module bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] bidsByModule nonquals mod = do - (_, _, decls) <- getModBreak mod + (_, decls) <- getModBreak mod let bids = nub $ declPath <$> elems decls pure $ case (moduleName mod) `elem` nonquals of True -> bids @@ -3556,7 +3558,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 -- declarations. See Note [ModBreaks.decls] in GHC.ByteCode.Types addNestedDecls :: GhciMonad m => (String, Module) -> m [String] addNestedDecls (ident, mod) = do - (_, _, decls) <- getModBreak mod + (_, decls) <- getModBreak mod let (mod_str, topLvl, _) = splitIdent ident ident_decls = filter ((topLvl ==) . head) $ elems decls bids = nub $ declPath <$> ident_decls @@ -3742,12 +3744,24 @@ traceCmd arg tr [] = doContinue (const True) GHC.RunAndLogSteps tr expression = runStmt expression GHC.RunAndLogSteps >> return () -continueCmd :: GhciMonad m => String -> m () -continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion +continueCmd :: GhciMonad m => String -> m () -- #19157 +continueCmd argLine = withSandboxOnly ":continue" $ + case contSwitch (words argLine) of + Left sdoc -> printForUser sdoc + Right mbCnt -> doContinue' (const True) GHC.RunToCompletion mbCnt + where + contSwitch :: [String] -> Either SDoc (Maybe Int) + contSwitch [ ] = Right Nothing + contSwitch [x] = getIgnoreCount x + contSwitch _ = Left $ + text "After ':continue' only one ignore count is allowed" doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m () -doContinue pre step = do - runResult <- resume pre step +doContinue pre step = doContinue' pre step Nothing + +doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m () +doContinue' pre step mbCnt= do + runResult <- resume pre step mbCnt _ <- afterRunStmt pre runResult return () @@ -3793,23 +3807,30 @@ enaDisaSwitch enaDisa idents = do where enaDisaOneBreak :: GhciMonad m => Bool -> String -> m () enaDisaOneBreak enaDisa strId = do - sdoc_loc <- getBreakLoc enaDisa strId + sdoc_loc <- checkEnaDisa enaDisa strId case sdoc_loc of Left sdoc -> printForUser sdoc Right loc -> enaDisaAssoc enaDisa (read strId, loc) -getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation) -getBreakLoc enaDisa strId = do +checkEnaDisa :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation) +checkEnaDisa enaDisa strId = do + sdoc_loc <- getBreakLoc strId + pure $ sdoc_loc >>= checkEnaDisaState enaDisa strId + +getBreakLoc :: GhciMonad m => String -> m (Either SDoc BreakLocation) +getBreakLoc strId = do st <- getGHCiState case readMaybe strId >>= flip IntMap.lookup (breaks st) of Nothing -> return $ Left (text "Breakpoint" <+> text strId <+> text "not found") - Just loc -> - if breakEnabled loc == enaDisa - then return $ Left - (text "Breakpoint" <+> text strId <+> - text "already in desired state") - else return $ Right loc + Just loc -> return $ Right loc + +checkEnaDisaState :: Bool -> String -> BreakLocation -> Either SDoc BreakLocation +checkEnaDisaState enaDisa strId loc = do + if breakEnabled loc == enaDisa + then Left $ + text "Breakpoint" <+> text strId <+> text "already in desired state" + else Right loc enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m () enaDisaAssoc enaDisa (intId, loc) = do @@ -3854,6 +3875,41 @@ bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold | otherwise = c +ignoreCmd :: GhciMonad m => String -> m () -- #19157 +ignoreCmd argLine = withSandboxOnly ":ignore" $ do + result <- ignoreSwitch (words argLine) + case result of + Left sdoc -> printForUser sdoc + Right (loc, mbCount) -> do + let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc) + count = fromMaybe 0 mbCount + setupBreakpoint breakInfo count + +ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Maybe Int)) +ignoreSwitch [break, count] = do + sdoc_loc <- getBreakLoc break + pure $ (,) <$> sdoc_loc <*> getIgnoreCount count +ignoreSwitch _ = pure $ Left $ text "Syntax: :ignore <breaknum> <count>" + +getIgnoreCount :: String -> Either SDoc (Maybe Int) +getIgnoreCount str = + let checkJust :: Maybe Int -> Either SDoc (Maybe Int) + checkJust mbCnt + | (isJust mbCnt) = Right mbCnt + | otherwise = Left $ sdocIgnore <+> text "is not numeric" + checkPositive :: Maybe Int -> Either SDoc (Maybe Int) + checkPositive mbCnt + | isJust mbCnt && fromJust mbCnt >= 0 = Right mbCnt + | otherwise = Left $ sdocIgnore <+> text "must be >= 0" + mbCnt :: Maybe Int = readMaybe str + sdocIgnore = (text "Ignore count") <+> quotes (text str) + in Right mbCnt >>= checkJust >>= checkPositive + +setupBreakpoint :: GhciMonad m => GHC.BreakInfo -> Int -> m() +setupBreakpoint loc count = do + hsc_env <- GHC.getSession + GHC.setupBreakpoint hsc_env loc count + backCmd :: GhciMonad m => String -> m () backCmd arg | null arg = back 1 @@ -3972,7 +4028,7 @@ breakById inp = do validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" validateBP _ fun_str (Just modl) = do isInterpr <- GHC.moduleIsInterpreted modl - (_, _, decls) <- getModBreak modl + (_, decls) <- getModBreak modl mb_err_msg <- case isInterpr of False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" @@ -3991,13 +4047,12 @@ findBreakAndSet :: GhciMonad m => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m () findBreakAndSet md lookupTickTree = do tickArray <- getTickArray md - (breakArray, _, _) <- getModBreak md case lookupTickTree tickArray of [] -> liftIO $ putStrLn $ "No breakpoints found at that location." - some -> mapM_ (breakAt breakArray) some + some -> mapM_ breakAt some where - breakAt breakArray (tick, pan) = do - setBreakFlag True breakArray tick + breakAt (tick, pan) = do + setBreakFlag md tick True (alreadySet, nm) <- recordBreak $ BreakLocation { breakModule = md @@ -4266,7 +4321,7 @@ getTickArray modl = do case lookupModuleEnv arrmap modl of Just arr -> return arr Nothing -> do - (_breakArray, ticks, _) <- getModBreak modl + (ticks, _) <- getModBreak modl let arr = mkTickArray (assocs ticks) setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} return arr @@ -4301,29 +4356,27 @@ deleteBreak identity = do let rest = IntMap.delete identity oldLocations setGHCiState $ st { breaks = rest } -turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation +turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation turnBreakOnOff onOff loc | onOff == breakEnabled loc = return loc | otherwise = do - (arr, _, _) <- getModBreak (breakModule loc) - hsc_env <- GHC.getSession - liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff + setBreakFlag (breakModule loc) (breakTick loc) onOff return loc { breakEnabled = onOff } getModBreak :: GHC.GhcMonad m - => Module -> m (ForeignRef BreakArray, Array Int SrcSpan, Array Int [String]) + => Module -> m (Array Int SrcSpan, Array Int [String]) getModBreak m = do mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info - let arr = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks let decls = GHC.modBreaks_decls modBreaks - return (arr, ticks, decls) + return (ticks, decls) -setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m () -setBreakFlag toggle arr i = do - hsc_env <- GHC.getSession - liftIO $ enableBreakpoint hsc_env arr i toggle +setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m () +setBreakFlag md ix enaDisa = do + let enaDisaToCount True = breakOn + enaDisaToCount False = breakOff + setupBreakpoint (GHC.BreakInfo md ix) $ enaDisaToCount enaDisa -- --------------------------------------------------------------------------- -- User code exception handling diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index ed06d81d75..80d4539849 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -404,14 +404,14 @@ runDecls' decls = do return Nothing) (Just <$> GHC.runParsedDecls decls) -resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult -resume canLogSpan step = do +resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult +resume canLogSpan step mbIgnoreCnt = do st <- getGHCiState reifyGHCi $ \x -> withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.resumeExec canLogSpan step + GHC.resumeExec canLogSpan step mbIgnoreCnt -- -------------------------------------------------------------------------- -- timing & statistics diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index 18c1d96b30..51bf3466eb 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -7,12 +7,17 @@ -- -- | Break Arrays -- --- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish) +-- An array of words, indexed by a breakpoint number (breakpointId in Tickish) +-- containing the ignore count for every breakpopint. -- There is one of these arrays per module. -- --- Each byte is --- 1 if the corresponding breakpoint is enabled --- 0 otherwise +-- For each word with value n: +-- n > 1 : the corresponding breakpoint is enabled. Next time the bp is hit, +-- GHCi will decrement the ignore count and continue processing. +-- n == 0 : The breakpoint is enabled, GHCi will stop next time it hits +-- this breakpoint. +-- n == -1: This breakpoint is disabled. +-- n < -1 : Not used. -- ------------------------------------------------------------------------------- @@ -22,25 +27,26 @@ module GHCi.BreakArray (BA) -- constructor is exported only for GHC.CoreToByteCode , newBreakArray , getBreak - , setBreakOn - , setBreakOff + , setupBreakpoint + , breakOn + , breakOff , showBreakArray ) where import Prelude -- See note [Why do we import Prelude here?] import Control.Monad -import Data.Word -import GHC.Word import GHC.Exts import GHC.IO ( IO(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) +#include "MachDeps.h" + data BreakArray = BA (MutableByteArray# RealWorld) -breakOff, breakOn :: Word8 -breakOn = 1 -breakOff = 0 +breakOff, breakOn :: Int +breakOn = 0 +breakOff = -1 showBreakArray :: BreakArray -> IO () showBreakArray array = do @@ -49,21 +55,14 @@ showBreakArray array = do putStr $ ' ' : show val putStr "\n" -setBreakOn :: BreakArray -> Int -> IO Bool -setBreakOn array index - | safeIndex array index = do - writeBreakArray array index breakOn - return True - | otherwise = return False - -setBreakOff :: BreakArray -> Int -> IO Bool -setBreakOff array index - | safeIndex array index = do - writeBreakArray array index breakOff - return True +setupBreakpoint :: BreakArray -> Int -> Int -> IO Bool +setupBreakpoint breakArray ind val + | safeIndex breakArray ind = do + writeBreakArray breakArray ind val + return True | otherwise = return False -getBreak :: BreakArray -> Int -> IO (Maybe Word8) +getBreak :: BreakArray -> Int -> IO (Maybe Int) getBreak array index | safeIndex array index = do val <- readBreakArray array index @@ -74,7 +73,7 @@ safeIndex :: BreakArray -> Int -> Bool safeIndex array index = index < size array && index >= 0 size :: BreakArray -> Int -size (BA array) = size +size (BA array) = size `div` SIZEOF_HSWORD where -- We want to keep this operation pure. The mutable byte array -- is never resized so this is safe. @@ -85,31 +84,31 @@ size (BA array) = size IO $ \s -> case getSizeofMutableByteArray# arr s of (# s', n# #) -> (# s', I# n# #) -allocBA :: Int -> IO BreakArray -allocBA (I# sz) = IO $ \s1 -> - case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } +allocBA :: Int# -> IO BreakArray +allocBA sz# = IO $ \s1 -> + case newByteArray# sz# s1 of { (# s2, array #) -> (# s2, BA array #) } --- create a new break array and initialise elements to zero +-- create a new break array and initialise all elements to breakOff. newBreakArray :: Int -> IO BreakArray -newBreakArray entries@(I# sz) = do - BA array <- allocBA entries +newBreakArray (I# sz#) = do + BA array <- allocBA (sz# *# SIZEOF_HSWORD#) case breakOff of - off -> do - let loop n | isTrue# (n ==# sz) = return () + I# off -> do + let loop n | isTrue# (n >=# sz#) = return () | otherwise = do writeBA# array n off; loop (n +# 1#) loop 0# return $ BA array -writeBA# :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeBA# array i (W8# w) = IO $ \s -> - case writeWord8Array# array i w s of { s -> (# s, () #) } +writeBA# :: MutableByteArray# RealWorld -> Int# -> Int# -> IO () +writeBA# array ind val = IO $ \s -> + case writeIntArray# array ind val s of { s -> (# s, () #) } -writeBreakArray :: BreakArray -> Int -> Word8 -> IO () -writeBreakArray (BA array) (I# i) word = writeBA# array i word +writeBreakArray :: BreakArray -> Int -> Int -> IO () +writeBreakArray (BA array) (I# i) (I# val) = writeBA# array i val -readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8 +readBA# :: MutableByteArray# RealWorld -> Int# -> IO Int readBA# array i = IO $ \s -> - case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) } + case readIntArray# array i s of { (# s, c #) -> (# s, I# c #) } -readBreakArray :: BreakArray -> Int -> IO Word8 -readBreakArray (BA array) (I# i) = readBA# array i +readBreakArray :: BreakArray -> Int -> IO Int +readBreakArray (BA array) (I# ind# ) = readBA# array ind# diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 1018242210..d5f8e84520 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -162,11 +162,13 @@ data Message a where :: Int -- size -> Message (RemoteRef BreakArray) - -- | Enable a breakpoint - EnableBreakpoint + -- | Set how many times a breakpoint should be ignored + -- also used for enable/disable + SetupBreakpoint :: RemoteRef BreakArray - -> Int -- index - -> Bool -- on or off + -> Int -- breakpoint index + -> Int -- ignore count to be stored in the BreakArray + -- -1 disable; 0 enable; >= 1 enable, ignore count. -> Message () -- | Query the status of a breakpoint (True <=> enabled) @@ -505,7 +507,7 @@ getMessage = do 25 -> Msg <$> (MkCostCentres <$> get <*> get) 26 -> Msg <$> (CostCentreStackInfo <$> get) 27 -> Msg <$> (NewBreakArray <$> get) - 28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get) + 28 -> Msg <$> (SetupBreakpoint <$> get <*> get <*> get) 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH @@ -548,7 +550,7 @@ putMessage m = case m of MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs CostCentreStackInfo ptr -> putWord8 26 >> put ptr NewBreakArray sz -> putWord8 27 >> put sz - EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b + SetupBreakpoint arr ix cnt -> putWord8 28 >> put arr >> put ix >> put cnt BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index 858c312b34..4ecb64620a 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -73,15 +73,15 @@ run m = case m of MkCostCentres mod ccs -> mkCostCentres mod ccs CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz - EnableBreakpoint ref ix b -> do - arr <- localRef ref - _ <- if b then setBreakOn arr ix else setBreakOff arr ix + SetupBreakpoint ref ix cnt -> do + arr <- localRef ref; + _ <- setupBreakpoint arr ix cnt return () BreakpointStatus ref ix -> do arr <- localRef ref; r <- getBreak arr ix case r of Nothing -> return False - Just w -> return (w /= 0) + Just w -> return (w == 0) GetBreakpointVar ref ix -> do aps <- localRef ref mapM mkRemoteRef =<< getIdValFromApStack aps ix diff --git a/rts/Interpreter.c b/rts/Interpreter.c index cdfd7684ed..6929aec5fd 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -1068,11 +1068,14 @@ run_BCO: // stop the current thread if either the // "rts_stop_next_breakpoint" flag is true OR if the - // breakpoint flag for this particular expression is - // true - if (rts_stop_next_breakpoint == true || - ((StgWord8*)breakPoints->payload)[arg2_array_index] - == true) + // ignore count for this particular breakpoint is zero + StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg2_array_index]; + if (rts_stop_next_breakpoint == false && ignore_count > 0) + { + // decrement and write back ignore count + ((StgInt*)breakPoints->payload)[arg2_array_index] = --ignore_count; + } + else if (rts_stop_next_breakpoint == true || ignore_count == 0) { // make sure we don't automatically stop at the // next breakpoint diff --git a/testsuite/tests/ghci.debugger/scripts/T19157.hs b/testsuite/tests/ghci.debugger/scripts/T19157.hs new file mode 100644 index 0000000000..d844a31e7e --- /dev/null +++ b/testsuite/tests/ghci.debugger/scripts/T19157.hs @@ -0,0 +1,8 @@ +module T19157 where + +mySum :: [Int] -> Int +mySum lst = go 0 lst + where + go :: Int -> [Int] -> Int + go sum [] = sum + go sum (s : ss) = go (sum + s) ss diff --git a/testsuite/tests/ghci.debugger/scripts/T19157.script b/testsuite/tests/ghci.debugger/scripts/T19157.script new file mode 100644 index 0000000000..edcad557d5 --- /dev/null +++ b/testsuite/tests/ghci.debugger/scripts/T19157.script @@ -0,0 +1,20 @@ +:l T19157 +:break mySum.go +putStrLn "---------------------- Test 1" +mySum [1,2,3,4,5,6] +:cont 2 +:cont 1 +:cont +:cont +putStrLn "---------------------- Test 2" +:ig 1 1000 +mySum [1..2000] +putStrLn "---------------------- Test 3" +:continue q +:continue -1 +:cont 3 4 +:ig a 5 +:ignore 5 a +:ignore 0 +:ignore 1 2 3 4 +:ignore 0 -1 diff --git a/testsuite/tests/ghci.debugger/scripts/T19157.stdout b/testsuite/tests/ghci.debugger/scripts/T19157.stdout new file mode 100644 index 0000000000..f0ac09d7f4 --- /dev/null +++ b/testsuite/tests/ghci.debugger/scripts/T19157.stdout @@ -0,0 +1,41 @@ +Breakpoint 0 activated at T19157.hs:7:17-19 +Breakpoint 1 activated at T19157.hs:8:23-37 +---------------------- Test 1 +Stopped in T19157.mySum.go, T19157.hs:8:23-37 +_result :: Int = _ +go :: Int -> [Int] -> Int = _ +s :: Int = 1 +ss :: [Int] = [2,3,4,5,6] +sum :: Int = 0 +Stopped in T19157.mySum.go, T19157.hs:8:23-37 +_result :: Int = _ +go :: Int -> [Int] -> Int = _ +s :: Int = 4 +ss :: [Int] = [5,6] +sum :: Int = _ +Stopped in T19157.mySum.go, T19157.hs:8:23-37 +_result :: Int = _ +go :: Int -> [Int] -> Int = _ +s :: Int = 6 +ss :: [Int] = [] +sum :: Int = _ +Stopped in T19157.mySum.go, T19157.hs:7:17-19 +_result :: Int = _ +sum :: Int = _ +21 +---------------------- Test 2 +Stopped in T19157.mySum.go, T19157.hs:8:23-37 +_result :: Int = _ +go :: Int -> [Int] -> Int = _ +s :: Int = 1001 +ss :: [Int] = _ +sum :: Int = _ +---------------------- Test 3 +Ignore count ‘q’ is not numeric +Ignore count ‘-1’ must be >= 0 +After ':continue' only one ignore count is allowed +Breakpoint a not found +Breakpoint 5 not found +Syntax: :ignore <breaknum> <count> +Syntax: :ignore <breaknum> <count> +Ignore count ‘-1’ must be >= 0 diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T index 30e5c4312c..489fa89d36 100644 --- a/testsuite/tests/ghci.debugger/scripts/all.T +++ b/testsuite/tests/ghci.debugger/scripts/all.T @@ -125,3 +125,4 @@ test('T16700', normal, ghci_script, ['T16700.script']) test('break029', extra_files(['break029.hs']), ghci_script, ['break029.script']) test('T2215', normal, ghci_script, ['T2215.script']) test('T17989', normal, ghci_script, ['T17989.script']) +test('T19157', normal, ghci_script, ['T19157.script']) |