[project @ 2002-06-26 08:18:38 by stolz]
[ghc-hetmet.git] / ghc / rts / Schedule.c
index d73559e..530bdf9 100644 (file)
@@ -1,5 +1,5 @@
 /* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.122 2002/02/13 08:48:06 sof Exp $
+ * $Id: Schedule.c,v 1.146 2002/06/26 08:18:42 stolz Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -96,6 +96,7 @@
 #include "Stats.h"
 #include "Itimer.h"
 #include "Prelude.h"
+#include "ThreadLabels.h"
 #ifdef PROFILING
 #include "Proftimer.h"
 #include "ProfHeap.h"
 #include "OSThreads.h"
 #include  "Task.h"
 
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 #include <stdarg.h>
 
 //@node Variables and Data structures, Prototypes, Includes, Main scheduling code
 //@subsection Variables and Data structures
 
-/* Main threads:
- *
- * These are the threads which clients have requested that we run.  
- *
- * In a 'threaded' build, we might have several concurrent clients all
- * waiting for results, and each one will wait on a condition variable
- * until the result is available.
- *
- * In non-SMP, clients are strictly nested: the first client calls
- * into the RTS, which might call out again to C with a _ccall_GC, and
- * eventually re-enter the RTS.
- *
- * Main threads information is kept in a linked list:
- */
-//@cindex StgMainThread
-typedef struct StgMainThread_ {
-  StgTSO *         tso;
-  SchedulerStatus  stat;
-  StgClosure **    ret;
-#if defined(RTS_SUPPORTS_THREADS)
-  Condition        wakeup;
-#endif
-  struct StgMainThread_ *link;
-} StgMainThread;
-
 /* Main thread queue.
  * Locks required: sched_mutex.
  */
-static StgMainThread *main_threads;
+StgMainThread *main_threads;
 
 /* Thread queues.
  * Locks required: sched_mutex.
@@ -207,7 +190,7 @@ nat context_switch;
 rtsBool interrupted;
 
 /* Next thread ID to allocate.
- * Locks required: sched_mutex
+ * Locks required: thread_id_mutex
  */
 //@cindex next_thread_id
 StgThreadID next_thread_id = 1;
@@ -243,15 +226,17 @@ StgTSO dummy_tso;
 
 rtsBool ready_to_gc;
 
+/*
+ * Set to TRUE when entering a shutdown state (via shutdownHaskellAndExit()) --
+ * in an MT setting, needed to signal that a worker thread shouldn't hang around
+ * in the scheduler when it is out of work.
+ */
+static rtsBool shutting_down_scheduler = rtsFalse;
+
 void            addToBlockedQueue ( StgTSO *tso );
 
 static void     schedule          ( void );
        void     interruptStgRts   ( void );
-#if defined(GRAN)
-static StgTSO * createThread_     ( nat size, rtsBool have_lock, StgInt pri );
-#else
-static StgTSO * createThread_     ( nat size, rtsBool have_lock );
-#endif
 
 static void     detectBlackHoles  ( void );
 
@@ -266,66 +251,11 @@ static void sched_belch(char *s, ...);
 Mutex     sched_mutex       = INIT_MUTEX_VAR;
 Mutex     term_mutex        = INIT_MUTEX_VAR;
 
-
 /*
- * When a native thread has completed executing an external
- * call, it needs to communicate the result back to the
- * (Haskell) thread that made the call. Do this as follows:
- *
- *  - in resumeThread(), the thread increments the counter
- *    rts_n_returning_workers, and then blocks waiting on the
- *    condition returning_worker_cond.
- *  - upon entry to the scheduler, a worker/task checks 
- *    rts_n_returning_workers. If it is > 0, worker threads
- *    are waiting to return, so it gives up its capability
- *    to let a worker deposit its result.
- *  - the worker thread that gave up its capability then tries
- *    to re-grab a capability and re-enter the Scheduler.
+ * A heavyweight solution to the problem of protecting
+ * the thread_id from concurrent update.
  */
-
-
-/* thread_ready_cond: when signalled, a thread has become runnable for a
- * task to execute.
- *
- * In the non-SMP case, it also implies that the thread that is woken up has
- * exclusive access to the RTS and all its data structures (that are not
- * under sched_mutex's control).
- *
- * thread_ready_cond is signalled whenever COND_NO_THREADS_READY doesn't hold.
- *
- */
-Condition thread_ready_cond = INIT_COND_VAR;
-#if 0
-/* For documentation purposes only */
-#define COND_NO_THREADS_READY() (noCapabilities() || EMPTY_RUN_QUEUE())
-#endif
-
-/*
- * To be able to make an informed decision about whether or not 
- * to create a new task when making an external call, keep track of
- * the number of tasks currently blocked waiting on thread_ready_cond.
- * (if > 0 => no need for a new task, just unblock an existing one).
- */
-nat rts_n_waiting_tasks = 0;
-
-/* returning_worker_cond: when a worker thread returns from executing an
- * external call, it needs to wait for an RTS Capability before passing
- * on the result of the call to the Haskell thread that made it.
- * 
- * returning_worker_cond is signalled in Capability.releaseCapability().
- *
- */
-Condition returning_worker_cond = INIT_COND_VAR;
-
-/*
- * To avoid starvation of threads blocked on worker_thread_cond,
- * the task(s) that enter the Scheduler will check to see whether
- * there are one or more worker threads blocked waiting on
- * returning_worker_cond.
- *
- * Locks needed: sched_mutex
- */
-nat rts_n_waiting_workers = 0;
+Mutex     thread_id_mutex   = INIT_MUTEX_VAR;
 
 
 # if defined(SMP)
