Schedule.c

/* ---------------------------------------------------------------------------
 * $Id: Schedule.c,v 1.181 2003/12/05 09:50:39 stolz Exp $
 *
 * (c) The GHC Team, 1998-2000
 *
 * Scheduler
 *
 * Different GHC ways use this scheduler quite differently (see comments below)
 * Here is the global picture:
 *
 * WAY  Name     CPP flag  What's it for
 * --------------------------------------
 * mp   GUM      PAR          Parallel execution on a distributed memory machine
 * s    SMP      SMP          Parallel execution on a shared memory machine
 * mg   GranSim  GRAN         Simulation of parallel execution
 * md   GUM/GdH  DIST         Distributed execution (based on GUM)
 *
 * --------------------------------------------------------------------------*/

//@node Main scheduling code, , ,
//@section Main scheduling code

/* 
 * Version with scheduler monitor support for SMPs (WAY=s):

   This design provides a high-level API to create and schedule threads etc.
   as documented in the SMP design document.

   It uses a monitor design controlled by a single mutex to exercise control
   over accesses to shared data structures, and builds on the Posix threads
   library.

   The majority of state is shared.  In order to keep essential per-task state,
   there is a Capability structure, which contains all the information
   needed to run a thread: its STG registers, a pointer to its TSO, a
   nursery etc.  During STG execution, a pointer to the capability is
   kept in a register (BaseReg).

   In a non-SMP build, there is one global capability, namely MainRegTable.

   SDM & KH, 10/99

 * Version with support for distributed memory parallelism aka GUM (WAY=mp):

   The main scheduling loop in GUM iterates until a finish message is received.
   In that case a global flag @receivedFinish@ is set and this instance of
   the RTS shuts down. See ghc/rts/parallel/HLComms.c:processMessages()
   for the handling of incoming messages, such as PP_FINISH.
   Note that in the parallel case we have a system manager that coordinates
   different PEs, each of which are running one instance of the RTS.
   See ghc/rts/parallel/SysMan.c for the main routine of the parallel program.
   From this routine processes executing ghc/rts/Main.c are spawned. -- HWL

 * Version with support for simulating parallel execution aka GranSim (WAY=mg):

   The main scheduling code in GranSim is quite different from that in std
   (concurrent) Haskell: while concurrent Haskell just iterates over the
   threads in the runnable queue, GranSim is event driven, i.e. it iterates
   over the events in the global event queue.  -- HWL
*/

//@menu
//* Includes::			
//* Variables and Data structures::  
//* Main scheduling loop::	
//* Suspend and Resume::	
//* Run queue code::		
//* Garbage Collextion Routines::  
//* Blocking Queue Routines::	
//* Exception Handling Routines::  
//* Debugging Routines::	
//* Index::			
//@end menu

//@node Includes, Variables and Data structures, Main scheduling code, Main scheduling code
//@subsection Includes

#include "PosixSource.h"
#include "Rts.h"
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Storage.h"
#include "StgRun.h"
#include "StgStartup.h"
#include "Hooks.h"
#define COMPILING_SCHEDULER
#include "Schedule.h"
#include "StgMiscClosures.h"
#include "Storage.h"
#include "Interpreter.h"
#include "Exception.h"
#include "Printer.h"
#include "Signals.h"
#include "Sanity.h"
#include "Stats.h"
#include "Timer.h"
#include "Prelude.h"
#include "ThreadLabels.h"
#ifdef PROFILING
#include "Proftimer.h"
#include "ProfHeap.h"
#endif
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"
# include "GranSim.h"
# include "ParallelRts.h"
# include "Parallel.h"
# include "ParallelDebug.h"
# include "FetchMe.h"
# include "HLC.h"
#endif
#include "Sparks.h"
#include "Capability.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 <string.h>
#include <stdlib.h>
#include <stdarg.h>

#ifdef HAVE_ERRNO_H
#include <errno.h>
#endif

