X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSchedule.c;h=d8491ae0b6c6ea264834b8dd37e17c58c53674ea;hb=d1d8706d2ebfb8898ba86977420b89b9854d5213;hp=413bfa88a9ec01479d36060b5299bfec91f471bf;hpb=a0b380bb30e37ab75eb42ff3f7e9a9bc60291496;p=ghc-hetmet.git

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 413bfa8..d8491ae 100644
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
 /* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.61 2000/04/03 15:24:21 rrt Exp $
+ * $Id: Schedule.c,v 1.85 2000/12/19 16:38:15 sewardj Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -62,12 +62,11 @@
 #include "Schedule.h"
 #include "StgMiscClosures.h"
 #include "Storage.h"
-#include "Evaluator.h"
+#include "Interpreter.h"
 #include "Exception.h"
 #include "Printer.h"
 #include "Main.h"
 #include "Signals.h"
-#include "Profiling.h"
 #include "Sanity.h"
 #include "Stats.h"
 #include "Itimer.h"
@@ -145,6 +144,7 @@ StgTSO *ccalling_threadss[MAX_PROC];
 
 StgTSO *run_queue_hd, *run_queue_tl;
 StgTSO *blocked_queue_hd, *blocked_queue_tl;
+StgTSO *sleeping_queue;		/* perhaps replace with a hash table? */
 
 #endif
 
@@ -214,6 +214,12 @@ Capability MainRegTable;       /* for non-SMP, we have one global capability */
 StgTSO *CurrentTSO;
 #endif
 
+/*  This is used in `TSO.h' and gcc 2.96 insists that this variable actually 
+ *  exists - earlier gccs apparently didn't.
+ *  -= chak
+ */
+StgTSO dummy_tso;
+
 rtsBool ready_to_gc;
 
 /* All our current task ids, saved in case we need to kill them later.
@@ -233,6 +239,8 @@ static StgTSO * createThread_     ( nat size, rtsBool have_lock, StgInt pri );
 static StgTSO * createThread_     ( nat size, rtsBool have_lock );
 #endif
 
+static void     detectBlackHoles  ( void );
+
 #ifdef DEBUG
 static void sched_belch(char *s, ...);
 #endif
@@ -259,7 +267,7 @@ rtsTime TimeOfLastYield;
 char *whatNext_strs[] = {
   "ThreadEnterGHC",
   "ThreadRunGHC",
-  "ThreadEnterHugs",
+  "ThreadEnterInterp",
   "ThreadKilled",
   "ThreadComplete"
 };
@@ -378,14 +386,7 @@ schedule( void )
      */
     if (interrupted) {
       IF_DEBUG(scheduler, sched_belch("interrupted"));
-      for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
-	deleteThread(t);
-      }
-      for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
-	deleteThread(t);
-      }
-      run_queue_hd = run_queue_tl = END_TSO_QUEUE;
-      blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
+      deleteAllThreads();
       interrupted = rtsFalse;
       was_interrupted = rtsTrue;
     }
@@ -505,7 +506,7 @@ schedule( void )
      * ToDo: what if another client comes along & requests another
      * main thread?
      */
