summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs3
-rw-r--r--compiler/GHC/Runtime/Eval.hs21
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs8
-rw-r--r--docs/users_guide/9.2.1-notes.rst13
-rw-r--r--docs/users_guide/ghci.rst28
-rw-r--r--ghc/GHCi/UI.hs123
-rw-r--r--ghc/GHCi/UI/Monad.hs6
-rw-r--r--libraries/ghci/GHCi/BreakArray.hs83
-rw-r--r--libraries/ghci/GHCi/Message.hs14
-rw-r--r--libraries/ghci/GHCi/Run.hs8
-rw-r--r--rts/Interpreter.c13
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T19157.hs8
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T19157.script20
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T19157.stdout41
-rw-r--r--testsuite/tests/ghci.debugger/scripts/all.T1
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'])
View Lorry Controller Status