#ifdef THREADED_RTS
#define USED_IN_THREADED_RTS
#else
#define USED_IN_THREADED_RTS STG_UNUSED
#endif

#ifdef RTS_SUPPORTS_THREADS
#define USED_WHEN_RTS_SUPPORTS_THREADS
#else
#define USED_WHEN_RTS_SUPPORTS_THREADS STG_UNUSED
#endif

//@node Variables and Data structures, Prototypes, Includes, Main scheduling code
//@subsection Variables and Data structures

/* Main thread queue.
 * Locks required: sched_mutex.
 */
StgMainThread *main_threads = NULL;

/* Thread queues.
 * Locks required: sched_mutex.
 */
#if defined(GRAN)

StgTSO* ActiveTSO = NULL; /* for assigning system costs; GranSim-Light only */
/* rtsTime TimeOfNextEvent, EndOfTimeSlice;            now in GranSim.c */

/* 
   In GranSim we have a runnable and a blocked queue for each processor.
   In order to minimise code changes new arrays run_queue_hds/tls
   are created. run_queue_hd is then a short cut (macro) for
   run_queue_hds[CurrentProc] (see GranSim.h).
   -- HWL
*/
StgTSO *run_queue_hds[MAX_PROC], *run_queue_tls[MAX_PROC];
StgTSO *blocked_queue_hds[MAX_PROC], *blocked_queue_tls[MAX_PROC];
StgTSO *ccalling_threadss[MAX_PROC];
/* We use the same global list of threads (all_threads) in GranSim as in
   the std RTS (i.e. we are cheating). However, we don't use this list in
   the GranSim specific code at the moment (so we are only potentially
   cheating).  */

#else /* !GRAN */

StgTSO *run_queue_hd = NULL;
StgTSO *run_queue_tl = NULL;
StgTSO *blocked_queue_hd = NULL;
StgTSO *blocked_queue_tl = NULL;
StgTSO *sleeping_queue = NULL;    /* perhaps replace with a hash table? */

#endif

/* Linked list of all threads.
 * Used for detecting garbage collected threads.
 */
StgTSO *all_threads = NULL;

/* When a thread performs a safe C call (_ccall_GC, using old
 * terminology), it gets put on the suspended_ccalling_threads
 * list. Used by the garbage collector.
 */
static StgTSO *suspended_ccalling_threads;

static StgTSO *threadStackOverflow(StgTSO *tso);

/* KH: The following two flags are shared memory locations.  There is no need
       to lock them, since they are only unset at the end of a scheduler
       operation.
*/

/* flag set by signal handler to precipitate a context switch */
//@cindex context_switch
nat context_switch = 0;

/* if this flag is set as well, give up execution */
//@cindex interrupted
rtsBool interrupted = rtsFalse;

/* Next thread ID to allocate.
 * Locks required: thread_id_mutex
 */
//@cindex next_thread_id
static StgThreadID next_thread_id = 1;

/*
 * Pointers to the state of the current thread.
 * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
 * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
 */
 
/* The smallest stack size that makes any sense is:
 *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
 *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
 *  + 1                       (the closure to enter)
 *  + 1			      (stg_ap_v_ret)
 *  + 1			      (spare slot req'd by stg_ap_v_ret)
 *
 * A thread with this stack will bomb immediately with a stack
 * overflow, which will increase its stack size.  
 */

#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)


#if defined(GRAN)
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;

static 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          ( StgMainThread *mainThread, Capability *initialCapability );
       void     interruptStgRts   ( void );

static void     detectBlackHoles  ( void );

#ifdef DEBUG
static void sched_belch(char *s, ...);
#endif

#if defined(RTS_SUPPORTS_THREADS)
/* ToDo: carefully document the invariants that go together
 *       with these synchronisation objects.
 */
Mutex     sched_mutex       = INIT_MUTEX_VAR;
Mutex     term_mutex        = INIT_MUTEX_VAR;