-    if (blocked_queue_hd != END_TSO_QUEUE) {
+    if (blocked_queue_hd != END_TSO_QUEUE || sleeping_queue != END_TSO_QUEUE) {
       awaitEvent(
 	   (run_queue_hd == END_TSO_QUEUE)
 #ifdef SMP
@@ -513,46 +514,60 @@ schedule( void )
 #endif
 	);
     }
-    
+    /* we can be interrupted while waiting for I/O... */
+    if (interrupted) continue;
+
     /* check for signals each time around the scheduler */
-#ifndef __MINGW32__
+#ifndef mingw32_TARGET_OS
     if (signals_pending()) {
       start_signal_handlers();
     }
 #endif
 
-    /* Detect deadlock: when we have no threads to run, there are
-     * no threads waiting on I/O or sleeping, and all the other
-     * tasks are waiting for work, we must have a deadlock.  Inform
-     * all the main threads.
+    /* 
+     * Detect deadlock: when we have no threads to run, there are no
+     * threads waiting on I/O or sleeping, and all the other tasks are
+     * waiting for work, we must have a deadlock of some description.
+     *
+     * We first try to find threads blocked on themselves (ie. black
+     * holes), and generate NonTermination exceptions where necessary.
+     *
+     * If no threads are black holed, we have a deadlock situation, so
+     * inform all the main threads.
      */
 #ifdef SMP
     if (blocked_queue_hd == END_TSO_QUEUE
 	&& run_queue_hd == END_TSO_QUEUE
-	&& (n_free_capabilities == RtsFlags.ParFlags.nNodes)
-	) {
-      StgMainThread *m;
-      for (m = main_threads; m != NULL; m = m->link) {
-	  m->ret = NULL;
-	  m->stat = Deadlock;
-	  pthread_cond_broadcast(&m->wakeup);
-      }
-      main_threads = NULL;
+	&& sleeping_queue == END_TSO_QUEUE
+	&& (n_free_capabilities == RtsFlags.ParFlags.nNodes))
+    {
+	IF_DEBUG(scheduler, sched_belch("deadlocked, checking for black holes..."));
+	detectBlackHoles();
+	if (run_queue_hd == END_TSO_QUEUE) {
+	    StgMainThread *m;
+	    for (m = main_threads; m != NULL; m = m->link) {
+		m->ret = NULL;
+		m->stat = Deadlock;
+		pthread_cond_broadcast(&m->wakeup);
+	    }
+	    main_threads = NULL;
+	}
     }
 #else /* ! SMP */
-    /* 
-       In GUM all non-main PEs come in here with no work;
-       we ignore multiple main threads for now 
-
     if (blocked_queue_hd == END_TSO_QUEUE
-	&& run_queue_hd == END_TSO_QUEUE) {
-      StgMainThread *m = main_threads;
-      m->ret = NULL;
-      m->stat = Deadlock;
-      main_threads = m->link;
-      return;
+	&& run_queue_hd == END_TSO_QUEUE
+	&& sleeping_queue == END_TSO_QUEUE)
+    {
+	IF_DEBUG(scheduler, sched_belch("deadlocked, checking for black holes..."));
+	detectBlackHoles();
+	if (run_queue_hd == END_TSO_QUEUE) {
+	    StgMainThread *m = main_threads;
+	    m->ret = NULL;
+	    m->stat = Deadlock;
+	    main_threads = m->link;
+	    return;
+	}
     }
-    */
 #endif
 
 #ifdef SMP
@@ -821,6 +836,7 @@ schedule( void )
   
     /* grab a thread from the run queue
      */
+    ASSERT(run_queue_hd != END_TSO_QUEUE);
     t = POP_RUN_QUEUE();
     IF_DEBUG(sanity,checkTSO(t));
 
@@ -838,21 +854,22 @@ schedule( void )
     
     cap->rCurrentTSO = t;
     
-    /* set the context_switch flag
+    /* context switches are now initiated by the timer signal, unless
+     * the user specified "context switch as often as possible", with
+     * +RTS -C0
      */
-    if (run_queue_hd == END_TSO_QUEUE)
-      context_switch = 0;
+    if (RtsFlags.ConcFlags.ctxtSwitchTicks == 0
+	&& (run_queue_hd != END_TSO_QUEUE
+	    || blocked_queue_hd != END_TSO_QUEUE
+	    || sleeping_queue != END_TSO_QUEUE))
+	context_switch = 1;
     else
-      context_switch = 1;
+	context_switch = 0;
 
     RELEASE_LOCK(&sched_mutex);
 
-#if defined(GRAN) || defined(PAR)    
-    IF_DEBUG(scheduler, belch("-->> Running TSO %ld (%p) %s ...", 
+    IF_DEBUG(scheduler, sched_belch("-->> Running TSO %ld (%p) %s ...", 
 			      t->id, t, whatNext_strs[t->what_next]));
-#else
-    IF_DEBUG(scheduler,sched_belch("running thread %d", t->id));
-#endif
 
     /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
     /* Run the current thread 
@@ -869,14 +886,11 @@ schedule( void )
     case ThreadRunGHC:
       ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
       break;
-    case ThreadEnterHugs:
-#ifdef INTERPRETER
+    case ThreadEnterInterp:
+#ifdef GHCI
       {
-         StgClosure* c;
-	 IF_DEBUG(scheduler,sched_belch("entering Hugs"));
-	 c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
-	 cap->rCurrentTSO->sp += 1;
-	 ret = enter(cap,c);
+	 IF_DEBUG(scheduler,sched_belch("entering interpreter"));
+	 ret = interpretBCO(cap);
          break;
       }
 #else
@@ -915,10 +929,8 @@ schedule( void )
        * maybe set context_switch and wait till they all pile in,
        * then have them wait on a GC condition variable.
        */
-#if defined(GRAN) || defined(PAR)    
-      IF_DEBUG(scheduler,belch("--<< TSO %ld (%p; %s) stopped: HeapOverflow", 
+      IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped: HeapOverflow", 
 			       t->id, t, whatNext_strs[t->what_next]));
-#endif
       threadPaused(t);
 #if defined(GRAN)
       ASSERT(!is_on_queue(t,CurrentProc));
@@ -931,10 +943,8 @@ schedule( void )
       break;
       
     case StackOverflow:
-#if defined(GRAN) || defined(PAR)    
-      IF_DEBUG(scheduler,belch("--<< TSO %ld (%p; %s) stopped, StackOverflow", 
+      IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped, StackOverflow", 
 			       t->id, t, whatNext_strs[t->what_next]));
-#endif
       /* just adjust the stack for this thread, then pop it back
        * on the run queue.
        */
@@ -972,32 +982,21 @@ schedule( void )
        * up the GC thread.  getThread will block during a GC until the
        * GC is finished.
        */
-#if defined(GRAN) || defined(PAR)    
       IF_DEBUG(scheduler,
-               if (t->what_next == ThreadEnterHugs) {
+               if (t->what_next == ThreadEnterInterp) {
 		   /* ToDo: or maybe a timer expired when we were in Hugs?
 		    * or maybe someone hit ctrl-C
                     */
-                   belch("--<< TSO %ld (%p; %s) stopped to switch to Hugs", 
+                   belch("--<< thread %ld (%p; %s) stopped to switch to Hugs", 
 			 t->id, t, whatNext_strs[t->what_next]);
                } else {
-                   belch("--<< TSO %ld (%p; %s) stopped, yielding", 
+                   belch("--<< thread %ld (%p; %s) stopped, yielding", 
 			 t->id, t, whatNext_strs[t->what_next]);
                }
                );
-#else
-      IF_DEBUG(scheduler,
-	       if (t->what_next == ThreadEnterHugs) {
-		 /* ToDo: or maybe a timer expired when we were in Hugs?
-		  * or maybe someone hit ctrl-C
-		  */
-		 belch("thread %ld stopped to switch to Hugs", t->id);
-	       } else {
-		 belch("thread %ld stopped, yielding", t->id);
-	       }
-	       );
-#endif
+
       threadPaused(t);
+
       IF_DEBUG(sanity,
 	       //belch("&& Doing sanity check on yielding TSO %ld.", t->id);
 	       checkTSO(t));
@@ -1025,7 +1024,7 @@ schedule( void )
     case ThreadBlocked:
 #if defined(GRAN)
       IF_DEBUG(scheduler,
-	       belch("--<< TSO %ld (%p; %s) stopped, blocking on node %p [PE %d] with BQ: ", 
+	       belch("--<< thread %ld (%p; %s) stopped, blocking on node %p [PE %d] with BQ: ", 
 			       t->id, t, whatNext_strs[t->what_next], t->block_info.closure, (t->block_info.closure==(StgClosure*)NULL ? 99 : where_is(t->block_info.closure)));
 	       if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
 
@@ -1051,7 +1050,7 @@ schedule( void )
       blockThread(t);
 
       IF_DEBUG(scheduler,
-	       belch("--<< TSO %ld (%p; %s) stopped, blocking on node %p with BQ: ", 
+	       belch("--<< thread %ld (%p; %s) stopped, blocking on node %p with BQ: ", 
 			       t->id, t, whatNext_strs[t->what_next], t->block_info.closure);
 	       if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
 
@@ -1062,7 +1061,7 @@ schedule( void )
        * case it'll be on the relevant queue already.
        */
       IF_DEBUG(scheduler,
-	       fprintf(stderr, "--<< TSO %d (%p) stopped ", t->id, t);
+	       fprintf(stderr, "--<< thread %d (%p) stopped: ", t->id, t);
 	       printThreadBlockage(t);
 	       fprintf(stderr, "\n"));
 
@@ -1080,8 +1079,10 @@ schedule( void )
        * more main threads, we probably need to stop all the tasks until
        * we get a new one.
        */
-      IF_DEBUG(scheduler,belch("--++ TSO %d (%p) finished", t->id, t));
-      t->what_next = ThreadComplete;
+      /* We also end up here if the thread kills itself with an
+       * uncaught exception, see Exception.hc.
+       */
+      IF_DEBUG(scheduler,belch("--++ thread %d (%p) finished", t->id, t));
 #if defined(GRAN)
       endThread(t, CurrentProc); // clean-up the thread
 #elif defined(PAR)
@@ -1092,7 +1093,7 @@ schedule( void )
       break;
       
     default:
-      barf("doneThread: invalid thread return code");
+      barf("schedule: invalid thread return code %d", (int)ret);
     }
     
 #ifdef SMP
@@ -1115,7 +1116,7 @@ schedule( void )
 #ifdef SMP
       IF_DEBUG(scheduler,sched_belch("doing GC"));
 #endif
-      GarbageCollect(GetRoots);
+      GarbageCollect(GetRoots,rtsFalse);
       ready_to_gc = rtsFalse;
 #ifdef SMP
       pthread_cond_broadcast(&gc_pending_cond);
@@ -1151,19 +1152,29 @@ schedule( void )
   } /* end of while(1) */
 }
 
-/* A hack for Hugs concurrency support.  Needs sanitisation (?) */
+/* ---------------------------------------------------------------------------
+ * deleteAllThreads():  kill all the live threads.
+ *
+ * This is used when we catch a user interrupt (^C), before performing
+ * any necessary cleanups and running finalizers.
+ * ------------------------------------------------------------------------- */
+   
 void deleteAllThreads ( void )
 {
   StgTSO* t;
-  IF_DEBUG(scheduler,sched_belch("deleteAllThreads()"));
+  IF_DEBUG(scheduler,sched_belch("deleting all threads"));
   for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
-    deleteThread(t);
+      deleteThread(t);
   }
   for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
-    deleteThread(t);
+      deleteThread(t);
+  }
+  for (t = sleeping_queue; t != END_TSO_QUEUE; t = t->link) {
+      deleteThread(t);
   }
   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
+  sleeping_queue = END_TSO_QUEUE;
 }
 
 /* startThread and  insertThread are now in GranSim.c -- HWL */
@@ -1194,7 +1205,7 @@ suspendThread( Capability *cap )
   ACQUIRE_LOCK(&sched_mutex);
 
   IF_DEBUG(scheduler,
-	   sched_belch("thread %d did a _ccall_gc\n", cap->rCurrentTSO->id));
+	   sched_belch("thread %d did a _ccall_gc", cap->rCurrentTSO->id));
 
   threadPaused(cap->rCurrentTSO);
   cap->rCurrentTSO->link = suspended_ccalling_threads;
@@ -1233,6 +1244,7 @@ resumeThread( StgInt tok )
   if (tso == END_TSO_QUEUE) {
     barf("resumeThread: thread not found");
   }
+  tso->link = END_TSO_QUEUE;
 
 #ifdef SMP
   while (free_capabilities == NULL) {
@@ -1344,7 +1356,7 @@ createThread_(nat size, rtsBool have_lock)
   tso = (StgTSO *)allocate(size);
   TICK_ALLOC_TSO(size-TSO_STRUCT_SIZEW, 0);
 
-  SET_HDR(tso, &TSO_info, CCS_MAIN);
+  SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
 #if defined(GRAN)
   SET_GRAN_HDR(tso, ThisPE);
 #endif
@@ -1361,7 +1373,6 @@ createThread_(nat size, rtsBool have_lock)
   tso->why_blocked  = NotBlocked;
   tso->blocked_exceptions = NULL;
 
-  tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
   tso->stack_size   = stack_size;
   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize) 
                               - TSO_STRUCT_SIZEW;
@@ -1373,12 +1384,9 @@ createThread_(nat size, rtsBool have_lock)
 
   /* put a stop frame on the stack */
   tso->sp -= sizeofW(StgStopFrame);
-  SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
+  SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
   tso->su = (StgUpdateFrame*)tso->sp;
 
-  IF_DEBUG(scheduler,belch("---- Initialised TSO %ld (%p), stack size = %lx words", 
-			   tso->id, tso, tso->stack_size));
-
   // ToDo: check this
 #if defined(GRAN)
   tso->link = END_TSO_QUEUE;
@@ -1528,7 +1536,9 @@ scheduleThread(StgTSO *tso)
   PUSH_ON_RUN_QUEUE(tso);
   THREAD_RUNNABLE();
 
+#if 0
   IF_DEBUG(scheduler,printTSO(tso));
+#endif
   RELEASE_LOCK(&sched_mutex);
 }
 
@@ -1583,12 +1593,14 @@ initScheduler(void)
     blocked_queue_hds[i]  = END_TSO_QUEUE;
     blocked_queue_tls[i]  = END_TSO_QUEUE;
     ccalling_threadss[i]  = END_TSO_QUEUE;
+    sleeping_queue        = END_TSO_QUEUE;
   }
 #else
   run_queue_hd      = END_TSO_QUEUE;
   run_queue_tl      = END_TSO_QUEUE;
   blocked_queue_hd  = END_TSO_QUEUE;
   blocked_queue_tl  = END_TSO_QUEUE;
+  sleeping_queue    = END_TSO_QUEUE;
 #endif 
 
   suspended_ccalling_threads  = END_TSO_QUEUE;
@@ -1599,7 +1611,13 @@ initScheduler(void)
   context_switch = 0;
   interrupted    = 0;
 
-  enteredCAFs = END_CAF_LIST;
+  RtsFlags.ConcFlags.ctxtSwitchTicks =
+      RtsFlags.ConcFlags.ctxtSwitchTime / TICK_MILLISECS;
+
+#ifdef INTERPRETER
+  ecafList = END_ECAF_LIST;
+  clearECafTable();
+#endif
 
   /* Install the SIGHUP handler */
 #ifdef SMP
@@ -1729,6 +1747,39 @@ exitScheduler( void )
  * will be in the main_thread struct.
  * -------------------------------------------------------------------------- */
 
+int 
+howManyThreadsAvail ( void )
+{
+   int i = 0;
+   StgTSO* q;
+   for (q = run_queue_hd; q != END_TSO_QUEUE; q = q->link)
+      i++;
+   for (q = blocked_queue_hd; q != END_TSO_QUEUE; q = q->link)
+      i++;
+   for (q = sleeping_queue; q != END_TSO_QUEUE; q = q->link)
+      i++;
+   return i;
+}
+
+void
+finishAllThreads ( void )
+{
+   do {
+      while (run_queue_hd != END_TSO_QUEUE) {
+         waitThread ( run_queue_hd, NULL );
+      }
+      while (blocked_queue_hd != END_TSO_QUEUE) {
+         waitThread ( blocked_queue_hd, NULL );
+      }
+      while (sleeping_queue != END_TSO_QUEUE) {
+         waitThread ( blocked_queue_hd, NULL );
+      }
+   } while 
+      (blocked_queue_hd != END_TSO_QUEUE || 
+       run_queue_hd     != END_TSO_QUEUE ||
+       sleeping_queue   != END_TSO_QUEUE);
+}
+
 SchedulerStatus
 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 {
@@ -1892,6 +1943,7 @@ take_off_run_queue(StgTSO *tso) {
 
         - all the threads on the runnable queue
         - all the threads on the blocked queue
+        - all the threads on the sleeping queue
 	- all the thread currently executing a _ccall_GC
         - all the "main threads"
      
@@ -1938,6 +1990,10 @@ static void GetRoots(void)
     blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
     blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
   }
+
+  if (sleeping_queue != END_TSO_QUEUE) {
+    sleeping_queue  = (StgTSO *)MarkRoot((StgClosure *)sleeping_queue);
+  }
 #endif 
 
   for (m = main_threads; m != NULL; m = m->link) {
@@ -1970,7 +2026,13 @@ void (*extra_roots)(void);
 void
 performGC(void)
 {
-  GarbageCollect(GetRoots);
+  GarbageCollect(GetRoots,rtsFalse);
+}
+
+void
+performMajorGC(void)
+{
+  GarbageCollect(GetRoots,rtsTrue);
 }
 
 static void
@@ -1985,7 +2047,7 @@ performGCWithRoots(void (*get_roots)(void))
 {
   extra_roots = get_roots;
 
-  GarbageCollect(AllRoots);
+  GarbageCollect(AllRoots,rtsFalse);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2049,7 +2111,6 @@ threadStackOverflow(StgTSO *tso)
   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
   dest->sp    = new_sp;
-  dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
   dest->stack_size = new_stack_size;
 	
   /* and relocate the update frame list */
@@ -2091,8 +2152,6 @@ threadStackOverflow(StgTSO *tso)
    Wake up a queue that was blocked on some resource.
    ------------------------------------------------------------------------ */
 
-/* ToDo: check push_on_run_queue vs. PUSH_ON_RUN_QUEUE */
-
 #if defined(GRAN)
 static inline void
 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
@@ -2196,9 +2255,9 @@ unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
 	 see comments on RBHSave closures above */
     case CONSTR:
       /* check that the closure is an RBHSave closure */
-      ASSERT(get_itbl((StgClosure *)bqe) == &RBH_Save_0_info ||
-	     get_itbl((StgClosure *)bqe) == &RBH_Save_1_info ||
-	     get_itbl((StgClosure *)bqe) == &RBH_Save_2_info);
+      ASSERT(get_itbl((StgClosure *)bqe) == &stg_RBH_Save_0_info ||
+	     get_itbl((StgClosure *)bqe) == &stg_RBH_Save_1_info ||
+	     get_itbl((StgClosure *)bqe) == &stg_RBH_Save_2_info);
       break;
 
     default:
@@ -2463,7 +2522,6 @@ unblockThread(StgTSO *tso)
       barf("unblockThread (Exception): TSO not found");
     }
 
-  case BlockedOnDelay:
   case BlockedOnRead:
   case BlockedOnWrite:
     {
@@ -2488,6 +2546,23 @@ unblockThread(StgTSO *tso)
       barf("unblockThread (I/O): TSO not found");
     }
 
+  case BlockedOnDelay:
+    {
+      StgBlockingQueueElement *prev = NULL;
+      for (t = (StgBlockingQueueElement *)sleeping_queue; t != END_BQ_QUEUE; 
+	   prev = t, t = t->link) {
+	if (t == (StgBlockingQueueElement *)tso) {
+	  if (prev == NULL) {
+	    sleeping_queue = (StgTSO *)t->link;
+	  } else {
+	    prev->link = t->link;
+	  }
+	  goto done;
+	}
+      }
+      barf("unblockThread (I/O): TSO not found");
+    }
+
   default:
     barf("unblockThread");
   }
@@ -2566,7 +2641,6 @@ unblockThread(StgTSO *tso)
       barf("unblockThread (Exception): TSO not found");
     }
 
-  case BlockedOnDelay:
   case BlockedOnRead:
   case BlockedOnWrite:
     {
@@ -2591,6 +2665,23 @@ unblockThread(StgTSO *tso)
       barf("unblockThread (I/O): TSO not found");
     }
 
+  case BlockedOnDelay:
+    {
+      StgTSO *prev = NULL;
+      for (t = sleeping_queue; t != END_TSO_QUEUE; 
+	   prev = t, t = t->link) {
+	if (t == tso) {
+	  if (prev == NULL) {
+	    sleeping_queue = t->link;
+	  } else {
+	    prev->link = t->link;
+	  }
+	  goto done;
+	}
+      }
+      barf("unblockThread (I/O): TSO not found");
+    }
+
   default:
     barf("unblockThread");
   }
@@ -2664,7 +2755,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
    * returns to the next return address on the stack.
    */
   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
-    *(--sp) = (W_)&dummy_ret_closure;
+    *(--sp) = (W_)&stg_dummy_ret_closure;
   }
 
   while (1) {
@@ -2683,11 +2774,11 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
        */
       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 2);
       TICK_ALLOC_UPD_PAP(3,0);
