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

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 ...@@ -570,12 +570,12 @@ afterRunStmt run_result = do
GHC.RunOk names -> do GHC.RunOk names -> do
show_types <- isOptionSet ShowType show_types <- isOptionSet ShowType
when show_types $ mapM_ (showTypeOfName session) names when show_types $ mapM_ (showTypeOfName session) names
GHC.RunBreak _ names info -> do GHC.RunBreak _ names mb_info -> do
resumes <- io $ GHC.getResumeContext session resumes <- io $ GHC.getResumeContext session
printForUser $ ptext SLIT("Stopped at") <+> printForUser $ ptext SLIT("Stopped at") <+>
ppr (GHC.resumeSpan (head resumes)) ppr (GHC.resumeSpan (head resumes))
mapM_ (showTypeOfName session) names mapM_ (showTypeOfName session) names
runBreakCmd info maybe (return ()) runBreakCmd mb_info
-- run the command set with ":set stop <cmd>" -- run the command set with ":set stop <cmd>"
st <- getGHCiState st <- getGHCiState
enqueueCommands [stop st] enqueueCommands [stop st]
...@@ -1695,7 +1695,8 @@ listCmd "" = do ...@@ -1695,7 +1695,8 @@ listCmd "" = do
mb_span <- getCurrentBreakSpan mb_span <- getCurrentBreakSpan
case mb_span of case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list" 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) listCmd str = list2 (words str)
list2 [arg] | all isDigit arg = do list2 [arg] | all isDigit arg = do
......
...@@ -210,6 +210,7 @@ data DynFlag ...@@ -210,6 +210,7 @@ data DynFlag
| Opt_PrintBindResult | Opt_PrintBindResult
| Opt_Haddock | Opt_Haddock
| Opt_Hpc_No_Auto | Opt_Hpc_No_Auto
| Opt_BreakOnException
-- keeping stuff -- keeping stuff
| Opt_KeepHiDiffs | Opt_KeepHiDiffs
...@@ -1079,7 +1080,8 @@ fFlags = [ ...@@ -1079,7 +1080,8 @@ fFlags = [
( "print-bind-result", Opt_PrintBindResult ), ( "print-bind-result", Opt_PrintBindResult ),
( "force-recomp", Opt_ForceRecomp ), ( "force-recomp", Opt_ForceRecomp ),
( "hpc-no-auto", Opt_Hpc_No_Auto ), ( "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 ...@@ -70,7 +70,9 @@ import Outputable
import Data.Dynamic import Data.Dynamic
import Control.Monad import Control.Monad
import Foreign import Foreign
import Foreign.C
import GHC.Exts import GHC.Exts
import GHC.Conc ( ThreadId(..) )
import Data.Array import Data.Array
import Control.Exception as Exception import Control.Exception as Exception
import Control.Concurrent import Control.Concurrent
...@@ -84,11 +86,11 @@ data RunResult ...@@ -84,11 +86,11 @@ data RunResult
= RunOk [Name] -- ^ names bound by this evaluation = RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation | RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception | RunException Exception -- ^ statement raised an exception
| RunBreak ThreadId [Name] BreakInfo | RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status data Status
= Break HValue BreakInfo ThreadId = Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint -- ^ the computation hit a breakpoint (Bool <=> was an exception)
| Complete (Either Exception [HValue]) | Complete (Either Exception [HValue])
-- ^ the computation completed with either an exception or a value -- ^ the computation completed with either an exception or a value
...@@ -102,7 +104,9 @@ data Resume ...@@ -102,7 +104,9 @@ data Resume
resumeFinalIds :: [Id], -- [Id] to bind on completion resumeFinalIds :: [Id], -- [Id] to bind on completion
resumeApStack :: HValue, -- The object from which we can get resumeApStack :: HValue, -- The object from which we can get
-- value of the free variables. -- 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 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
-- to fetch the ModDetails & ModBreaks -- to fetch the ModDetails & ModBreaks
-- to get this. -- to get this.
...@@ -135,28 +139,6 @@ getHistorySpan s hist = withSession s $ \hsc_env -> do ...@@ -135,28 +139,6 @@ getHistorySpan s hist = withSession s $ \hsc_env -> do
Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num) Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
_ -> panic "getHistorySpan" _ -> 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 -- | Run a statement in the current interactive context. Statement
-- may bind multple values. -- may bind multple values.
runStmt :: Session -> String -> SingleStep -> IO RunResult runStmt :: Session -> String -> SingleStep -> IO RunResult
...@@ -178,13 +160,7 @@ runStmt (Session ref) expr step ...@@ -178,13 +160,7 @@ runStmt (Session ref) expr step
Nothing -> return RunFailed Nothing -> return RunFailed
Just (ids, hval) -> do Just (ids, hval) -> do
when (isStep step) $ setStepFlag withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
-- 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
let thing_to_run = unsafeCoerce# hval :: IO [HValue] let thing_to_run = unsafeCoerce# hval :: IO [HValue]
status <- sandboxIO statusMVar thing_to_run status <- sandboxIO statusMVar thing_to_run
...@@ -207,17 +183,20 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status ...@@ -207,17 +183,20 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
history = history =
case status of case status of
-- did we hit a breakpoint or did we complete? -- 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_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 let
resume = Resume expr tid breakMVar statusMVar resume = Resume expr tid breakMVar statusMVar
bindings final_ids apStack info span bindings final_ids apStack mb_info span
(toListBL history) 0 (toListBL history) 0
hsc_env2 = pushResume hsc_env1 resume hsc_env2 = pushResume hsc_env1 resume
-- --
writeIORef ref hsc_env2 writeIORef ref hsc_env2
return (RunBreak tid names info) return (RunBreak tid names mb_info)
(Complete either_hvals) -> (Complete either_hvals) ->
case either_hvals of case either_hvals of
Left e -> return (RunException e) Left e -> return (RunException e)
...@@ -238,7 +217,7 @@ traceRunStatus expr ref bindings final_ids ...@@ -238,7 +217,7 @@ traceRunStatus expr ref bindings final_ids
case status of case status of
-- when tracing, if we hit a breakpoint that is not explicitly -- when tracing, if we hit a breakpoint that is not explicitly
-- enabled, then we just log the event in the history and continue. -- 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 b <- isBreakEnabled hsc_env info
if b if b
then handle_normally then handle_normally
...@@ -247,8 +226,8 @@ traceRunStatus expr ref bindings final_ids ...@@ -247,8 +226,8 @@ traceRunStatus expr ref bindings final_ids
-- probably better make history strict here, otherwise -- probably better make history strict here, otherwise
-- our BoundedList will be pointless. -- our BoundedList will be pointless.
evaluate history' evaluate history'
setStepFlag status <- withBreakAction True (hsc_dflags hsc_env)
status <- withBreakAction breakMVar statusMVar $ do breakMVar statusMVar $ do
withInterruptsSentTo withInterruptsSentTo
(do putMVar breakMVar () -- awaken the stopped thread (do putMVar breakMVar () -- awaken the stopped thread
return tid) return tid)
...@@ -273,11 +252,15 @@ isBreakEnabled hsc_env inf = ...@@ -273,11 +252,15 @@ isBreakEnabled hsc_env inf =
return False 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 -- this points to the IO action that is executed when a breakpoint is hit
foreign import ccall "&breakPointIOAction" foreign import ccall "&rts_breakpoint_io_action"
breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
-- When running a computation, we redirect ^C exceptions to the running -- When running a computation, we redirect ^C exceptions to the running
-- thread. ToDo: we might want a way to continue even if the target -- thread. ToDo: we might want a way to continue even if the target
...@@ -297,25 +280,38 @@ withInterruptsSentTo io get_result = do ...@@ -297,25 +280,38 @@ withInterruptsSentTo io get_result = do
putMVar interruptTargetThread (child:ts) putMVar interruptTargetThread (child:ts)
get_result `finally` modifyMVar_ interruptTargetThread (return.tail) 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) = bracket setBreakAction resetBreakAction (\_ -> io)
where where
setBreakAction = do setBreakAction = do
stablePtr <- newStablePtr onBreak stablePtr <- newStablePtr onBreak
poke breakPointIOAction stablePtr poke breakPointIOAction stablePtr
when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
when step $ setStepFlag
return stablePtr 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 tid <- myThreadId
putMVar statusMVar (Break apStack info tid) putMVar statusMVar (Break is_exception apStack info tid)
takeMVar breakMVar takeMVar breakMVar
resetBreakAction stablePtr = do resetBreakAction stablePtr = do
poke breakPointIOAction noBreakStablePtr poke breakPointIOAction noBreakStablePtr
poke exceptionFlag 0
resetStepFlag
freeStablePtr stablePtr freeStablePtr stablePtr
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction 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 -> SingleStep -> IO RunResult
resume (Session ref) step resume (Session ref) step
...@@ -346,7 +342,8 @@ resume (Session ref) step ...@@ -346,7 +342,8 @@ resume (Session ref) step
case r of case r of
Resume expr tid breakMVar statusMVar bindings Resume expr tid breakMVar statusMVar bindings
final_ids apStack info _ _ _ -> do final_ids apStack info _ _ _ -> do
withBreakAction breakMVar statusMVar $ do withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- withInterruptsSentTo status <- withInterruptsSentTo
(do putMVar breakMVar () (do putMVar breakMVar ()
-- this awakens the stopped thread... -- this awakens the stopped thread...
...@@ -377,15 +374,15 @@ moveHist fn (Session ref) = do ...@@ -377,15 +374,15 @@ moveHist fn (Session ref) = do
history = resumeHistory r history = resumeHistory r
new_ix = fn ix new_ix = fn ix
-- --
when (new_ix >= length history) $ when (new_ix > length history) $
throwDyn (ProgramError "no more logged breakpoints") throwDyn (ProgramError "no more logged breakpoints")
when (new_ix < 0) $ when (new_ix < 0) $
throwDyn (ProgramError "already at the beginning of the history") throwDyn (ProgramError "already at the beginning of the history")
let let
update_ic apStack info = do update_ic apStack mb_info = do
(hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
apStack info apStack mb_info
let ic = hsc_IC hsc_env1 let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix } r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs } ic' = ic { ic_resume = r':rs }
...@@ -400,11 +397,11 @@ moveHist fn (Session ref) = do ...@@ -400,11 +397,11 @@ moveHist fn (Session ref) = do
if new_ix == 0 if new_ix == 0
then case r of then case r of
Resume { resumeApStack = apStack, Resume { resumeApStack = apStack,
resumeBreakInfo = info } -> resumeBreakInfo = mb_info } ->
update_ic apStack info update_ic apStack mb_info
else case history !! (new_ix - 1) of else case history !! (new_ix - 1) of
History apStack info -> History apStack info ->
update_ic apStack info update_ic apStack (Just info)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment -- After stopping at a breakpoint, add free variables to the environment
...@@ -412,9 +409,34 @@ moveHist fn (Session ref) = do ...@@ -412,9 +409,34 @@ moveHist fn (Session ref) = do
bindLocalsAtBreakpoint bindLocalsAtBreakpoint
:: HscEnv :: HscEnv
-> HValue -> HValue
-> BreakInfo -> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan) -> 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 let
mod_name = moduleName (breakInfo_module info) mod_name = moduleName (breakInfo_module info)
......
...@@ -99,6 +99,11 @@ extern void setIOManagerPipe (int fd); ...@@ -99,6 +99,11 @@ extern void setIOManagerPipe (int fd);
extern void* allocateExec(unsigned int len); 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 Storage manager stuff exported
-------------------------------------------------------------------------- */ -------------------------------------------------------------------------- */
......
...@@ -118,6 +118,7 @@ RTS_INFO(stg_AP_info); ...@@ -118,6 +118,7 @@ RTS_INFO(stg_AP_info);
RTS_INFO(stg_AP_STACK_info); RTS_INFO(stg_AP_STACK_info);
RTS_INFO(stg_dummy_ret_info); RTS_INFO(stg_dummy_ret_info);
RTS_INFO(stg_raise_info); RTS_INFO(stg_raise_info);
RTS_INFO(stg_raise_ret_info);
RTS_INFO(stg_TVAR_WATCH_QUEUE_info); RTS_INFO(stg_TVAR_WATCH_QUEUE_info);
RTS_INFO(stg_INVARIANT_CHECK_QUEUE_info); RTS_INFO(stg_INVARIANT_CHECK_QUEUE_info);
RTS_INFO(stg_ATOMIC_INVARIANT_info); RTS_INFO(stg_ATOMIC_INVARIANT_info);
......
...@@ -352,13 +352,26 @@ INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise") ...@@ -352,13 +352,26 @@ INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
jump raisezh_fast; 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 raisezh_fast
{ {
W_ handler; W_ handler;
W_ raise_closure;
W_ frame_type; W_ frame_type;
W_ exception;
/* args : R1 :: Exception */ /* args : R1 :: Exception */
exception = R1;
#if defined(PROFILING) #if defined(PROFILING)
/* Debugging tool: on raising an exception, show where we are. */ /* Debugging tool: on raising an exception, show where we are. */
...@@ -367,16 +380,39 @@ raisezh_fast ...@@ -367,16 +380,39 @@ raisezh_fast
* the info was only displayed for an *uncaught* exception. * the info was only displayed for an *uncaught* exception.
*/ */
if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) { if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
foreign "C" fprintCCS_stderr(W_[CCCS] "ptr"); foreign "C" fprintCCS_stderr(W_[CCCS] "ptr") [];
} }
#endif #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 */ /* 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: retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp; 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); Sp = StgTSO_sp(CurrentTSO);
if (frame_type == ATOMICALLY_FRAME) { if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that /* The exception has reached the edge of a memory transaction. Check that
...@@ -390,14 +426,14 @@ retry_pop_stack: ...@@ -390,14 +426,14 @@ retry_pop_stack:
W_ trec, outer; W_ trec, outer;
W_ r; W_ r;
trec = StgTSO_trec(CurrentTSO); trec = StgTSO_trec(CurrentTSO);
r = foreign "C" stmValidateNestOfTransactions(trec "ptr"); r = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
"ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr"); foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
if (outer != NO_TREC) { if (outer != NO_TREC) {
foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr"); foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr"); foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr") [];
} }
StgTSO_trec(CurrentTSO) = NO_TREC; StgTSO_trec(CurrentTSO) = NO_TREC;
...@@ -408,7 +444,7 @@ retry_pop_stack: ...@@ -408,7 +444,7 @@ retry_pop_stack:
} else { } else {
// Transaction was not valid: we retry the exception (otherwise continue // Transaction was not valid: we retry the exception (otherwise continue
// with a further call to raiseExceptionHelper) // 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; StgTSO_trec(CurrentTSO) = trec;
R1 = StgAtomicallyFrame_code(Sp); R1 = StgAtomicallyFrame_code(Sp);
jump stg_ap_v_fast; jump stg_ap_v_fast;
...@@ -423,7 +459,7 @@ retry_pop_stack: ...@@ -423,7 +459,7 @@ retry_pop_stack:
*/ */
Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack
+ WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2); + 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 */ Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
StgTSO_what_next(CurrentTSO) = ThreadKilled::I16; StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
SAVE_THREAD_STATE(); /* inline! */ SAVE_THREAD_STATE(); /* inline! */
...@@ -477,7 +513,7 @@ retry_pop_stack: ...@@ -477,7 +513,7 @@ retry_pop_stack:
* token as arguments. * token as arguments.
*/ */
Sp_adj(-1); Sp_adj(-1);
Sp(0) = R1; Sp(0) = exception;
R1 = handler; R1 = handler;
Sp_adj(-1); Sp_adj(-1);
TICK_UNKNOWN_CALL(); TICK_UNKNOWN_CALL();
......
...@@ -16,6 +16,7 @@ ...@@ -16,6 +16,7 @@