/*
 * A heavyweight solution to the problem of protecting
 * the thread_id from concurrent update.
 */
Mutex     thread_id_mutex   = INIT_MUTEX_VAR;


# if defined(SMP)
static Condition gc_pending_cond = INIT_COND_VAR;
nat await_death;
# endif

#endif /* RTS_SUPPORTS_THREADS */

#if defined(PAR)
StgTSO *LastTSO;
rtsTime TimeOfLastYield;
rtsBool emitSchedule = rtsTrue;
#endif

#if DEBUG
static char *whatNext_strs[] = {
  "ThreadRunGHC",
  "ThreadInterpret",
  "ThreadKilled",
  "ThreadRelocated",
  "ThreadComplete"
};
#endif

#if defined(PAR)
StgTSO * createSparkThread(rtsSpark spark);
StgTSO * activateSpark (rtsSpark spark);  
#endif

/*
 * The thread state for the main thread.
// ToDo: check whether not needed any more
StgTSO   *MainTSO;
 */

#if defined(RTS_SUPPORTS_THREADS)
static rtsBool startingWorkerThread = rtsFalse;

static void taskStart(void);
static void
taskStart(void)
{
  Capability *cap;
  
  ACQUIRE_LOCK(&sched_mutex);
  startingWorkerThread = rtsFalse;
  waitForWorkCapability(&sched_mutex, &cap, NULL);
  RELEASE_LOCK(&sched_mutex);
  
  schedule(NULL,cap);
}

void
startSchedulerTaskIfNecessary(void)
{
  if(run_queue_hd != END_TSO_QUEUE
    || blocked_queue_hd != END_TSO_QUEUE
    || sleeping_queue != END_TSO_QUEUE)
  {
    if(!startingWorkerThread)
    { // we don't want to start another worker thread
      // just because the last one hasn't yet reached the
      // "waiting for capability" state
      startingWorkerThread = rtsTrue;
      startTask(taskStart);
    }
  }
}
#endif

//@node Main scheduling loop, Suspend and Resume, Prototypes, Main scheduling code
//@subsection Main scheduling loop

/* ---------------------------------------------------------------------------
   Main scheduling loop.

   We use round-robin scheduling, each thread returning to the
   scheduler loop when one of these conditions is detected:

      * out of heap space
      * timer expires (thread yields)
      * thread blocks
      * thread ends
      * stack overflow

   Locking notes:  we acquire the scheduler lock once at the beginning
   of the scheduler loop, and release it when
    
      * running a thread, or
      * waiting for work, or
      * waiting for a GC to complete.

   GRAN version:
     In a GranSim setup this loop iterates over the global event queue.
     This revolves around the global event queue, which determines what 
     to do next. Therefore, it's more complicated than either the 
     concurrent or the parallel (GUM) setup.

   GUM version:
     GUM iterates over incoming messages.
     It starts with nothing to do (thus CurrentTSO == END_TSO_QUEUE),
     and sends out a fish whenever it has nothing to do; in-between
     doing the actual reductions (shared code below) it processes the
     incoming messages and deals with delayed operations 
     (see PendingFetches).
     This is not the ugliest code you could imagine, but it's bloody close.

   ------------------------------------------------------------------------ */