-      SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
+      SET_HDR(ap,&stg_PAP_info,cf->header.prof.ccs);
 	      
       ap->n_args = 2;
       ap->fun = cf->handler;	/* :: Exception -> IO a */
-      ap->payload[0] = (P_)exception;
+      ap->payload[0] = exception;
       ap->payload[1] = ARG_TAG(0); /* realworld token */
 
       /* throw away the stack from Sp up to and including the
@@ -2704,7 +2795,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
        * unblockAsyncExceptions_ret stack frame.
        */
       if (!cf->exceptions_blocked) {
-	*(sp--) = (W_)&unblockAsyncExceptionszh_ret_info;
+	*(sp--) = (W_)&stg_unblockAsyncExceptionszh_ret_info;
       }
       
       /* Ensure that async exceptions are blocked when running the handler.
@@ -2719,6 +2810,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
       sp[0] = (W_)ap;
       tso->sp = sp;
       tso->what_next = ThreadEnterGHC;
+      IF_DEBUG(sanity, checkTSO(tso));
       return;
     }
 
@@ -2734,14 +2826,14 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
     ap->fun    = (StgClosure *)sp[0];
     sp++;
     for(i=0; i < (nat)words; ++i) {
-      ap->payload[i] = (P_)*sp++;
+      ap->payload[i] = (StgClosure *)*sp++;
     }
     
     switch (get_itbl(su)->type) {
       
     case UPDATE_FRAME:
       {
-	SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */); 
+	SET_HDR(ap,&stg_AP_UPD_info,su->header.prof.ccs /* ToDo */); 
 	TICK_ALLOC_UP_THK(words+1,0);
 	
 	IF_DEBUG(scheduler,
@@ -2770,13 +2862,13 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
 	/* We want a PAP, not an AP_UPD.  Fortunately, the
 	 * layout's the same.
 	 */
-	SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+	SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
 	TICK_ALLOC_UPD_PAP(words+1,0);
 	
 	/* now build o = FUN(catch,ap,handler) */
 	o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
 	TICK_ALLOC_FUN(2,0);
-	SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
+	SET_HDR(o,&stg_catch_info,su->header.prof.ccs /* ToDo */);
 	o->payload[0] = (StgClosure *)ap;
 	o->payload[1] = cf->handler;
 	
@@ -2797,13 +2889,13 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
 	StgSeqFrame *sf = (StgSeqFrame *)su;
 	StgClosure* o;
 	
-	SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+	SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
 	TICK_ALLOC_UPD_PAP(words+1,0);
 	
 	/* now build o = FUN(seq,ap) */
 	o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
 	TICK_ALLOC_SE_THK(1,0);
-	SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
+	SET_HDR(o,&stg_seq_info,su->header.prof.ccs /* ToDo */);
 	o->payload[0] = (StgClosure *)ap;
 	
 	IF_DEBUG(scheduler,
@@ -2826,7 +2918,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
       tso->su = (StgUpdateFrame *)(sp+1);
       tso->sp = sp;
       return;
-      
+
     default:
       barf("raiseAsync");
     }
@@ -2873,6 +2965,61 @@ resurrectThreads( StgTSO *threads )
   }
 }
 