@@ -440,41 +370,17 @@ schedule( void )
 # endif
 #endif
   rtsBool was_interrupted = rtsFalse;
-
-#if defined(RTS_SUPPORTS_THREADS)
-schedule_start:
-#endif
   
-#if defined(RTS_SUPPORTS_THREADS)
   ACQUIRE_LOCK(&sched_mutex);
-#endif
  
 #if defined(RTS_SUPPORTS_THREADS)
-  /* ToDo: consider SMP support */
-  if ( rts_n_waiting_workers > 0 && noCapabilities() ) {
-    /* (At least) one native thread is waiting to
-     * deposit the result of an external call. So,
-     * be nice and hand over our capability.
-     */
-    IF_DEBUG(scheduler, sched_belch("worker thread (%d): giving up RTS token (waiting workers: %d)\n", osThreadId(), rts_n_waiting_workers));
-    releaseCapability(cap);
-    RELEASE_LOCK(&sched_mutex);
-
-    yieldThread();
-    goto schedule_start;
-  }
-#endif
-
-#if defined(RTS_SUPPORTS_THREADS)
-  while ( noCapabilities() ) {
-    rts_n_waiting_tasks++;
-    waitCondition(&thread_ready_cond, &sched_mutex);
-    rts_n_waiting_tasks--;
-  }
+  waitForWorkCapability(&sched_mutex, &cap, rtsFalse);
+#else
+  /* simply initialise it in the non-threaded case */
+  grabCapability(&cap);
 #endif
 
 #if defined(GRAN)
-
   /* set up first event to get things going */
   /* ToDo: assign costs for system setup and init MainTSO ! */
   new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
@@ -509,6 +415,13 @@ schedule_start:
 
     IF_DEBUG(scheduler, printAllThreads());
 
+#if defined(RTS_SUPPORTS_THREADS)
+    /* Check to see whether there are any worker threads
+       waiting to deposit external call results. If so,
+       yield our capability */
+    yieldToReturningWorker(&sched_mutex, &cap);
+#endif
+
     /* If we're interrupted (the user pressed ^C, or some other
      * termination condition occurred), kill all the currently running
      * threads.
@@ -538,6 +451,9 @@ schedule_start:
          *prev = m->link;
          m->stat = Success;
          broadcastCondition(&m->wakeup);
+#ifdef DEBUG
+         removeThreadLabel(m->tso);
+#endif
          break;
        case ThreadKilled:
          if (m->ret) *(m->ret) = NULL;
@@ -548,6 +464,9 @@ schedule_start:
            m->stat = Killed;
          }
          broadcastCondition(&m->wakeup);
+#ifdef DEBUG
+         removeThreadLabel(m->tso);
+#endif
          break;
        default:
          break;
@@ -567,6 +486,9 @@ schedule_start:
       StgMainThread *m = main_threads;
       if (m->tso->what_next == ThreadComplete
          || m->tso->what_next == ThreadKilled) {
+#ifdef DEBUG
+       removeThreadLabel((StgWord)m->tso);
+#endif
        main_threads = main_threads->link;
        if (m->tso->what_next == ThreadComplete) {
          /* we finished successfully, fill in the return value */
@@ -631,7 +553,9 @@ schedule_start:
     /* check for signals each time around the scheduler */
 #ifndef mingw32_TARGET_OS
     if (signals_pending()) {
+      RELEASE_LOCK(&sched_mutex); /* ToDo: kill */
       startSignalHandlers();
+      ACQUIRE_LOCK(&sched_mutex);
     }
 #endif
 
@@ -663,9 +587,7 @@ schedule_start:
      * inform all the main threads.
      */
 #ifndef PAR
