Deadlock is now an exception instead of a return status from
rts_evalIO().
The current behaviour is as follows, and can be changed if necessary:
in the event of a deadlock, the top main thread is taken from the main
thread queue, and if it is blocked on an MVar or an Exception (for
throwTo), then it receives a Deadlock exception. If it is blocked on
a BLACKHOLE, we instead send it the NonTermination exception. Note
that only the main thread gets the exception: it is the responsibility
of the main thread to unblock other threads if necessary.
There's a slight difference in the SMP build: *all* the main threads
get an exception, because clearly none of them may make progress
(compared to the non-SMP situation, where all but the top main thread
are usually blocked).
#ifdef GHCI
cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool
#ifdef GHCI
cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool
- cmSetContext, -- :: CmState -> [String] -> [String] -> IO CmState
+ cmSetContext, -- :: CmState -> DynFlags -> [String] -> [String] -> IO CmState
cmGetContext, -- :: CmState -> IO ([String],[String])
cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
cmGetContext, -- :: CmState -> IO ([String],[String])
cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing)
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
cmCompileExpr, -- :: CmState -> DynFlags -> String
cmCompileExpr, -- :: CmState -> DynFlags -> String
- -- -> IO (CmState, Maybe HValue)#endif
+ -- -> IO (CmState, Maybe HValue)
data CmRunResult
= CmRunOk [Name] -- names bound by this evaluation
| CmRunFailed
data CmRunResult
= CmRunOk [Name] -- names bound by this evaluation
| CmRunFailed
- | CmRunDeadlocked -- statement deadlocked
| CmRunException Exception -- statement raised an exception
cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult)
| CmRunException Exception -- statement raised an exception
cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult)
either_hvals <- sandboxIO thing_to_run
case either_hvals of
Left err
either_hvals <- sandboxIO thing_to_run
case either_hvals of
Left err
- | err == dEADLOCKED
- -> return ( cmstate{ pcs=new_pcs, ic=new_ic },
- CmRunDeadlocked )
- | otherwise
-> do hPutStrLn stderr ("unknown failure, code " ++ show err)
return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed )
-> do hPutStrLn stderr ("unknown failure, code " ++ show err)
return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed )
CmRunOk names)
-- We run the statement in a "sandbox", which amounts to calling into
CmRunOk names)
-- We run the statement in a "sandbox", which amounts to calling into
--- the RTS to request a new main thread. The main benefit is that we
--- get to detect a deadlock this way, but also there's no danger that
--- exceptions raised by the expression can affect the interpreter.
+-- the RTS to request a new main thread. The main benefit is that
+-- there's no danger that exceptions raised by the expression can
+-- affect the interpreter.
sandboxIO :: IO a -> IO (Either Int (Either Exception a))
sandboxIO thing = do
sandboxIO :: IO a -> IO (Either Int (Either Exception a))
sandboxIO thing = do
else do
return (Left (fromIntegral stat))
else do
return (Left (fromIntegral stat))
--- ToDo: slurp this in from ghc/includes/RtsAPI.h somehow
-dEADLOCKED = 4 :: Int
-
foreign import "rts_evalStableIO" {- safe -}
rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
-- more informative than the C type!
foreign import "rts_evalStableIO" {- safe -}
rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
-- more informative than the C type!
, "PrelIOBase_heapOverflow_closure"
, "PrelIOBase_NonTermination_closure"
, "PrelIOBase_BlockedOnDeadMVar_closure"
, "PrelIOBase_heapOverflow_closure"
, "PrelIOBase_NonTermination_closure"
, "PrelIOBase_BlockedOnDeadMVar_closure"
+ , "PrelIOBase_Deadlock_closure"
, "PrelWeak_runFinalizzerBatch_closure"
, "__stginit_Prelude"
])
, "PrelWeak_runFinalizzerBatch_closure"
, "__stginit_Prelude"
])
/* ----------------------------------------------------------------------------
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.24 2001/10/29 11:33:37 simonmar Exp $
+ * $Id: RtsAPI.h,v 1.25 2002/01/22 13:54:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
*
* (c) The GHC Team, 1998-1999
*
NoStatus, /* not finished yet */
Success, /* completed successfully */
Killed, /* uncaught exception */
NoStatus, /* not finished yet */
Success, /* completed successfully */
Killed, /* uncaught exception */
- Interrupted, /* stopped in response to a call to interruptStgRts */
- Deadlock /* no threads to run, but main thread hasn't finished */
+ Interrupted /* stopped in response to a call to interruptStgRts */
} SchedulerStatus;
typedef StgClosure *HaskellObj;
} SchedulerStatus;
typedef StgClosure *HaskellObj;
% ------------------------------------------------------------------------------
% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.45 2001/11/26 20:04:00 sof Exp $
+% $Id: PrelIOBase.lhs,v 1.46 2002/01/22 13:54:22 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2001
%
%
% (c) The University of Glasgow, 1994-2001
%
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
+ | NonTermination -- Cyclic data dependency or other loop
+ | Deadlock -- no threads can run (raised in main thread)
| UserError String
data ArithException
| UserError String
data ArithException
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
+ showsPrec _ (Deadlock) = showString "<<deadlock>>"
showsPrec _ (UserError err) = showString err
-- -----------------------------------------------------------------------------
showsPrec _ (UserError err) = showString err
-- -----------------------------------------------------------------------------
{-# OPTIONS -#include "PrelIOUtils.h" #-}
-- -----------------------------------------------------------------------------
--
{-# OPTIONS -#include "PrelIOUtils.h" #-}
-- -----------------------------------------------------------------------------
--
--- (c) The University of Glasgow, 1994-
+-- (c) The University of Glasgow, 1994-2002
ExitException ExitSuccess -> shutdownHaskellAndExit 0
ExitException (ExitFailure n) -> shutdownHaskellAndExit n
ExitException ExitSuccess -> shutdownHaskellAndExit 0
ExitException (ExitFailure n) -> shutdownHaskellAndExit n
+ Deadlock -> reportError True
+ "no threads to run: infinite loop or deadlock?"
+
ErrorCall s -> reportError True s
other -> reportError True (showsPrec 0 other "\n")
ErrorCall s -> reportError True s
other -> reportError True (showsPrec 0 other "\n")
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.31 2001/09/04 18:29:21 ken Exp $
+ * $Id: Main.c,v 1.32 2002/01/22 13:54:22 simonmar Exp $
*
* (c) The GHC Team 1998-2000
*
*
* (c) The GHC Team 1998-2000
*
/* check the status of the entire Haskell computation */
switch (status) {
/* check the status of the entire Haskell computation */
switch (status) {
- case Deadlock:
- prog_belch("no threads to run: infinite loop or deadlock?");
- exit_status = EXIT_DEADLOCK;
- break;
case Killed:
prog_belch("main thread exited (uncaught exception)");
exit_status = EXIT_KILLED;
case Killed:
prog_belch("main thread exited (uncaught exception)");
exit_status = EXIT_KILLED;
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.16 2001/03/19 10:24:03 simonmar Exp $
+ * $Id: Prelude.h,v 1.17 2002/01/22 13:54:22 simonmar Exp $
*
* (c) The GHC Team, 1998-2001
*
*
* (c) The GHC Team, 1998-2001
*
extern DLL_IMPORT const StgClosure PrelIOBase_heapOverflow_closure;
extern DLL_IMPORT const StgClosure PrelIOBase_BlockedOnDeadMVar_closure;
extern DLL_IMPORT const StgClosure PrelIOBase_NonTermination_closure;
extern DLL_IMPORT const StgClosure PrelIOBase_heapOverflow_closure;
extern DLL_IMPORT const StgClosure PrelIOBase_BlockedOnDeadMVar_closure;
extern DLL_IMPORT const StgClosure PrelIOBase_NonTermination_closure;
+extern DLL_IMPORT const StgClosure PrelIOBase_Deadlock_closure;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info;
#define heapOverflow_closure (&PrelIOBase_heapOverflow_closure)
#define BlockedOnDeadMVar_closure (&PrelIOBase_BlockedOnDeadMVar_closure)
#define NonTermination_closure (&PrelIOBase_NonTermination_closure)
#define heapOverflow_closure (&PrelIOBase_heapOverflow_closure)
#define BlockedOnDeadMVar_closure (&PrelIOBase_BlockedOnDeadMVar_closure)
#define NonTermination_closure (&PrelIOBase_NonTermination_closure)
+#define Deadlock_closure (&PrelIOBase_Deadlock_closure)
#define Czh_static_info (&PrelBase_Czh_static_info)
#define Fzh_static_info (&PrelFloat_Fzh_static_info)
#define Czh_static_info (&PrelBase_Czh_static_info)
#define Fzh_static_info (&PrelFloat_Fzh_static_info)
/* ----------------------------------------------------------------------------
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.30 2001/10/23 11:30:07 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.31 2002/01/22 13:54:22 simonmar Exp $
*
* (c) The GHC Team, 1998-2001
*
*
* (c) The GHC Team, 1998-2001
*
barf("%s: uncaught exception",site);
case Interrupted:
barf("%s: interrupted", site);
barf("%s: uncaught exception",site);
case Interrupted:
barf("%s: interrupted", site);
- case Deadlock:
- barf("%s: no threads to run: infinite loop or deadlock?", site);
default:
barf("%s: Return code (%d) not ok",(site),(rc));
}
default:
barf("%s: Return code (%d) not ok",(site),(rc));
}
/* ---------------------------------------------------------------------------
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.110 2001/12/18 12:33:45 simonmar Exp $
+ * $Id: Schedule.c,v 1.111 2002/01/22 13:54:22 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
*
* (c) The GHC Team, 1998-2000
*
if (blocked_queue_hd == END_TSO_QUEUE
&& run_queue_hd == END_TSO_QUEUE
&& sleeping_queue == END_TSO_QUEUE) {
if (blocked_queue_hd == END_TSO_QUEUE
&& run_queue_hd == END_TSO_QUEUE
&& sleeping_queue == END_TSO_QUEUE) {
IF_DEBUG(scheduler, sched_belch("still deadlocked, checking for black holes..."));
detectBlackHoles();
IF_DEBUG(scheduler, sched_belch("still deadlocked, checking for black holes..."));
detectBlackHoles();
+
+ // No black holes, so probably a real deadlock. Send the
+ // current main thread the Deadlock exception (or in the SMP
+ // build, send *all* main threads the deadlock exception,
+ // since none of them can make progress).
if (run_queue_hd == END_TSO_QUEUE) {
if (run_queue_hd == END_TSO_QUEUE) {
- StgMainThread *m = main_threads;
- for (; m != NULL; m = m->link) {
- deleteThread(m->tso);
- m->ret = NULL;
- m->stat = Deadlock;
- pthread_cond_broadcast(&m->wakeup);
+ for (m = main_threads; m != NULL; m = m->link) {
+ switch (m->tso->why_blocked) {
+ case BlockedOnBlackHole:
+ raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
+ break;
+ case BlockedOnException:
+ case BlockedOnMVar:
+ raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
+ break;
+ default:
+ barf("deadlock: main thread blocked in a strange way");
+ }
- deleteThread(m->tso);
- m->ret = NULL;
- m->stat = Deadlock;
- main_threads = m->link;
- return;
+ m = main_threads;
+ switch (m->tso->why_blocked) {
+ case BlockedOnBlackHole:
+ raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
+ break;
+ case BlockedOnException:
+ case BlockedOnMVar:
+ raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
+ break;
+ default:
+ barf("deadlock: main thread blocked in a strange way");
+ }
+ ASSERT( run_queue_hd != END_TSO_QUEUE );
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.71 2001/12/10 18:07:35 sof Exp $
+ * $Id: StgMiscClosures.hc,v 1.72 2002/01/22 13:54:23 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
*
* (c) The GHC Team, 1998-2000
*
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(ENTRY_CODE(*R1.p));
+ JMP_(GET_ENTRY(R1.cl));
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgIndStatic*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(ENTRY_CODE(*R1.p));
+ JMP_(GET_ENTRY(R1.cl));
TICK_ENT_VIA_NODE();
#endif
TICK_ENT_VIA_NODE();
#endif
- JMP_(ENTRY_CODE(*R1.p));
+ JMP_(GET_ENTRY(R1.cl));
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
TICK_ENT_IND(Node); /* tick */
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(ENTRY_CODE(*R1.p));
+ JMP_(GET_ENTRY(R1.cl));
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
- JMP_(ENTRY_CODE(*R1.p));
+ JMP_(GET_ENTRY(R1.cl));