+/* -----------------------------------------------------------------------------
+ * Blackhole detection: if we reach a deadlock, test whether any
+ * threads are blocked on themselves.  Any threads which are found to
+ * be self-blocked get sent a NonTermination exception.
+ *
+ * This is only done in a deadlock situation in order to avoid
+ * performance overhead in the normal case.
+ * -------------------------------------------------------------------------- */
+
+static void
+detectBlackHoles( void )
+{
+    StgTSO *t = all_threads;
+    StgUpdateFrame *frame;
+    StgClosure *blocked_on;
+
+    for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+
+	if (t->why_blocked != BlockedOnBlackHole) {
+	    continue;
+	}
+
+	blocked_on = t->block_info.closure;
+
+	for (frame = t->su; ; frame = frame->link) {
+	    switch (get_itbl(frame)->type) {
+
+	    case UPDATE_FRAME:
+		if (frame->updatee == blocked_on) {
+		    /* We are blocking on one of our own computations, so
+		     * send this thread the NonTermination exception.  
+		     */
+		    IF_DEBUG(scheduler, 
+			     sched_belch("thread %d is blocked on itself", t->id));
+		    raiseAsync(t, (StgClosure *)NonTermination_closure);
+		    goto done;
+		}
+		else {
+		    continue;
+		}
+
+	    case CATCH_FRAME:
+	    case SEQ_FRAME:
+		continue;
+		
+	    case STOP_FRAME:
+		break;
+	    }
+	    break;
+	}
+
+    done:
+    }   
+}
+
 //@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
 //@subsection Debugging Routines
 