-    if (   EMPTY_RUN_QUEUE()
-       && EMPTY_QUEUE(blocked_queue_hd)
-       && EMPTY_QUEUE(sleeping_queue)
+    if (   EMPTY_THREAD_QUEUES()
 #if defined(RTS_SUPPORTS_THREADS)
        && EMPTY_QUEUE(suspended_ccalling_threads)
 #endif
@@ -679,39 +601,65 @@ schedule_start:
        /* and SMP mode ..? */
        releaseCapability(cap);
 #endif
-       RELEASE_LOCK(&sched_mutex);
+       // Garbage collection can release some new threads due to
+       // either (a) finalizers or (b) threads resurrected because
+       // they are about to be send BlockedOnDeadMVar.  Any threads
+       // thus released will be immediately runnable.
        GarbageCollect(GetRoots,rtsTrue);
-       ACQUIRE_LOCK(&sched_mutex);
-       if (   EMPTY_QUEUE(blocked_queue_hd)
-           && EMPTY_RUN_QUEUE()
-           && EMPTY_QUEUE(sleeping_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 ( EMPTY_RUN_QUEUE() ) {
-               StgMainThread *m;
+
+       if ( !EMPTY_RUN_QUEUE() ) { goto not_deadlocked; }
+
+       IF_DEBUG(scheduler, 
+                sched_belch("still deadlocked, checking for black holes..."));
+       detectBlackHoles();
+
+       if ( !EMPTY_RUN_QUEUE() ) { goto not_deadlocked; }
+
+#ifndef mingw32_TARGET_OS
+       /* If we have user-installed signal handlers, then wait
+        * for signals to arrive rather then bombing out with a
+        * deadlock.
+        */
 #if defined(RTS_SUPPORTS_THREADS)
-               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");
-                   }
-               }
+       if ( 0 ) { /* hmm..what to do? Simply stop waiting for
+                     a signal with no runnable threads (or I/O
+                     suspended ones) leads nowhere quick.
+                     For now, simply shut down when we reach this
+                     condition.
+                     
+                     ToDo: define precisely under what conditions
+                     the Scheduler should shut down in an MT setting.
+                  */
 #else
-               m = main_threads;
+       if ( anyUserHandlers() ) {
+#endif
+           IF_DEBUG(scheduler, 
+                    sched_belch("still deadlocked, waiting for signals..."));
+
+           awaitUserSignals();
+
+           // we might be interrupted...
+           if (interrupted) { continue; }
+
+           if (signals_pending()) {
+               RELEASE_LOCK(&sched_mutex);
+               startSignalHandlers();
+               ACQUIRE_LOCK(&sched_mutex);
+           }
+           ASSERT(!EMPTY_RUN_QUEUE());
+           goto not_deadlocked;
+       }
+#endif
+
+       /* 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).
+        */
+       {
+           StgMainThread *m;
+#if defined(RTS_SUPPORTS_THREADS)
+           for (m = main_threads; m != NULL; m = m->link) {
                switch (m->tso->why_blocked) {
                case BlockedOnBlackHole:
                    raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
@@ -723,20 +671,34 @@ schedule_start:
                default:
                    barf("deadlock: main thread blocked in a strange way");
                }
-#endif
            }
-#if defined(RTS_SUPPORTS_THREADS)
-           /* ToDo: revisit conditions (and mechanism) for shutting
-              down a multi-threaded world  */
-           if ( EMPTY_RUN_QUEUE() ) {
-             IF_DEBUG(scheduler, sched_belch("all done, i think...shutting down."));
-             shutdownHaskellAndExit(0);
-           
+#else
+           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( !EMPTY_RUN_QUEUE() );
        }
+
+#if defined(RTS_SUPPORTS_THREADS)
+       /* ToDo: revisit conditions (and mechanism) for shutting
+          down a multi-threaded world  */
+       IF_DEBUG(scheduler, sched_belch("all done, i think...shutting down."));
+       RELEASE_LOCK(&sched_mutex);
+       shutdownHaskell();
+       return;
+#endif
     }
+  not_deadlocked:
+
 #elif defined(PAR)
     /* ToDo: add deadlock detection in GUM (similar to SMP) -- HWL */
 #endif
@@ -759,18 +721,21 @@ schedule_start:
     if ( EMPTY_RUN_QUEUE() ) {
       /* Give up our capability */
       releaseCapability(cap);
-      while ( noCapabilities() || EMPTY_RUN_QUEUE() ) {
-       IF_DEBUG(scheduler, sched_belch("thread %d: waiting for work", osThreadId()));
-       rts_n_waiting_tasks++;
-       waitCondition( &thread_ready_cond, &sched_mutex );
-       rts_n_waiting_tasks--;
-       IF_DEBUG(scheduler, sched_belch("thread %d: work now available %d %d", osThreadId(), getFreeCapabilities(),EMPTY_RUN_QUEUE()));
+
+      /* If we're in the process of shutting down (& running the
+       * a batch of finalisers), don't wait around.
+       */
+      if ( shutting_down_scheduler ) {
+       RELEASE_LOCK(&sched_mutex);
+       return;
       }
+      IF_DEBUG(scheduler, sched_belch("thread %d: waiting for work", osThreadId()));
+      waitForWorkCapability(&sched_mutex, &cap, rtsTrue);
+      IF_DEBUG(scheduler, sched_belch("thread %d: work now available", osThreadId()));
     }
 #endif
 
 #if defined(GRAN)
-
     if (RtsFlags.GranFlags.Light)
       GranSimLight_enter_system(event, &ActiveTSO); // adjust ActiveTSO etc
 
@@ -1016,7 +981,7 @@ schedule_start:
             belch("--=^ %d threads, %d sparks on [%#x]", 
                   run_queue_len(), spark_queue_len(pool), CURRENT_PROC));
 
-#if 1
+# if 1
     if (0 && RtsFlags.ParFlags.ParStats.Full && 
        t && LastTSO && t->id != LastTSO->id && 
        LastTSO->why_blocked == NotBlocked && 
@@ -1041,7 +1006,7 @@ schedule_start:
       emitSchedule = rtsFalse;
     }
      
-#endif
+# endif
 #else /* !GRAN && !PAR */
   
     /* grab a thread from the run queue */
@@ -1052,7 +1017,6 @@ schedule_start:
     IF_DEBUG(sanity,checkTSO(t));
 #endif
     
-    grabCapability(&cap);
     cap->r.rCurrentTSO = t;
     
     /* context switches are now initiated by the timer signal, unless
@@ -1400,11 +1364,6 @@ schedule_start:
     default:
       barf("schedule: invalid thread return code %d", (int)ret);
     }
-    
-#if defined(RTS_SUPPORTS_THREADS)
-    /* I don't understand what this re-grab is doing -- sof */
-    grabCapability(&cap);
-#endif
 
 #ifdef PROFILING
     if (RtsFlags.ProfFlags.profileInterval==0 || performHeapProfile) {
@@ -1415,12 +1374,11 @@ schedule_start:
     }
 #endif
 
+    if (ready_to_gc 
 #ifdef SMP
-    if (ready_to_gc && allFreeCapabilities() )
-#else
-    if (ready_to_gc) 
+       && allFreeCapabilities() 
 #endif
-      {
+       ) {
       /* everybody back, start the GC.
        * Could do it in this thread, or signal a condition var
        * to do it in another thread.  Either way, we need to
@@ -1464,28 +1422,63 @@ schedule_start:
 }
 
 /* ---------------------------------------------------------------------------
+ * Singleton fork(). Do not copy any running threads.
+ * ------------------------------------------------------------------------- */
+
+StgInt forkProcess(StgTSO* tso) {
+
+#ifndef mingw32_TARGET_OS
+  pid_t pid;
+  StgTSO* t,*next;
+
+  IF_DEBUG(scheduler,sched_belch("forking!"));
+
+  pid = fork();
+  if (pid) { /* parent */
+
+  /* just return the pid */
+    
+  } else { /* child */
+  /* wipe all other threads */
+  run_queue_hd = tso;
+  tso->link = END_TSO_QUEUE;
+
+  /* DO NOT TOUCH THE QUEUES directly because most of the code around
+     us is picky about finding the threat still in its queue when
+     handling the deleteThread() */
+
+  for (t = all_threads; t != END_TSO_QUEUE; t = next) {
+    next = t->link;
+    if (t->id != tso->id) {
+      deleteThread(t);
+    }
+  }
+  }
+  return pid;
+#else /* mingw32 */
+  barf("forkProcess#: primop not implemented for mingw32, sorry! (%u)\n", tso->id);
+  /* pointlessly printing out the TSOs 'id' to avoid CC unused warning. */
+  return -1;
+#endif /* mingw32 */
+}
+
+/* ---------------------------------------------------------------------------
  * deleteAllThreads():  kill all the live threads.
  *
  * This is used when we catch a user interrupt (^C), before performing
  * any necessary cleanups and running finalizers.
+ *
+ * Locks: sched_mutex held.
  * ------------------------------------------------------------------------- */
    
 void deleteAllThreads ( void )
 {
   StgTSO* t, *next;
   IF_DEBUG(scheduler,sched_belch("deleting all threads"));
-  for (t = run_queue_hd; t != END_TSO_QUEUE; t = next) {
-      next = t->link;
+  for (t = all_threads; t != END_TSO_QUEUE; t = next) {
+      next = t->global_link;
       deleteThread(t);
-  }
-  for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = next) {
-      next = t->link;
-      deleteThread(t);
-  }
-  for (t = sleeping_queue; t != END_TSO_QUEUE; t = next) {
-      next = 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;
@@ -1513,7 +1506,12 @@ void deleteAllThreads ( void )
  * ------------------------------------------------------------------------- */
    
 StgInt
-suspendThread( StgRegTable *reg )
+suspendThread( StgRegTable *reg, 
+              rtsBool concCall
+#if !defined(RTS_SUPPORTS_THREADS) && !defined(DEBUG)
+              STG_UNUSED
+#endif
+              )
 {
   nat tok;
   Capability *cap;
@@ -1526,7 +1524,7 @@ suspendThread( StgRegTable *reg )
   ACQUIRE_LOCK(&sched_mutex);
 
   IF_DEBUG(scheduler,
-          sched_belch("thread %d did a _ccall_gc", cap->r.rCurrentTSO->id));
+          sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
 
   threadPaused(cap->r.rCurrentTSO);
   cap->r.rCurrentTSO->link = suspended_ccalling_threads;
@@ -1542,7 +1540,7 @@ suspendThread( StgRegTable *reg )
   /* Hand back capability */
   releaseCapability(cap);
   
-#if defined(RTS_SUPPORTS_THREADS) && !defined(SMP)
+#if defined(RTS_SUPPORTS_THREADS)
   /* Preparing to leave the RTS, so ensure there's a native thread/task
      waiting to take over.
      
@@ -1550,37 +1548,39 @@ suspendThread( StgRegTable *reg )
      for one (i.e., if there's only one Concurrent Haskell thread alive,
      there's no need to create a new task).
   */
-  IF_DEBUG(scheduler, sched_belch("worker thread (%d): leaving RTS\n", tok));
-  startTask(taskStart);
+  IF_DEBUG(scheduler, sched_belch("worker thread (%d): leaving RTS", tok));
+  if (concCall) {
+    startTask(taskStart);
+  }
 #endif
 
+  /* Other threads _might_ be available for execution; signal this */
   THREAD_RUNNABLE();
   RELEASE_LOCK(&sched_mutex);
   return tok; 
 }
 
 StgRegTable *
-resumeThread( StgInt tok )
+resumeThread( StgInt tok,
+             rtsBool concCall
+#if !defined(RTS_SUPPORTS_THREADS)
+              STG_UNUSED
+#endif
+             )
 {
   StgTSO *tso, **prev;
   Capability *cap;
 
 #if defined(RTS_SUPPORTS_THREADS)
-  IF_DEBUG(scheduler, sched_belch("worker %d: returning, waiting for sched. lock.\n", tok));
-  ACQUIRE_LOCK(&sched_mutex);
-  rts_n_waiting_workers++;
-  IF_DEBUG(scheduler, sched_belch("worker %d: returning; workers waiting: %d.\n", tok, rts_n_waiting_workers));
-
-  /*
-   * Wait for the go ahead
-   */
-  IF_DEBUG(scheduler, sched_belch("worker %d: waiting for capability %d...\n", tok, rts_n_free_capabilities));
-  while ( noCapabilities() ) {
-    waitCondition(&returning_worker_cond, &sched_mutex);
+  /* Wait for permission to re-enter the RTS with the result. */
+  if ( concCall ) {
+    ACQUIRE_LOCK(&sched_mutex);
+    grabReturnCapability(&sched_mutex, &cap);
+  } else {
+    grabCapability(&cap);
   }
-  rts_n_waiting_workers--;
-
-  IF_DEBUG(scheduler, sched_belch("worker %d: acquired capability...\n", tok));
+#else
+  grabCapability(&cap);
 #endif
 
   /* Remove the thread off of the suspended list */
@@ -1597,28 +1597,11 @@ resumeThread( StgInt tok )
     barf("resumeThread: thread not found");
   }
   tso->link = END_TSO_QUEUE;
-
-#if defined(RTS_SUPPORTS_THREADS)
-  /* Is it clever to block here with the TSO off the list,
-   * but not hooked up to a capability?
-   */
-  while ( noCapabilities() ) {
-    IF_DEBUG(scheduler, sched_belch("waiting to resume"));
-    rts_n_waiting_tasks++;
-    waitCondition(&thread_ready_cond, &sched_mutex);
-    rts_n_waiting_tasks--;
-    IF_DEBUG(scheduler, sched_belch("resuming thread %d", tso->id));
-  }
-#endif
-
-  grabCapability(&cap);
-  RELEASE_LOCK(&sched_mutex);
-
   /* Reset blocking status */
   tso->why_blocked  = NotBlocked;
 
   cap->r.rCurrentTSO = tso;
-
+  RELEASE_LOCK(&sched_mutex);
   return &cap->r;
 }
 
@@ -1655,6 +1638,24 @@ int rts_getThreadId(const StgTSO *tso)
   return tso->id;
 }
 
+#ifdef DEBUG
+void labelThread(StgTSO *tso, char *label)
+{
+  int len;
+  void *buf;
+
+  /* Caveat: Once set, you can only set the thread name to "" */
+  len = strlen(label)+1;
+  buf = malloc(len);
+  if (buf == NULL) {
+    fprintf(stderr,"insufficient memory for labelThread!\n");
+  } else
+    strncpy(buf,label,len);
+  /* Update will free the old memory for us */
+  updateThreadLabel((StgWord)tso,buf);
+}
+#endif /* DEBUG */
+
 /* ---------------------------------------------------------------------------
    Create a new thread.
 
@@ -1672,25 +1673,12 @@ int rts_getThreadId(const StgTSO *tso)
 #if defined(GRAN)
 /*   currently pri (priority) is only used in a GRAN setup -- HWL */
 StgTSO *
-createThread(nat stack_size, StgInt pri)
-{
-  return createThread_(stack_size, rtsFalse, pri);
-}
-
-static StgTSO *
-createThread_(nat size, rtsBool have_lock, StgInt pri)
-{
+createThread(nat size, StgInt pri)
 #else
 StgTSO *
-createThread(nat stack_size)
-{
-  return createThread_(stack_size, rtsFalse);
-}
-
-static StgTSO *
-createThread_(nat size, rtsBool have_lock)
-{
+createThread(nat size)
 #endif
+{
 
     StgTSO *tso;
     nat stack_size;
@@ -1733,9 +1721,9 @@ createThread_(nat size, rtsBool have_lock)
    * protect the increment operation on next_thread_id.
    * In future, we could use an atomic increment instead.
    */
-  if (!have_lock) { ACQUIRE_LOCK(&sched_mutex); }
+  ACQUIRE_LOCK(&thread_id_mutex);
   tso->id = next_thread_id++; 
-  if (!have_lock) { RELEASE_LOCK(&sched_mutex); }
+  RELEASE_LOCK(&thread_id_mutex);
 
   tso->why_blocked  = NotBlocked;
   tso->blocked_exceptions = NULL;
@@ -1872,7 +1860,7 @@ createSparkThread(rtsSpark spark)
   }
   else
   { threadsCreated++;
-    tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
+    tso = createThread(RtsFlags.GcFlags.initialStkSize);
     if (tso==END_TSO_QUEUE)    
       barf("createSparkThread: Cannot create TSO");
 #if defined(DIST)
@@ -1913,6 +1901,13 @@ activateSpark (rtsSpark spark)
 }
 #endif
 
+static SchedulerStatus waitThread_(/*out*/StgMainThread* m
+#if defined(THREADED_RTS)
+                                  , rtsBool blockWaiting
+#endif
+                                  );
+
+
 /* ---------------------------------------------------------------------------
  * scheduleThread()
  *
@@ -1923,10 +1918,13 @@ activateSpark (rtsSpark spark)
  * on this thread's stack before the scheduler is invoked.
  * ------------------------------------------------------------------------ */
 
+static void scheduleThread_ (StgTSO* tso, rtsBool createTask);
+
 void
 scheduleThread_(StgTSO *tso
-#if defined(THREADED_RTS)
               , rtsBool createTask
+#if !defined(THREADED_RTS)
+                STG_UNUSED
 #endif
              )
 {
@@ -1956,10 +1954,47 @@ scheduleThread_(StgTSO *tso
 
 void scheduleThread(StgTSO* tso)
 {
+  scheduleThread_(tso, rtsFalse);
+}
+
+SchedulerStatus
+scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret)
+{
+  StgMainThread *m;
+
+  m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
+  m->tso = tso;
+  m->ret = ret;
+  m->stat = NoStatus;
+#if defined(RTS_SUPPORTS_THREADS)
+  initCondition(&m->wakeup);
+#endif
+
+  /* Put the thread on the main-threads list prior to scheduling the TSO.
+     Failure to do so introduces a race condition in the MT case (as
+     identified by Wolfgang Thaller), whereby the new task/OS thread 
+     created by scheduleThread_() would complete prior to the thread
+     that spawned it managed to put 'itself' on the main-threads list.
+     The upshot of it all being that the worker thread wouldn't get to
+     signal the completion of the its work item for the main thread to
+     see (==> it got stuck waiting.)    -- sof 6/02.
+  */
+  ACQUIRE_LOCK(&sched_mutex);
+  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+  
+  m->link = main_threads;
+  main_threads = m;
+
+  /* Inefficient (scheduleThread_() acquires it again right away),
+   * but obviously correct.
+   */
+  RELEASE_LOCK(&sched_mutex);
+
+  scheduleThread_(tso, rtsTrue);
 #if defined(THREADED_RTS)
-  return scheduleThread_(tso, rtsTrue);
+  return waitThread_(m, rtsTrue);
 #else
-  return scheduleThread_(tso);
+  return waitThread_(m);
 #endif
 }
 
@@ -2022,9 +2057,9 @@ initScheduler(void)
    * the scheduler. */
   initMutex(&sched_mutex);
   initMutex(&term_mutex);
+  initMutex(&thread_id_mutex);
 
   initCondition(&thread_ready_cond);
-  initCondition(&returning_worker_cond);
 #endif
   
 #if defined(SMP)
@@ -2080,6 +2115,7 @@ exitScheduler( void )
 #if defined(RTS_SUPPORTS_THREADS)
   stopTaskManager();
 #endif
+  shutting_down_scheduler = rtsTrue;
 }
 
 /* -----------------------------------------------------------------------------
@@ -2143,28 +2179,9 @@ finishAllThreads ( void )
 SchedulerStatus
 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 { 
-#if defined(THREADED_RTS)
-  return waitThread_(tso,ret, rtsFalse);
-#else
-  return waitThread_(tso,ret);
-#endif
-}
-
-SchedulerStatus
-waitThread_(StgTSO *tso,
-           /*out*/StgClosure **ret
-#if defined(THREADED_RTS)
-           , rtsBool blockWaiting
-#endif
-          )
-{
   StgMainThread *m;
-  SchedulerStatus stat;
 
-  ACQUIRE_LOCK(&sched_mutex);
-  
   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
-
   m->tso = tso;
   m->ret = ret;
   m->stat = NoStatus;
@@ -2172,8 +2189,30 @@ waitThread_(StgTSO *tso,
   initCondition(&m->wakeup);
 #endif
 
+  /* see scheduleWaitThread() comment */
+  ACQUIRE_LOCK(&sched_mutex);
+  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
   m->link = main_threads;
   main_threads = m;
+  RELEASE_LOCK(&sched_mutex);
+
+  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+#if defined(THREADED_RTS)
+  return waitThread_(m, rtsFalse);
+#else
+  return waitThread_(m);
+#endif
+}
+
+static
+SchedulerStatus
+waitThread_(StgMainThread* m
+#if defined(THREADED_RTS)
+           , rtsBool blockWaiting
+#endif
+          )
+{
+  SchedulerStatus stat;
 
   IF_DEBUG(scheduler, sched_belch("== scheduler: new main thread (%d)\n", m->tso->id));
 
@@ -2185,13 +2224,12 @@ waitThread_(StgTSO *tso,
      * gets to enter the RTS directly without going via another
      * task/thread.
      */
-    RELEASE_LOCK(&sched_mutex);
     schedule();
     ASSERT(m->stat != NoStatus);
   } else 
 # endif
   {
-    IF_DEBUG(scheduler, sched_belch("sfoo"));
+    ACQUIRE_LOCK(&sched_mutex);
     do {
       waitCondition(&m->wakeup, &sched_mutex);
     } while (m->stat == NoStatus);
@@ -2350,8 +2388,6 @@ take_off_run_queue(StgTSO *tso) {
 void
 GetRoots(evac_fn evac)
 {
-  StgMainThread *m;
-
 #if defined(GRAN)
   {
     nat i;
@@ -2390,9 +2426,6 @@ GetRoots(evac_fn evac)
   }
 #endif 
 
-  for (m = main_threads; m != NULL; m = m->link) {
-      evac((StgClosure **)&m->tso);
-  }
   if (suspended_ccalling_threads != END_TSO_QUEUE) {
       evac((StgClosure **)&suspended_ccalling_threads);
   }
@@ -2420,13 +2453,18 @@ void (*extra_roots)(evac_fn);
 void
 performGC(void)
 {
+  /* Obligated to hold this lock upon entry */
+  ACQUIRE_LOCK(&sched_mutex);
   GarbageCollect(GetRoots,rtsFalse);
+  RELEASE_LOCK(&sched_mutex);
 }
 
 void
 performMajorGC(void)
 {
+  ACQUIRE_LOCK(&sched_mutex);
   GarbageCollect(GetRoots,rtsTrue);
+  RELEASE_LOCK(&sched_mutex);
 }
 
 static void
@@ -2439,8 +2477,10 @@ AllRoots(evac_fn evac)
 void
 performGCWithRoots(void (*get_roots)(evac_fn))
 {
+  ACQUIRE_LOCK(&sched_mutex);
   extra_roots = get_roots;
   GarbageCollect(AllRoots,rtsFalse);
+  RELEASE_LOCK(&sched_mutex);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2855,13 +2895,15 @@ interruptStgRts(void)
   NB: only the type of the blocking queue is different in GranSim and GUM
       the operations on the queue-elements are the same
       long live polymorphism!
+
+  Locks: sched_mutex is held upon entry and exit.
+
 */
 static void
 unblockThread(StgTSO *tso)
 {
   StgBlockingQueueElement *t, **last;
 
-  ACQUIRE_LOCK(&sched_mutex);
   switch (tso->why_blocked) {
 
   case NotBlocked:
@@ -2983,20 +3025,20 @@ unblockThread(StgTSO *tso)
   tso->why_blocked = NotBlocked;
   tso->block_info.closure = NULL;
   PUSH_ON_RUN_QUEUE(tso);
-  RELEASE_LOCK(&sched_mutex);
 }
 #else
 static void
 unblockThread(StgTSO *tso)
 {
   StgTSO *t, **last;
+  
+  /* To avoid locking unnecessarily. */
+  if (tso->why_blocked == NotBlocked) {
+    return;
+  }
 
-  ACQUIRE_LOCK(&sched_mutex);
   switch (tso->why_blocked) {
 
-  case NotBlocked:
-    return;  /* not blocked */
-
   case BlockedOnMVar:
     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
     {
@@ -3108,7 +3150,6 @@ unblockThread(StgTSO *tso)
   tso->why_blocked = NotBlocked;
   tso->block_info.closure = NULL;
   PUSH_ON_RUN_QUEUE(tso);
-  RELEASE_LOCK(&sched_mutex);
 }
 #endif
 
@@ -3142,6 +3183,8 @@ unblockThread(StgTSO *tso)
  * CATCH_FRAME on the stack.  In either case, we strip the entire
  * stack and replace the thread with a zombie.
  *
+ * Locks: sched_mutex held upon entry nor exit.
+ *
  * -------------------------------------------------------------------------- */
  
 void 
@@ -3151,6 +3194,16 @@ deleteThread(StgTSO *tso)
 }
 
 void
+raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
+{
+  /* When raising async exs from contexts where sched_mutex isn't held;
+     use raiseAsyncWithLock(). */
+  ACQUIRE_LOCK(&sched_mutex);
+  raiseAsync(tso,exception);
+  RELEASE_LOCK(&sched_mutex);
+}
+
+void
 raiseAsync(StgTSO *tso, StgClosure *exception)
 {
   StgUpdateFrame* su = tso->su;
@@ -3166,6 +3219,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
   /* Remove it from any blocking queues */
   unblockThread(tso);
 
+  IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
   /* The stack freezing code assumes there's a closure pointer on
    * the top of the stack.  This isn't always the case with compiled
    * code, so we have to push a dummy closure on the top which just
@@ -3181,51 +3235,41 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
     StgAP_UPD * ap;
 
     /* If we find a CATCH_FRAME, and we've got an exception to raise,
-     * then build PAP(handler,exception,realworld#), and leave it on
-     * top of the stack ready to enter.
+     * then build the THUNK raise(exception), and leave it on
+     * top of the CATCH_FRAME ready to enter.
      */
     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
+#ifdef PROFILING
       StgCatchFrame *cf = (StgCatchFrame *)su;
+#endif
+      StgClosure *raise;
+
       /* we've got an exception to raise, so let's pass it to the
        * handler in this frame.
        */
-      ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 2);
-      TICK_ALLOC_UPD_PAP(3,0);
-      SET_HDR(ap,&stg_PAP_info,cf->header.prof.ccs);
-             
-      ap->n_args = 2;
-      ap->fun = cf->handler;   /* :: Exception -> IO a */
-      ap->payload[0] = exception;
-      ap->payload[1] = ARG_TAG(0); /* realworld token */
-
-      /* throw away the stack from Sp up to and including the
-       * CATCH_FRAME.
-       */
-      sp = (P_)su + sizeofW(StgCatchFrame) - 1; 
-      tso->su = cf->link;
-
-      /* Restore the blocked/unblocked state for asynchronous exceptions
-       * at the CATCH_FRAME.  
-       *
-       * If exceptions were unblocked at the catch, arrange that they
-       * are unblocked again after executing the handler by pushing an
-       * unblockAsyncExceptions_ret stack frame.
+      raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+      TICK_ALLOC_SE_THK(1,0);
+      SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
+      raise->payload[0] = exception;
+
+      /* throw away the stack from Sp up to the CATCH_FRAME.
        */
-      if (!cf->exceptions_blocked) {
-       *(sp--) = (W_)&stg_unblockAsyncExceptionszh_ret_info;
-      }
-      
-      /* Ensure that async exceptions are blocked when running the handler.
+      sp = (P_)su - 1;
+
+      /* Ensure that async excpetions are blocked now, so we don't get
+       * a surprise exception before we get around to executing the
+       * handler.
        */
       if (tso->blocked_exceptions == NULL) {
-       tso->blocked_exceptions = END_TSO_QUEUE;
+         tso->blocked_exceptions = END_TSO_QUEUE;
       }
-      
-      /* Put the newly-built PAP on top of the stack, ready to execute
+
+      /* Put the newly-built THUNK on top of the stack, ready to execute
        * when the thread restarts.
        */
-      sp[0] = (W_)ap;
+      sp[0] = (W_)raise;
       tso->sp = sp;
+      tso->su = su;
       tso->what_next = ThreadEnterGHC;
       IF_DEBUG(sanity, checkTSO(tso));
       return;
@@ -3359,6 +3403,8 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
    up and sent a signal: BlockedOnDeadMVar if the thread was blocked
    on an MVar, or NonTermination if the thread was blocked on a Black
    Hole.
+
+   Locks: sched_mutex isn't held upon entry nor exit.
    -------------------------------------------------------------------------- */
 
 void
@@ -3375,6 +3421,7 @@ resurrectThreads( StgTSO *threads )
     switch (tso->why_blocked) {
     case BlockedOnMVar:
     case BlockedOnException:
+      /* Called by GC - sched_mutex lock is currently held. */
       raiseAsync(tso,(StgClosure *)BlockedOnDeadMVar_closure);
       break;
     case BlockedOnBlackHole:
@@ -3399,6 +3446,8 @@ resurrectThreads( StgTSO *threads )
  *
  * This is only done in a deadlock situation in order to avoid
  * performance overhead in the normal case.
+ *
+ * Locks: sched_mutex is held upon entry and exit.
  * -------------------------------------------------------------------------- */
 
 static void
@@ -3527,6 +3576,7 @@ void
 printAllThreads(void)
 {
   StgTSO *t;
+  void *label;
 
 # if defined(GRAN)
   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
@@ -3545,7 +3595,9 @@ printAllThreads(void)
 # endif
 
   for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
-    fprintf(stderr, "\tthread %d ", t->id);
+    fprintf(stderr, "\tthread %d @ %p ", t->id, (void *)t);
+    label = lookupThreadLabel((StgWord)t);
+    if (label) fprintf(stderr,"[\"%s\"] ",(char *)label);
     printThreadStatus(t);
     fprintf(stderr,"\n");
   }
@@ -3733,6 +3785,7 @@ sched_belch(char *s, ...)
 #endif
   vfprintf(stderr, s, ap);
   fprintf(stderr, "\n");
+  va_end(ap);
 }
 
 #endif /* DEBUG */
@@ -3742,7 +3795,6 @@ sched_belch(char *s, ...)
 //@subsection Index
 
 //@index
-//* MainRegTable::  @cindex\s-+MainRegTable
 //* StgMainThread::  @cindex\s-+StgMainThread
 //* awaken_blocked_queue::  @cindex\s-+awaken_blocked_queue
 //* blocked_queue_hd::  @cindex\s-+blocked_queue_hd
@@ -3760,5 +3812,4 @@ sched_belch(char *s, ...)
 //* schedule::  @cindex\s-+schedule
 //* take_off_run_queue::  @cindex\s-+take_off_run_queue
 //* term_mutex::  @cindex\s-+term_mutex
-//* thread_ready_cond::  @cindex\s-+thread_ready_cond
 //@end index