[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).

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 4fcafeb..b79d4de 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 "<<loop>>"
+  showsPrec _ (Deadlock)                 = showString "<<deadlock>>"
   showsPrec _ (UserError err)            = showString err
 
 -- -----------------------------------------------------------------------------

diff --git a/ghc/lib/std/PrelTopHandler.hs b/ghc/lib/std/PrelTopHandler.hs
index 54da967..1159631 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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_
 }