@@ -2887,39 +3034,34 @@ printThreadBlockage(StgTSO *tso)
 {
   switch (tso->why_blocked) {
   case BlockedOnRead:
-    fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
+    fprintf(stderr,"is blocked on read from fd %d", tso->block_info.fd);
     break;
   case BlockedOnWrite:
-    fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
+    fprintf(stderr,"is blocked on write to fd %d", tso->block_info.fd);
     break;
   case BlockedOnDelay:
-#if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
-    fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
-#else
-    fprintf(stderr,"blocked on delay of %d ms", 
-	    tso->block_info.target - getourtimeofday());
-#endif
+    fprintf(stderr,"is blocked until %d", tso->block_info.target);
     break;
   case BlockedOnMVar:
-    fprintf(stderr,"blocked on an MVar");
+    fprintf(stderr,"is blocked on an MVar");
     break;
   case BlockedOnException:
-    fprintf(stderr,"blocked on delivering an exception to thread %d",
+    fprintf(stderr,"is blocked on delivering an exception to thread %d",
 	    tso->block_info.tso->id);
     break;
   case BlockedOnBlackHole:
-    fprintf(stderr,"blocked on a black hole");
+    fprintf(stderr,"is blocked on a black hole");
     break;
   case NotBlocked:
-    fprintf(stderr,"not blocked");
+    fprintf(stderr,"is not blocked");
     break;
 #if defined(PAR)
   case BlockedOnGA:
-    fprintf(stderr,"blocked on global address; local FM_BQ is %p (%s)",
+    fprintf(stderr,"is blocked on global address; local FM_BQ is %p (%s)",
 	    tso->block_info.closure, info_type(tso->block_info.closure));
     break;
   case BlockedOnGA_NoSend:
-    fprintf(stderr,"blocked on global address (no send); local FM_BQ is %p (%s)",
+    fprintf(stderr,"is blocked on global address (no send); local FM_BQ is %p (%s)",
 	    tso->block_info.closure, info_type(tso->block_info.closure));
     break;
 #endif
@@ -2951,7 +3093,7 @@ printAllThreads(void)
 
   sched_belch("all threads:");
   for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
-    fprintf(stderr, "\tthread %d is ", t->id);
+    fprintf(stderr, "\tthread %d ", t->id);
     printThreadStatus(t);
     fprintf(stderr,"\n");
   }
@@ -3007,9 +3149,9 @@ print_bq (StgClosure *node)
       break;
     case CONSTR:
       fprintf(stderr," %s (IP %p),",
-	      (get_itbl(bqe) == &RBH_Save_0_info ? "RBH_Save_0" :
-	       get_itbl(bqe) == &RBH_Save_1_info ? "RBH_Save_1" :
-	       get_itbl(bqe) == &RBH_Save_2_info ? "RBH_Save_2" :
+	      (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
+	       get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
+	       get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
 	       "RBH_Save_?"), get_itbl(bqe));
       break;
     default:
@@ -3061,9 +3203,9 @@ print_bq (StgClosure *node)
       break;
     case CONSTR:
       fprintf(stderr," %s (IP %p),",
-	      (get_itbl(bqe) == &RBH_Save_0_info ? "RBH_Save_0" :
-	       get_itbl(bqe) == &RBH_Save_1_info ? "RBH_Save_1" :
-	       get_itbl(bqe) == &RBH_Save_2_info ? "RBH_Save_2" :
+	      (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
+	       get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
+	       get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
 	       "RBH_Save_?"), get_itbl(bqe));
       break;
     default: