From 33a7aa8bb2584a8e4cb8bdae27f6d56696f2dea5 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 22 Jan 2002 13:54:23 +0000 Subject: [PATCH] [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). --- ghc/compiler/compMan/CompManager.lhs | 19 +++++--------- ghc/driver/PackageSrc.hs | 1 + ghc/includes/RtsAPI.h | 5 ++-- ghc/lib/std/PrelIOBase.lhs | 6 +++-- ghc/lib/std/PrelTopHandler.hs | 5 +++- ghc/rts/Main.c | 6 +---- ghc/rts/Prelude.h | 4 ++- ghc/rts/RtsAPI.c | 4 +-- ghc/rts/Schedule.c | 46 ++++++++++++++++++++++++---------- ghc/rts/StgMiscClosures.hc | 12 ++++----- 10 files changed, 61 insertions(+), 47 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 4fcafeb..b79d4de 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -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! diff --git a/ghc/driver/PackageSrc.hs b/ghc/driver/PackageSrc.hs index 9e347cc..474ae4f 100644 --- a/ghc/driver/PackageSrc.hs +++ b/ghc/driver/PackageSrc.hs @@ -133,6 +133,7 @@ package_details installing , "PrelIOBase_heapOverflow_closure" , "PrelIOBase_NonTermination_closure" , "PrelIOBase_BlockedOnDeadMVar_closure" + , "PrelIOBase_Deadlock_closure" , "PrelWeak_runFinalizzerBatch_closure" , "__stginit_Prelude" ]) diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h index ae6c5c0..fc4507e 100644 --- a/ghc/includes/RtsAPI.h +++ b/ghc/includes/RtsAPI.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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; diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index ef862df..ea459d3 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $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 "<>" + showsPrec _ (Deadlock) = showString "<>" showsPrec _ (UserError err) = showString err -- ----------------------------------------------------------------------------- diff --git a/ghc/lib/std/PrelTopHandler.hs b/ghc/lib/std/PrelTopHandler.hs index 54da967..1159631 100644 --- a/ghc/lib/std/PrelTopHandler.hs +++ b/ghc/lib/std/PrelTopHandler.hs @@ -1,7 +1,7 @@ {-# 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") diff --git a/ghc/rts/Main.c b/ghc/rts/Main.c index 83fb115..a8ca10c 100644 --- a/ghc/rts/Main.c +++ b/ghc/rts/Main.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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; diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index 5bdd82e..e83aaa8 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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) diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c index 62540de..96092d0 100644 --- a/ghc/rts/RtsAPI.c +++ b/ghc/rts/RtsAPI.c @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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)); } diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 758bcc9..9ccaf90 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $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) diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 68490d7..67fd674 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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_ } -- 1.7.10.4