//@cindex schedule
static void
schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS,
          Capability *initialCapability )
{
  StgTSO *t;
  Capability *cap = initialCapability;
  StgThreadReturnCode ret;
#if defined(GRAN)
  rtsEvent *event;
#elif defined(PAR)
  StgSparkPool *pool;
  rtsSpark spark;
  StgTSO *tso;
  GlobalTaskId pe;
  rtsBool receivedFinish = rtsFalse;
# if defined(DEBUG)
  nat tp_size, sp_size; // stats only
# endif
#endif
  rtsBool was_interrupted = rtsFalse;
  StgTSOWhatNext prev_what_next;
  
  ACQUIRE_LOCK(&sched_mutex);
 
#if defined(RTS_SUPPORTS_THREADS)
  /* in the threaded case, the capability is either passed in via the initialCapability
     parameter, or initialized inside the scheduler loop */

  IF_DEBUG(scheduler,
    fprintf(stderr,"### NEW SCHEDULER LOOP in os thread %u(%p)\n",
	    osThreadId(), osThreadId()));
  IF_DEBUG(scheduler,
    fprintf(stderr,"### main thread: %p\n",mainThread));
  IF_DEBUG(scheduler,
    fprintf(stderr,"### initial cap: %p\n",initialCapability));
#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],
	    ContinueThread, 
	    CurrentTSO, (StgClosure*)NULL, (rtsSpark*)NULL);

  IF_DEBUG(gran,
	   fprintf(stderr, "GRAN: Init CurrentTSO (in schedule) = %p\n", CurrentTSO);
	   G_TSO(CurrentTSO, 5));

  if (RtsFlags.GranFlags.Light) {
    /* Save current time; GranSim Light only */
    CurrentTSO->gran.clock = CurrentTime[CurrentProc];
  }      

  event = get_next_event();

  while (event!=(rtsEvent*)NULL) {
    /* Choose the processor with the next event */
    CurrentProc = event->proc;
    CurrentTSO = event->tso;

#elif defined(PAR)

  while (!receivedFinish) {    /* set by processMessages */
                               /* when receiving PP_FINISH message         */ 
#else

  while (1) {

#endif

    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... if we have a capability, that is. */
    if(cap)
      yieldToReturningWorker(&sched_mutex, &cap,
	  mainThread ? &mainThread->bound_thread_cond : NULL);

    /* If we do not currently hold a capability, we wait for one */
    if(!cap)
    {
      waitForWorkCapability(&sched_mutex, &cap,
	  mainThread ? &mainThread->bound_thread_cond : NULL);
      IF_DEBUG(scheduler, sched_belch("worker thread (osthread %p): got cap",
				      osThreadId()));
    }
#endif

    /* If we're interrupted (the user pressed ^C, or some other
     * termination condition occurred), kill all the currently running
     * threads.
     */
    if (interrupted) {
      IF_DEBUG(scheduler, sched_belch("interrupted"));
      interrupted = rtsFalse;
      was_interrupted = rtsTrue;
#if defined(RTS_SUPPORTS_THREADS)
      // In the threaded RTS, deadlock detection doesn't work,
      // so just exit right away.
      prog_belch("interrupted");
      releaseCapability(cap);
      RELEASE_LOCK(&sched_mutex);
      shutdownHaskellAndExit(EXIT_SUCCESS);
#else
      deleteAllThreads();
#endif
    }

    /* Go through the list of main threads and wake up any
     * clients whose computations have finished.  ToDo: this
     * should be done more efficiently without a linear scan
     * of the main threads list, somehow...
     */
#if defined(RTS_SUPPORTS_THREADS)
    { 
	StgMainThread *m, **prev;
	prev = &main_threads;
	for (m = main_threads; m != NULL; prev = &m->link, m = m->link) {
	  if (m->tso->what_next == ThreadComplete
	      || m->tso->what_next == ThreadKilled)
	  {
	    if(m == mainThread)
	    {
              if(m->tso->what_next == ThreadComplete)
              {
                if (m->ret)
                {
                  // NOTE: return val is tso->sp[1] (see StgStartup.hc)
                  *(m->ret) = (StgClosure *)m->tso->sp[1]; 
                }
                m->stat = Success;
              }
              else
              {
                if (m->ret)
                {
                  *(m->ret) = NULL;
                }
                if (was_interrupted)
                {
                  m->stat = Interrupted;
                }
                else
                {
                  m->stat = Killed;
                }
              }
              *prev = m->link;
	    
#ifdef DEBUG
	      removeThreadLabel((StgWord)m->tso->id);
#endif
              releaseCapability(cap);
              RELEASE_LOCK(&sched_mutex);
              return;
            }
            else
            {
                // The current OS thread can not handle the fact that the Haskell
                // thread "m" has ended. 
                // "m" is bound; the scheduler loop in it's bound OS thread has
                // to return, so let's pass our capability directly to that thread.
              passCapability(&sched_mutex, cap, &m->bound_thread_cond);
              cap = NULL;
            }
          }
	}
    }
    
    if(!cap)	// If we gave our capability away,
      continue;	// go to the top to get it back
      
#else /* not threaded */

# if defined(PAR)
    /* in GUM do this only on the Main PE */
    if (IAmMainThread)
# endif
    /* If our main thread has finished or been killed, return.
     */
    {
      StgMainThread *m = main_threads;
      if (m->tso->what_next == ThreadComplete
	  || m->tso->what_next == ThreadKilled) {
#ifdef DEBUG
	removeThreadLabel((StgWord)m->tso->id);
#endif
	main_threads = main_threads->link;
	if (m->tso->what_next == ThreadComplete) {
	    // We finished successfully, fill in the return value
	    // NOTE: return val is tso->sp[1] (see StgStartup.hc)
	    if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[1]; };
	    m->stat = Success;
	    return;
	} else {
	  if (m->ret) { *(m->ret) = NULL; };
	  if (was_interrupted) {
	    m->stat = Interrupted;
	  } else {
	    m->stat = Killed;
	  }
	  return;
	}
      }
    }
#endif

    /* Top up the run queue from our spark pool.  We try to make the
     * number of threads in the run queue equal to the number of
     * free capabilities.
     *
     * Disable spark support in SMP for now, non-essential & requires
     * a little bit of work to make it compile cleanly. -- sof 1/02.
     */
#if 0 /* defined(SMP) */
    {
      nat n = getFreeCapabilities();
      StgTSO *tso = run_queue_hd;

      /* Count the run queue */
      while (n > 0 && tso != END_TSO_QUEUE) {
	tso = tso->link;
	n--;
      }

      for (; n > 0; n--) {
	StgClosure *spark;
	spark = findSpark(rtsFalse);
	if (spark == NULL) {
	  break; /* no more sparks in the pool */
	} else {
	  /* I'd prefer this to be done in activateSpark -- HWL */
	  /* tricky - it needs to hold the scheduler lock and
	   * not try to re-acquire it -- SDM */
	  createSparkThread(spark);	  
	  IF_DEBUG(scheduler,
		   sched_belch("==^^ turning spark of closure %p into a thread",
			       (StgClosure *)spark));
	}
      }
      /* We need to wake up the other tasks if we just created some
       * work for them.
       */
      if (getFreeCapabilities() - n > 1) {
   	  signalCondition( &thread_ready_cond );
      }
    }
#endif // SMP

    /* check for signals each time around the scheduler */
#if defined(RTS_USER_SIGNALS)
    if (signals_pending()) {
      RELEASE_LOCK(&sched_mutex); /* ToDo: kill */
      startSignalHandlers();
      ACQUIRE_LOCK(&sched_mutex);
    }
#endif

    /* Check whether any waiting threads need to be woken up.  If the
     * run queue is empty, and there are no other tasks running, we
     * can wait indefinitely for something to happen.
     */
    if ( !EMPTY_QUEUE(blocked_queue_hd) || !EMPTY_QUEUE(sleeping_queue) 
#if defined(RTS_SUPPORTS_THREADS) && !defined(SMP)
		|| EMPTY_RUN_QUEUE()
#endif
        )
    {
      awaitEvent( EMPTY_RUN_QUEUE()
#if defined(SMP)
	&& allFreeCapabilities()
#endif
	);
    }
    /* we can be interrupted while waiting for I/O... */
    if (interrupted) continue;

    /* 
     * 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.
     */
#if !defined(PAR) && !defined(RTS_SUPPORTS_THREADS)
    if (   EMPTY_THREAD_QUEUES()
#if defined(RTS_SUPPORTS_THREADS)
	&& EMPTY_QUEUE(suspended_ccalling_threads)
#endif
#ifdef SMP
	&& allFreeCapabilities()
#endif
	)
    {
	IF_DEBUG(scheduler, sched_belch("deadlocked, forcing major GC..."));
#if defined(THREADED_RTS)
	/* and SMP mode ..? */
	releaseCapability(cap);
#endif
	// 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);

	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; }

#if defined(RTS_USER_SIGNALS)
	/* 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)
	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
	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);
		    break;
		case BlockedOnException:
		case BlockedOnMVar:
		    raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
		    break;
		default:
		    barf("deadlock: main thread blocked in a strange way");
		}
	    }
#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
	}

#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(RTS_SUPPORTS_THREADS)
    /* ToDo: add deadlock detection in threaded RTS */
#elif defined(PAR)
    /* ToDo: add deadlock detection in GUM (similar to SMP) -- HWL */
#endif

#if defined(SMP)
    /* If there's a GC pending, don't do anything until it has
     * completed.
     */
    if (ready_to_gc) {
      IF_DEBUG(scheduler,sched_belch("waiting for GC"));
      waitCondition( &gc_pending_cond, &sched_mutex );
    }
#endif    

#if defined(RTS_SUPPORTS_THREADS)
#if defined(SMP)
    /* block until we've got a thread on the run queue and a free
     * capability.
     *
     */
    if ( EMPTY_RUN_QUEUE() ) {
      /* Give up our capability */
      releaseCapability(cap);

      /* 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()));
    }
#else
    if ( EMPTY_RUN_QUEUE() ) {
      continue; // nothing to do
    }
#endif
#endif

#if defined(GRAN)
    if (RtsFlags.GranFlags.Light)
      GranSimLight_enter_system(event, &ActiveTSO); // adjust ActiveTSO etc

    /* adjust time based on time-stamp */
    if (event->time > CurrentTime[CurrentProc] &&
        event->evttype != ContinueThread)
      CurrentTime[CurrentProc] = event->time;
    
    /* Deal with the idle PEs (may issue FindWork or MoveSpark events) */
    if (!RtsFlags.GranFlags.Light)
      handleIdlePEs();

    IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"));

    /* main event dispatcher in GranSim */
    switch (event->evttype) {
      /* Should just be continuing execution */
    case ContinueThread:
      IF_DEBUG(gran, fprintf(stderr, "GRAN: doing ContinueThread\n"));
      /* ToDo: check assertion
      ASSERT(run_queue_hd != (StgTSO*)NULL &&
	     run_queue_hd != END_TSO_QUEUE);
      */
      /* Ignore ContinueThreads for fetching threads (if synchr comm) */
      if (!RtsFlags.GranFlags.DoAsyncFetch &&
	  procStatus[CurrentProc]==Fetching) {
	belch("ghuH: Spurious ContinueThread while Fetching ignored; TSO %d (%p) [PE %d]",
	      CurrentTSO->id, CurrentTSO, CurrentProc);
	goto next_thread;
      }	
      /* Ignore ContinueThreads for completed threads */
      if (CurrentTSO->what_next == ThreadComplete) {
	belch("ghuH: found a ContinueThread event for completed thread %d (%p) [PE %d] (ignoring ContinueThread)", 
	      CurrentTSO->id, CurrentTSO, CurrentProc);
	goto next_thread;
      }	
      /* Ignore ContinueThreads for threads that are being migrated */
      if (PROCS(CurrentTSO)==Nowhere) { 
	belch("ghuH: trying to run the migrating TSO %d (%p) [PE %d] (ignoring ContinueThread)",
	      CurrentTSO->id, CurrentTSO, CurrentProc);
	goto next_thread;
      }
      /* The thread should be at the beginning of the run queue */
      if (CurrentTSO!=run_queue_hds[CurrentProc]) { 
	belch("ghuH: TSO %d (%p) [PE %d] is not at the start of the run_queue when doing a ContinueThread",
	      CurrentTSO->id, CurrentTSO, CurrentProc);
	break; // run the thread anyway
      }
      /*
      new_event(proc, proc, CurrentTime[proc],
		FindWork,
		(StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
      goto next_thread; 
      */ /* Catches superfluous CONTINUEs -- should be unnecessary */
      break; // now actually run the thread; DaH Qu'vam yImuHbej 

    case FetchNode:
      do_the_fetchnode(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case GlobalBlock:
      do_the_globalblock(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case FetchReply:
      do_the_fetchreply(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case UnblockThread:   /* Move from the blocked queue to the tail of */
      do_the_unblock(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case ResumeThread:  /* Move from the blocked queue to the tail of */
      /* the runnable queue ( i.e. Qu' SImqa'lu') */ 
      event->tso->gran.blocktime += 
	CurrentTime[CurrentProc] - event->tso->gran.blockedat;
      do_the_startthread(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case StartThread:
      do_the_startthread(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case MoveThread:
      do_the_movethread(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case MoveSpark:
      do_the_movespark(event);
      goto next_thread;             /* handle next event in event queue  */
      
    case FindWork:
      do_the_findwork(event);
      goto next_thread;             /* handle next event in event queue  */
      
    default:
      barf("Illegal event type %u\n", event->evttype);
    }  /* switch */
    
    /* This point was scheduler_loop in the old RTS */

    IF_DEBUG(gran, belch("GRAN: after main switch"));

    TimeOfLastEvent = CurrentTime[CurrentProc];
    TimeOfNextEvent = get_time_of_next_event();
    IgnoreEvents=(TimeOfNextEvent==0); // HWL HACK
    // CurrentTSO = ThreadQueueHd;

    IF_DEBUG(gran, belch("GRAN: time of next event is: %ld", 
			 TimeOfNextEvent));

    if (RtsFlags.GranFlags.Light) 
      GranSimLight_leave_system(event, &ActiveTSO); 

    EndOfTimeSlice = CurrentTime[CurrentProc]+RtsFlags.GranFlags.time_slice;

    IF_DEBUG(gran, 
	     belch("GRAN: end of time-slice is %#lx", EndOfTimeSlice));

    /* in a GranSim setup the TSO stays on the run queue */
    t = CurrentTSO;
    /* Take a thread from the run queue. */
    POP_RUN_QUEUE(t); // take_off_run_queue(t);

    IF_DEBUG(gran, 
	     fprintf(stderr, "GRAN: About to run current thread, which is\n");
	     G_TSO(t,5));

    context_switch = 0; // turned on via GranYield, checking events and time slice

    IF_DEBUG(gran, 
	     DumpGranEvent(GR_SCHEDULE, t));

    procStatus[CurrentProc] = Busy;

#elif defined(PAR)
    if (PendingFetches != END_BF_QUEUE) {
        processFetches();
    }

    /* ToDo: phps merge with spark activation above */
    /* check whether we have local work and send requests if we have none */
    if (EMPTY_RUN_QUEUE()) {  /* no runnable threads */
      /* :-[  no local threads => look out for local sparks */
      /* the spark pool for the current PE */
      pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
      if (advisory_thread_count < RtsFlags.ParFlags.maxThreads &&
	  pool->hd < pool->tl) {
	/* 
	 * ToDo: add GC code check that we really have enough heap afterwards!!
	 * Old comment:
	 * If we're here (no runnable threads) and we have pending
	 * sparks, we must have a space problem.  Get enough space
	 * to turn one of those pending sparks into a
	 * thread... 
	 */

	spark = findSpark(rtsFalse);                /* get a spark */
	if (spark != (rtsSpark) NULL) {
	  tso = activateSpark(spark);       /* turn the spark into a thread */