Commit 17f848e1 authored by Simon Marlow's avatar Simon Marlow

GHCi debugger: new flag -fbreak-on-exception

When -fbreak-on-exception is set, an exception will cause GHCi to
suspend the current computation and return to the prompt, where the
history of the current evaluation can be inspected (if we are in
:trace).  This isn't on by default, because the behaviour could be
confusing: for example, ^C will cause a breakpoint.  It can be very
useful for finding the cause of a "head []" or a "fromJust Nothing",
though.
parent fb80639a
......@@ -570,12 +570,12 @@ afterRunStmt run_result = do
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ mapM_ (showTypeOfName session) names
GHC.RunBreak _ names info -> do
GHC.RunBreak _ names mb_info -> do
resumes <- io $ GHC.getResumeContext session
printForUser $ ptext SLIT("Stopped at") <+>
ppr (GHC.resumeSpan (head resumes))
mapM_ (showTypeOfName session) names
runBreakCmd info
maybe (return ()) runBreakCmd mb_info
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
......@@ -1695,7 +1695,8 @@ listCmd "" = do
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
Just span -> io $ listAround span True
Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
| otherwise -> printForUser $ text "unable to list source for" <+> ppr span
listCmd str = list2 (words str)
list2 [arg] | all isDigit arg = do
......
......@@ -210,6 +210,7 @@ data DynFlag
| Opt_PrintBindResult
| Opt_Haddock
| Opt_Hpc_No_Auto
| Opt_BreakOnException
-- keeping stuff
| Opt_KeepHiDiffs
......@@ -1079,7 +1080,8 @@ fFlags = [
( "print-bind-result", Opt_PrintBindResult ),
( "force-recomp", Opt_ForceRecomp ),
( "hpc-no-auto", Opt_Hpc_No_Auto ),
( "rewrite-rules", Opt_RewriteRules )
( "rewrite-rules", Opt_RewriteRules ),
( "break-on-exception", Opt_BreakOnException )
]
......
......@@ -70,7 +70,9 @@ import Outputable
import Data.Dynamic
import Control.Monad
import Foreign
import Foreign.C
import GHC.Exts
import GHC.Conc ( ThreadId(..) )
import Data.Array
import Control.Exception as Exception
import Control.Concurrent
......@@ -84,11 +86,11 @@ data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception
| RunBreak ThreadId [Name] BreakInfo
| RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status
= Break HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint
= Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception)
| Complete (Either Exception [HValue])
-- ^ the computation completed with either an exception or a value
......@@ -102,7 +104,9 @@ data Resume
resumeFinalIds :: [Id], -- [Id] to bind on completion
resumeApStack :: HValue, -- The object from which we can get
-- value of the free variables.
resumeBreakInfo :: BreakInfo, -- the breakpoint we stopped at.
resumeBreakInfo :: Maybe BreakInfo,
-- the breakpoint we stopped at
-- (Nothing <=> exception)
resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
-- to fetch the ModDetails & ModBreaks
-- to get this.
......@@ -135,28 +139,6 @@ getHistorySpan s hist = withSession s $ \hsc_env -> do
Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
_ -> panic "getHistorySpan"
{-
[Main.hs:42:(1,0)-(3,52)] *Main> :history 2
Foo.hs:1:3-5
Bar.hs:5:23-48
[Main.hs:42:(1,0)-(3,52)] *Main> :back
Logged breakpoint at Foo.hs:1:3-5
x :: Int
y :: a
_result :: [Char]
[-1: Foo.hs:1:3-5] *Main> :back
Logged breakpoint at Bar.hs:5:23-48
z :: a
_result :: Float
[-2: Bar.hs:5:23-48] *Main> :forward
Logged breakpoint at Foo.hs:1:3-5
x :: Int
y :: a
_result :: [Char]
[-1: Foo.hs:1:3-5] *Main> :cont
.. continues
-}
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: Session -> String -> SingleStep -> IO RunResult
......@@ -178,13 +160,7 @@ runStmt (Session ref) expr step
Nothing -> return RunFailed
Just (ids, hval) -> do
when (isStep step) $ setStepFlag
-- set the onBreakAction to be performed when we hit a
-- breakpoint this is visible in the Byte Code
-- Interpreter, thus it is a global variable,
-- implemented with stable pointers
withBreakAction breakMVar statusMVar $ do
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
status <- sandboxIO statusMVar thing_to_run
......@@ -207,17 +183,20 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
history =
case status of
-- did we hit a breakpoint or did we complete?
(Break apStack info tid) -> do
(Break is_exception apStack info tid) -> do
hsc_env <- readIORef ref
(hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env apStack info
let mb_info | is_exception = Nothing
| otherwise = Just info
(hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
apStack mb_info
let
resume = Resume expr tid breakMVar statusMVar
bindings final_ids apStack info span
bindings final_ids apStack mb_info span
(toListBL history) 0
hsc_env2 = pushResume hsc_env1 resume
--
writeIORef ref hsc_env2
return (RunBreak tid names info)
return (RunBreak tid names mb_info)
(Complete either_hvals) ->
case either_hvals of
Left e -> return (RunException e)
......@@ -238,7 +217,7 @@ traceRunStatus expr ref bindings final_ids
case status of
-- when tracing, if we hit a breakpoint that is not explicitly
-- enabled, then we just log the event in the history and continue.
(Break apStack info tid) -> do
(Break is_exception apStack info tid) | not is_exception -> do
b <- isBreakEnabled hsc_env info
if b
then handle_normally
......@@ -247,8 +226,8 @@ traceRunStatus expr ref bindings final_ids
-- probably better make history strict here, otherwise
-- our BoundedList will be pointless.
evaluate history'
setStepFlag
status <- withBreakAction breakMVar statusMVar $ do
status <- withBreakAction True (hsc_dflags hsc_env)
breakMVar statusMVar $ do
withInterruptsSentTo
(do putMVar breakMVar () -- awaken the stopped thread
return tid)
......@@ -273,11 +252,15 @@ isBreakEnabled hsc_env inf =
return False
foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
setStepFlag = poke stepFlag 1
resetStepFlag = poke stepFlag 0
-- this points to the IO action that is executed when a breakpoint is hit
foreign import ccall "&breakPointIOAction"
breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ()))
foreign import ccall "&rts_breakpoint_io_action"
breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
-- When running a computation, we redirect ^C exceptions to the running
-- thread. ToDo: we might want a way to continue even if the target
......@@ -297,25 +280,38 @@ withInterruptsSentTo io get_result = do
putMVar interruptTargetThread (child:ts)
get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
withBreakAction breakMVar statusMVar io
-- This function sets up the interpreter for catching breakpoints, and
-- resets everything when the computation has stopped running. This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
withBreakAction step dflags breakMVar statusMVar io
= bracket setBreakAction resetBreakAction (\_ -> io)
where
setBreakAction = do
stablePtr <- newStablePtr onBreak
poke breakPointIOAction stablePtr
when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
when step $ setStepFlag
return stablePtr
-- Breaking on exceptions is not enabled by default, since it
-- might be a bit surprising. The exception flag is turned off
-- as soon as it is hit, or in resetBreakAction below.
onBreak info apStack = do
onBreak is_exception info apStack = do
tid <- myThreadId
putMVar statusMVar (Break apStack info tid)
putMVar statusMVar (Break is_exception apStack info tid)
takeMVar breakMVar
resetBreakAction stablePtr = do
poke breakPointIOAction noBreakStablePtr
poke exceptionFlag 0
resetStepFlag
freeStablePtr stablePtr
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
noBreakAction True info apStack = return () -- exception: just continue
resume :: Session -> SingleStep -> IO RunResult
resume (Session ref) step
......@@ -346,7 +342,8 @@ resume (Session ref) step
case r of
Resume expr tid breakMVar statusMVar bindings
final_ids apStack info _ _ _ -> do
withBreakAction breakMVar statusMVar $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- withInterruptsSentTo
(do putMVar breakMVar ()
-- this awakens the stopped thread...
......@@ -377,15 +374,15 @@ moveHist fn (Session ref) = do
history = resumeHistory r
new_ix = fn ix
--
when (new_ix >= length history) $
when (new_ix > length history) $
throwDyn (ProgramError "no more logged breakpoints")
when (new_ix < 0) $
throwDyn (ProgramError "already at the beginning of the history")
let
update_ic apStack info = do
update_ic apStack mb_info = do
(hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
apStack info
apStack mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
......@@ -400,11 +397,11 @@ moveHist fn (Session ref) = do
if new_ix == 0
then case r of
Resume { resumeApStack = apStack,
resumeBreakInfo = info } ->
update_ic apStack info
resumeBreakInfo = mb_info } ->
update_ic apStack mb_info
else case history !! (new_ix - 1) of
History apStack info ->
update_ic apStack info
update_ic apStack (Just info)
-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
......@@ -412,9 +409,34 @@ moveHist fn (Session ref) = do
bindLocalsAtBreakpoint
:: HscEnv
-> HValue
-> BreakInfo
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan)
bindLocalsAtBreakpoint hsc_env apStack info = do
-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint. We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
let exn_fs = FSLIT("_exception")
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = FSLIT("e")
e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
vanillaIdInfo
new_tyvars = unitVarSet e_tyvar
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
span = mkGeneralSrcSpan FSLIT("<exception thrown>")
--
Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
let
mod_name = moduleName (breakInfo_module info)
......
......@@ -99,6 +99,11 @@ extern void setIOManagerPipe (int fd);
extern void* allocateExec(unsigned int len);
// Breakpoint stuff
extern int rts_stop_next_breakpoint;
extern int rts_stop_on_exception;
extern HsStablePtr rts_breakpoint_io_action;
/* -----------------------------------------------------------------------------
Storage manager stuff exported
-------------------------------------------------------------------------- */
......
......@@ -118,6 +118,7 @@ RTS_INFO(stg_AP_info);
RTS_INFO(stg_AP_STACK_info);
RTS_INFO(stg_dummy_ret_info);
RTS_INFO(stg_raise_info);
RTS_INFO(stg_raise_ret_info);
RTS_INFO(stg_TVAR_WATCH_QUEUE_info);
RTS_INFO(stg_INVARIANT_CHECK_QUEUE_info);
RTS_INFO(stg_ATOMIC_INVARIANT_info);
......
......@@ -352,13 +352,26 @@ INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
jump raisezh_fast;
}
section "data" {
no_break_on_exception: W_[1];
}
INFO_TABLE_RET(stg_raise_ret, 1, 0, RET_SMALL)
{
R1 = Sp(1);
Sp = Sp + WDS(2);
W_[no_break_on_exception] = 1;
jump raisezh_fast;
}
raisezh_fast
{
W_ handler;
W_ raise_closure;
W_ frame_type;
W_ exception;
/* args : R1 :: Exception */
exception = R1;
#if defined(PROFILING)
/* Debugging tool: on raising an exception, show where we are. */
......@@ -367,16 +380,39 @@ raisezh_fast
* the info was only displayed for an *uncaught* exception.
*/
if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
foreign "C" fprintCCS_stderr(W_[CCCS] "ptr") [];
}
#endif
if (W_[no_break_on_exception] != 0) {
W_[no_break_on_exception] = 0;
} else {
if (TO_W_(CInt[rts_stop_on_exception]) != 0) {
W_ ioAction;
// we don't want any further exceptions to be caught,
// until GHCi is ready to handle them. This prevents
// deadlock if an exception is raised in InteractiveUI,
// for exmplae. Perhaps the stop_on_exception flag should
// be per-thread.
W_[rts_stop_on_exception] = 0;
"ptr" ioAction = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
Sp = Sp - WDS(6);
Sp(5) = exception;
Sp(4) = stg_raise_ret_info;
Sp(3) = exception; // the AP_STACK
Sp(2) = base_GHCziBase_True_closure; // dummy breakpoint info
Sp(1) = base_GHCziBase_True_closure; // True <=> a breakpoint
R1 = ioAction;
jump stg_ap_pppv_info;
}
}
/* Inform the Hpc that an exception has been thrown */
foreign "C" hs_hpc_raise_event(CurrentTSO "ptr");
foreign "C" hs_hpc_raise_event(CurrentTSO "ptr") [];
retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp;
frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", R1 "ptr");
frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
Sp = StgTSO_sp(CurrentTSO);
if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that
......@@ -390,14 +426,14 @@ retry_pop_stack:
W_ trec, outer;
W_ r;
trec = StgTSO_trec(CurrentTSO);
r = foreign "C" stmValidateNestOfTransactions(trec "ptr");
r = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
"ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
if (outer != NO_TREC) {
foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr");
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr");
foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr") [];
}
StgTSO_trec(CurrentTSO) = NO_TREC;
......@@ -408,7 +444,7 @@ retry_pop_stack:
} else {
// Transaction was not valid: we retry the exception (otherwise continue
// with a further call to raiseExceptionHelper)
"ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
"ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
R1 = StgAtomicallyFrame_code(Sp);
jump stg_ap_v_fast;
......@@ -423,7 +459,7 @@ retry_pop_stack:
*/
Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack
+ WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
Sp(1) = R1; /* save the exception */
Sp(1) = exception; /* save the exception */
Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
SAVE_THREAD_STATE(); /* inline! */
......@@ -477,7 +513,7 @@ retry_pop_stack:
* token as arguments.
*/
Sp_adj(-1);
Sp(0) = R1;
Sp(0) = exception;
R1 = handler;
Sp_adj(-1);
TICK_UNKNOWN_CALL();
......
......@@ -16,6 +16,7 @@
#include "Updates.h"
#include "Sanity.h"
#include "Liveness.h"
#include "Prelude.h"
#include "Bytecodes.h"
#include "Printer.h"
......@@ -83,7 +84,8 @@ allocate_NONUPD (int n_words)
return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
}
rtsBool stop_next_breakpoint = rtsFalse;
int rts_stop_next_breakpoint = 0;
int rts_stop_on_exception = 0;
#ifdef INTERP_STATS
......@@ -177,7 +179,7 @@ static StgWord app_ptrs_itbl[] = {
(W_)&stg_ap_pppppp_info,
};
HsStablePtr breakPointIOAction; // points to the IO action which is executed on a breakpoint
HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint
// it is set in main/GHC.hs:runStmt
Capability *
......@@ -809,15 +811,15 @@ run_BCO:
breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
// stop the current thread if either the
// "stop_next_breakpoint" flag is true OR if the
// "rts_stop_next_breakpoint" flag is true OR if the
// breakpoint flag for this particular expression is
// true
if (stop_next_breakpoint == rtsTrue ||
if (rts_stop_next_breakpoint == rtsTrue ||
breakPoints->payload[arg2_array_index] == rtsTrue)
{
// make sure we don't automatically stop at the
// next breakpoint
stop_next_breakpoint = rtsFalse;
rts_stop_next_breakpoint = rtsFalse;
// allocate memory for a new AP_STACK, enough to
// store the top stack frame plus an
......@@ -840,16 +842,17 @@ run_BCO:
}
// prepare the stack so that we can call the
// breakPointIOAction and ensure that the stack is
// rts_breakpoint_io_action and ensure that the stack is
// in a reasonable state for the GC and so that
// execution of this BCO can continue when we resume
ioAction = (StgClosure *) deRefStablePtr (breakPointIOAction);
Sp -= 7;
Sp[6] = (W_)obj;
Sp[5] = (W_)&stg_apply_interp_info;
Sp[4] = (W_)new_aps; // the AP_STACK
Sp[3] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
Sp[2] = (W_)&stg_ap_ppv_info;
ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action);
Sp -= 8;
Sp[7] = (W_)obj;
Sp[6] = (W_)&stg_apply_interp_info;
Sp[5] = (W_)new_aps; // the AP_STACK
Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint
Sp[3] = (W_)False_closure; // True <=> a breakpoint
Sp[2] = (W_)&stg_ap_pppv_info;
Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above
Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action
......@@ -1374,13 +1377,3 @@ run_BCO:
barf("interpretBCO: fell off end of the interpreter");
}
/* set the single step flag for the debugger to True -
it gets set back to false in the interpreter everytime
we hit a breakpoint
*/
void rts_setStepFlag (void);
void rts_setStepFlag (void)
{
stop_next_breakpoint = rtsTrue;
}
......@@ -710,8 +710,7 @@ typedef struct _RtsSymbolVal {
SymX(getAllocations) \
SymX(revertCAFs) \
SymX(RtsFlags) \
Sym(breakPointIOAction) \
Sym(rts_setStepFlag) \
SymX(rts_breakpoint_io_action) \
RTS_USER_SIGNALS_SYMBOLS
#ifdef SUPPORT_LONG_LONGS
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment