Commit 33a7aa8b authored by simonmar's avatar simonmar
Browse files

[project @ 2002-01-22 13:54:22 by simonmar]

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).
parent 483817dd
......@@ -22,7 +22,7 @@ module CompManager (
#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)
......@@ -36,8 +36,9 @@ module CompManager (
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
HValue,
cmCompileExpr, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe HValue)#endif
-- -> IO (CmState, Maybe HValue)
#endif
)
where
......@@ -246,7 +247,6 @@ cmInfoThing cmstate dflags id
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)
......@@ -291,10 +291,6 @@ cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext }
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 )
......@@ -314,9 +310,9 @@ cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext }
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
......@@ -332,9 +328,6 @@ sandboxIO thing = do
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!
......
......@@ -133,6 +133,7 @@ package_details installing
, "PrelIOBase_heapOverflow_closure"
, "PrelIOBase_NonTermination_closure"
, "PrelIOBase_BlockedOnDeadMVar_closure"
, "PrelIOBase_Deadlock_closure"
, "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
*
......@@ -23,8 +23,7 @@ typedef enum {
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;
......
% ------------------------------------------------------------------------------
% $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
%
......@@ -393,7 +393,8 @@ data Exception
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
| NonTermination
| NonTermination -- Cyclic data dependency or other loop
| Deadlock -- no threads can run (raised in main thread)
| UserError String
data ArithException
......@@ -457,6 +458,7 @@ instance Show Exception where
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
showsPrec _ (Deadlock) = showString "<<deadlock>>"
showsPrec _ (UserError err) = showString err
-- -----------------------------------------------------------------------------
......
{-# OPTIONS -#include "PrelIOUtils.h" #-}
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 1994-
-- (c) The University of Glasgow, 1994-2002
--
-- PrelTopHandler
--
......@@ -42,6 +42,9 @@ real_handler ex =
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")
......
/* -----------------------------------------------------------------------------
* $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
*
......@@ -109,10 +109,6 @@ int main(int argc, char *argv[])
/* 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;
......
/* -----------------------------------------------------------------------------
* $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
*
......@@ -24,6 +24,7 @@ extern DLL_IMPORT const StgClosure PrelIOBase_stackOverflow_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;
......@@ -68,6 +69,7 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info;
#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)
......
/* ----------------------------------------------------------------------------
* $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
*
......@@ -479,8 +479,6 @@ rts_checkSchedStatus ( char* site, SchedulerStatus rc )
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));
}
......
/* ---------------------------------------------------------------------------
* $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
*
......@@ -579,26 +579,46 @@ schedule( void )
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();
// 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) {
StgMainThread *m = main_threads;
StgMainThread *m;
#ifdef SMP
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");
}
}
main_threads = NULL;
#else
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");
}
#endif
}
ASSERT( run_queue_hd != END_TSO_QUEUE );
}
}
#elif defined(PAR)
......
/* -----------------------------------------------------------------------------
* $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
*
......@@ -295,7 +295,7 @@ STGFUN(stg_IND_entry)
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));
FE_
}
......@@ -306,7 +306,7 @@ STGFUN(stg_IND_STATIC_entry)
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));
FE_
}
......@@ -350,7 +350,7 @@ STGFUN(stg_IND_PERM_entry)
TICK_ENT_VIA_NODE();
#endif
JMP_(ENTRY_CODE(*R1.p));
JMP_(GET_ENTRY(R1.cl));
FE_
}
......@@ -361,7 +361,7 @@ STGFUN(stg_IND_OLDGEN_entry)
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));
FE_
}
......@@ -391,7 +391,7 @@ STGFUN(stg_IND_OLDGEN_PERM_entry)
R1.p = (P_) ((StgInd*)R1.p)->indirectee;
TICK_ENT_VIA_NODE();
JMP_(ENTRY_CODE(*R1.p));
JMP_(GET_ENTRY(R1.cl));
FE_
}
......
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