Schedule.c 106 KB
Newer Older
1
/* ---------------------------------------------------------------------------
sof's avatar
sof committed
2
 * $Id: Schedule.c,v 1.112 2002/01/24 02:06:48 sof Exp $
3
 *
4
 * (c) The GHC Team, 1998-2000
5
6
7
 *
 * Scheduler
 *
8
9
10
11
12
13
14
15
16
 * 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)
17
18
19
20
 * --------------------------------------------------------------------------*/

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

22
23
/* 
 * Version with scheduler monitor support for SMPs (WAY=s):
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

   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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

 * 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
59
60
*/

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
//@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

77
#include "PosixSource.h"
78
79
80
81
82
83
84
85
86
87
88
#include "Rts.h"
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Storage.h"
#include "StgRun.h"
#include "StgStartup.h"
#include "Hooks.h"
#include "Schedule.h"
#include "StgMiscClosures.h"
#include "Storage.h"
89
#include "Interpreter.h"
90
#include "Exception.h"
91
92
93
94
#include "Printer.h"
#include "Main.h"
#include "Signals.h"
#include "Sanity.h"
95
#include "Stats.h"
andy's avatar
andy committed
96
#include "Itimer.h"
97
#include "Prelude.h"
98
99
100
101
#ifdef PROFILING
#include "Proftimer.h"
#include "ProfHeap.h"
#endif
102
103
104
105
106
107
108
109
110
#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
111
#include "Sparks.h"
112
113

#include <stdarg.h>
114

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

118
119
120
121
122
123
124
125
126
127
128
129
130
131
/* Main threads:
 *
 * These are the threads which clients have requested that we run.  
 *
 * In an SMP 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:
 */
132
//@cindex StgMainThread
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
typedef struct StgMainThread_ {
  StgTSO *         tso;
  SchedulerStatus  stat;
  StgClosure **    ret;
#ifdef SMP
  pthread_cond_t wakeup;
#endif
  struct StgMainThread_ *link;
} StgMainThread;

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

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

StgTSO* ActiveTSO = NULL; /* for assigning system costs; GranSim-Light only */
154
/* rtsTime TimeOfNextEvent, EndOfTimeSlice;            now in GranSim.c */
155
156
157
158
159
160
161
162
163
164
165

/* 
   In GranSim we have a runable 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];
166
167
168
169
/* 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).  */
170
171
172

#else /* !GRAN */

173
174
StgTSO *run_queue_hd, *run_queue_tl;
StgTSO *blocked_queue_hd, *blocked_queue_tl;
175
StgTSO *sleeping_queue;		/* perhaps replace with a hash table? */
176

177
178
#endif

179
180
181
182
183
/* Linked list of all threads.
 * Used for detecting garbage collected threads.
 */
StgTSO *all_threads;

184
185
186
187
/* Threads suspended in _ccall_GC.
 */
static StgTSO *suspended_ccalling_threads;

188
189
static StgTSO *threadStackOverflow(StgTSO *tso);

190
191
192
193
194
/* 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.
*/

195
/* flag set by signal handler to precipitate a context switch */
196
//@cindex context_switch
197
nat context_switch;
198

199
/* if this flag is set as well, give up execution */
200
//@cindex interrupted
201
rtsBool interrupted;
202

203
204
205
/* Next thread ID to allocate.
 * Locks required: sched_mutex
 */
206
//@cindex next_thread_id
207
208
209
210
211
212
213
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.
 */
214
 
215
216
217
218
219
220
221
222
223
224
225
226
/* 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 realworld token for an IO thread)
 *  + 1                       (the closure to enter)
 *
 * 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) + 2)

227
228
229
230
/* Free capability list.
 * Locks required: sched_mutex.
 */
#ifdef SMP
231
232
233
Capability *free_capabilities; /* Available capabilities for running threads */
nat n_free_capabilities;       /* total number of available capabilities */
#else
234
Capability MainCapability;     /* for non-SMP, we have one global capability */
235
236
237
#endif

#if defined(GRAN)
238
StgTSO *CurrentTSO;
239
240
#endif

241
242
243
244
245
246
/*  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;

247
248
249
250
251
rtsBool ready_to_gc;

/* All our current task ids, saved in case we need to kill them later.
 */
#ifdef SMP
252
//@cindex task_ids
253
254
255
256
257
258
task_info *task_ids;
#endif

void            addToBlockedQueue ( StgTSO *tso );

static void     schedule          ( void );
259
       void     interruptStgRts   ( void );
260
261
262
#if defined(GRAN)
static StgTSO * createThread_     ( nat size, rtsBool have_lock, StgInt pri );
#else
263
static StgTSO * createThread_     ( nat size, rtsBool have_lock );
264
#endif
265

266
267
static void     detectBlackHoles  ( void );

268
269
270
#ifdef DEBUG
static void sched_belch(char *s, ...);
#endif
271
272

#ifdef SMP
273
274
275
276
//@cindex sched_mutex
//@cindex term_mutex
//@cindex thread_ready_cond
//@cindex gc_pending_cond
277
278
279
280
281
282
283
284
pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
pthread_mutex_t term_mutex        = PTHREAD_MUTEX_INITIALIZER;
pthread_cond_t  thread_ready_cond = PTHREAD_COND_INITIALIZER;
pthread_cond_t  gc_pending_cond   = PTHREAD_COND_INITIALIZER;

nat await_death;
#endif

285
286
287
#if defined(PAR)
StgTSO *LastTSO;
rtsTime TimeOfLastYield;
288
rtsBool emitSchedule = rtsTrue;
289
290
#endif

291
292
293
294
#if DEBUG
char *whatNext_strs[] = {
  "ThreadEnterGHC",
  "ThreadRunGHC",
295
  "ThreadEnterInterp",
296
297
298
299
300
301
302
303
304
305
306
307
308
  "ThreadKilled",
  "ThreadComplete"
};

char *threadReturnCode_strs[] = {
  "HeapOverflow",			/* might also be StackOverflow */
  "StackOverflow",
  "ThreadYielding",
  "ThreadBlocked",
  "ThreadFinished"
};
#endif

sof's avatar
sof committed
309
#if defined(PAR)
310
311
312
313
StgTSO * createSparkThread(rtsSpark spark);
StgTSO * activateSpark (rtsSpark spark);  
#endif

314
315
316
317
318
319
320
321
322
323
/*
 * The thread state for the main thread.
// ToDo: check whether not needed any more
StgTSO   *MainTSO;
 */

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

/* ---------------------------------------------------------------------------
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
   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.

342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
   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.

357
358
   ------------------------------------------------------------------------ */
//@cindex schedule
359
360
361
362
363
364
static void
schedule( void )
{
  StgTSO *t;
  Capability *cap;
  StgThreadReturnCode ret;
365
366
367
#if defined(GRAN)
  rtsEvent *event;
#elif defined(PAR)
368
  StgSparkPool *pool;
369
370
371
  rtsSpark spark;
  StgTSO *tso;
  GlobalTaskId pe;
372
373
374
375
  rtsBool receivedFinish = rtsFalse;
# if defined(DEBUG)
  nat tp_size, sp_size; // stats only
# endif
376
#endif
377
  rtsBool was_interrupted = rtsFalse;
378
379
380
  
  ACQUIRE_LOCK(&sched_mutex);

381
#if defined(GRAN)
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404

  /* 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;

405
#elif defined(PAR)
406

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

411
  while (1) {
412

413
#endif
414

415
416
    IF_DEBUG(scheduler, printAllThreads());

417
418
419
420
421
    /* If we're interrupted (the user pressed ^C, or some other
     * termination condition occurred), kill all the currently running
     * threads.
     */
    if (interrupted) {
422
      IF_DEBUG(scheduler, sched_belch("interrupted"));
423
      deleteAllThreads();
424
425
      interrupted = rtsFalse;
      was_interrupted = rtsTrue;
426
427
428
429
430
431
432
433
434
435
436
437
    }

    /* 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...
     */
#ifdef SMP
    { 
      StgMainThread *m, **prev;
      prev = &main_threads;
      for (m = main_threads; m != NULL; m = m->link) {
438
	switch (m->tso->what_next) {
439
	case ThreadComplete:
440
441
442
443
444
445
	  if (m->ret) {
	    *(m->ret) = (StgClosure *)m->tso->sp[0];
	  }
	  *prev = m->link;
	  m->stat = Success;
	  pthread_cond_broadcast(&m->wakeup);
446
447
	  break;
	case ThreadKilled:
448
	  if (m->ret) *(m->ret) = NULL;
449
	  *prev = m->link;
450
	  if (was_interrupted) {
451
452
453
454
	    m->stat = Interrupted;
	  } else {
	    m->stat = Killed;
	  }
455
	  pthread_cond_broadcast(&m->wakeup);
456
457
458
	  break;
	default:
	  break;
459
460
461
	}
      }
    }
462

463
464
#else // not SMP

465
466
467
468
# if defined(PAR)
    /* in GUM do this only on the Main PE */
    if (IAmMainThread)
# endif
469
470
471
472
    /* If our main thread has finished or been killed, return.
     */
    {
      StgMainThread *m = main_threads;
473
474
      if (m->tso->what_next == ThreadComplete
	  || m->tso->what_next == ThreadKilled) {
475
	main_threads = main_threads->link;
476
	if (m->tso->what_next == ThreadComplete) {
477
478
479
480
481
	  /* we finished successfully, fill in the return value */
	  if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
	  m->stat = Success;
	  return;
	} else {
482
	  if (m->ret) { *(m->ret) = NULL; };
483
	  if (was_interrupted) {
484
485
486
487
	    m->stat = Interrupted;
	  } else {
	    m->stat = Killed;
	  }
488
489
490
491
492
493
	  return;
	}
      }
    }
#endif

494
495
496
    /* 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.
sof's avatar
sof committed
497
498
499
     *
     * Disable spark support in SMP for now, non-essential & requires
     * a little bit of work to make it compile cleanly. -- sof 1/02.
500
     */
sof's avatar
sof committed
501
#if 0 /* defined(SMP) */
502
503
504
505
506
507
508
509
510
511
512
513
    {
      nat n = n_free_capabilities;
      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;
514
	spark = findSpark(rtsFalse);
515
516
517
	if (spark == NULL) {
	  break; /* no more sparks in the pool */
	} else {
518
519
520
	  /* 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 */
521
	  createSparkThread(spark);	  
522
	  IF_DEBUG(scheduler,
523
		   sched_belch("==^^ turning spark of closure %p into a thread",
524
525
526
527
528
529
530
531
532
533
			       (StgClosure *)spark));
	}
      }
      /* We need to wake up the other tasks if we just created some
       * work for them.
       */
      if (n_free_capabilities - n > 1) {
	  pthread_cond_signal(&thread_ready_cond);
      }
    }
534
#endif // SMP
535

536
537
538
539
540
541
542
    /* check for signals each time around the scheduler */
#ifndef mingw32_TARGET_OS
    if (signals_pending()) {
      startSignalHandlers();
    }
#endif

543
544
545
546
547
    /* 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.
     * ToDo: what if another client comes along & requests another
     * main thread?
548
     */
549
    if (blocked_queue_hd != END_TSO_QUEUE || sleeping_queue != END_TSO_QUEUE) {
550
551
552
      awaitEvent(
	   (run_queue_hd == END_TSO_QUEUE)
#ifdef SMP
553
	&& (n_free_capabilities == RtsFlags.ParFlags.nNodes)
554
555
#endif
	);
556
    }
557
558
559
    /* we can be interrupted while waiting for I/O... */
    if (interrupted) continue;

560
561
562
563
564
565
566
567
568
569
    /* 
     * 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.
570
     */
571
#ifndef PAR
572
573
    if (blocked_queue_hd == END_TSO_QUEUE
	&& run_queue_hd == END_TSO_QUEUE
574
	&& sleeping_queue == END_TSO_QUEUE
575
576
577
578
#ifdef SMP
	&& (n_free_capabilities == RtsFlags.ParFlags.nNodes)
#endif
	)
579
    {
580
581
582
583
584
	IF_DEBUG(scheduler, sched_belch("deadlocked, forcing major GC..."));
	GarbageCollect(GetRoots,rtsTrue);
	if (blocked_queue_hd == END_TSO_QUEUE
	    && run_queue_hd == END_TSO_QUEUE
	    && sleeping_queue == END_TSO_QUEUE) {
585

586
587
	    IF_DEBUG(scheduler, sched_belch("still deadlocked, checking for black holes..."));
	    detectBlackHoles();
588
589
590
591
592

	    // 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).
593
	    if (run_queue_hd == END_TSO_QUEUE) {
594
		StgMainThread *m;
595
#ifdef SMP
596
597
598
599
600
601
602
603
604
605
606
607
		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");
		    }
608
609
		}
#else
610
611
612
613
614
615
616
617
618
619
620
621
		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");
		}
622
#endif
623
	    }
624
	    ASSERT( run_queue_hd != END_TSO_QUEUE );
625
	}
626
    }
627
628
#elif defined(PAR)
    /* ToDo: add deadlock detection in GUM (similar to SMP) -- HWL */
629
630
#endif

631
632
633
634
635
#ifdef SMP
    /* If there's a GC pending, don't do anything until it has
     * completed.
     */
    if (ready_to_gc) {
636
      IF_DEBUG(scheduler,sched_belch("waiting for GC"));
637
638
639
640
641
642
643
      pthread_cond_wait(&gc_pending_cond, &sched_mutex);
    }
    
    /* block until we've got a thread on the run queue and a free
     * capability.
     */
    while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
644
      IF_DEBUG(scheduler, sched_belch("waiting for work"));
645
      pthread_cond_wait(&thread_ready_cond, &sched_mutex);
646
      IF_DEBUG(scheduler, sched_belch("work now available"));
647
648
    }
#endif
649
650

#if defined(GRAN)
651
652
653
654
655
656
657
658
659
660
661
662
663

    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();

664
    IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"));
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777

    /* 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. */
    t = POP_RUN_QUEUE(); // take_off_run_queue(t);

    IF_DEBUG(gran, 
	     fprintf(stderr, "GRAN: About to run current thread, which is\n");
778
	     G_TSO(t,5));
779
780
781
782
783
784
785
786

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

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

    procStatus[CurrentProc] = Busy;

787
#elif defined(PAR)
788
789
790
791
    if (PendingFetches != END_BF_QUEUE) {
        processFetches();
    }

792
    /* ToDo: phps merge with spark activation above */
793
    /* check whether we have local work and send requests if we have none */
794
    if (EMPTY_RUN_QUEUE()) {  /* no runnable threads */
795
      /* :-[  no local threads => look out for local sparks */
796
797
      /* the spark pool for the current PE */
      pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
798
      if (advisory_thread_count < RtsFlags.ParFlags.maxThreads &&
799
	  pool->hd < pool->tl) {
800
801
802
803
804
805
806
807
	/* 
	 * 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... 
	 */
808
809

	spark = findSpark(rtsFalse);                /* get a spark */
810
811
	if (spark != (rtsSpark) NULL) {
	  tso = activateSpark(spark);       /* turn the spark into a thread */
812
813
814
	  IF_PAR_DEBUG(schedule,
		       belch("==== schedule: Created TSO %d (%p); %d threads active",
			     tso->id, tso, advisory_thread_count));
815

816
	  if (tso==END_TSO_QUEUE) { /* failed to activate spark->back to loop */
817
	    belch("==^^ failed to activate spark");
818
	    goto next_thread;
819
	  }               /* otherwise fall through & pick-up new tso */
820
821
	} else {
	  IF_PAR_DEBUG(verbose,
822
823
		       belch("==^^ no local sparks (spark pool contains only NFs: %d)", 
			     spark_queue_len(pool)));
824
825
	  goto next_thread;
	}
826
827
828
829
830
831
      }

      /* If we still have no work we need to send a FISH to get a spark
	 from another PE 
      */
      if (EMPTY_RUN_QUEUE()) {
832
833
834
835
836
837
838
839
840
      /* =8-[  no local sparks => look for work on other PEs */
	/*
	 * We really have absolutely no work.  Send out a fish
	 * (there may be some out there already), and wait for
	 * something to arrive.  We clearly can't run any threads
	 * until a SCHEDULE or RESUME arrives, and so that's what
	 * we're hoping to see.  (Of course, we still have to
	 * respond to other types of messages.)
	 */
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
	TIME now = msTime() /*CURRENT_TIME*/;
	IF_PAR_DEBUG(verbose, 
		     belch("--  now=%ld", now));
	IF_PAR_DEBUG(verbose,
		     if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
			 (last_fish_arrived_at!=0 &&
			  last_fish_arrived_at+RtsFlags.ParFlags.fishDelay > now)) {
		       belch("--$$ delaying FISH until %ld (last fish %ld, delay %ld, now %ld)",
			     last_fish_arrived_at+RtsFlags.ParFlags.fishDelay,
			     last_fish_arrived_at,
			     RtsFlags.ParFlags.fishDelay, now);
		     });
	
	if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
	    (last_fish_arrived_at==0 ||
	     (last_fish_arrived_at+RtsFlags.ParFlags.fishDelay <= now))) {
	  /* outstandingFishes is set in sendFish, processFish;
858
859
860
861
	     avoid flooding system with fishes via delay */
	  pe = choosePE();
	  sendFish(pe, mytid, NEW_FISH_AGE, NEW_FISH_HISTORY, 
		   NEW_FISH_HUNGER);
862
863
864
865
866
867

	  // Global statistics: count no. of fishes
	  if (RtsFlags.ParFlags.ParStats.Global &&
	      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
	    globalParStats.tot_fish_mess++;
	  }
868
	}
869
870
      
	receivedFinish = processMessages();
871
872
873
	goto next_thread;
      }
    } else if (PacketsWaiting()) {  /* Look for incoming messages */
874
      receivedFinish = processMessages();
875
876
877
878
    }

    /* Now we are sure that we have some work available */
    ASSERT(run_queue_hd != END_TSO_QUEUE);
879

880
    /* Take a thread from the run queue, if we have work */
881
    t = POP_RUN_QUEUE();  // take_off_run_queue(END_TSO_QUEUE);
882
    IF_DEBUG(sanity,checkTSO(t));
883
884
885
886
887
888

    /* ToDo: write something to the log-file
    if (RTSflags.ParFlags.granSimStats && !sameThread)
        DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);

    CurrentTSO = t;
889
890
891
    */
    /* the spark pool for the current PE */
    pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
892

893
894
895
896
897
898
899
900
901
902
903
904
905
    IF_DEBUG(scheduler, 
	     belch("--=^ %d threads, %d sparks on [%#x]", 
		   run_queue_len(), spark_queue_len(pool), CURRENT_PROC));

#if 1
    if (0 && RtsFlags.ParFlags.ParStats.Full && 
	t && LastTSO && t->id != LastTSO->id && 
	LastTSO->why_blocked == NotBlocked && 
	LastTSO->what_next != ThreadComplete) {
      // if previously scheduled TSO not blocked we have to record the context switch
      DumpVeryRawGranEvent(TimeOfLastYield, CURRENT_PROC, CURRENT_PROC,
			   GR_DESCHEDULE, LastTSO, (StgClosure *)NULL, 0, 0);
    }
906

907
908
909
    if (RtsFlags.ParFlags.ParStats.Full && 
	(emitSchedule /* forced emit */ ||
        (t && LastTSO && t->id != LastTSO->id))) {
910
911
912
913
914
915
916
917
918
      /* 
	 we are running a different TSO, so write a schedule event to log file
	 NB: If we use fair scheduling we also have to write  a deschedule 
	     event for LastTSO; with unfair scheduling we know that the
	     previous tso has blocked whenever we switch to another tso, so
	     we don't need it in GUM for now
      */
      DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
		       GR_SCHEDULE, t, (StgClosure *)NULL, 0, 0);
919
      emitSchedule = rtsFalse;
920
    }
921
     
922
#endif
923
#else /* !GRAN && !PAR */
924
925
926
  
    /* grab a thread from the run queue
     */
927
    ASSERT(run_queue_hd != END_TSO_QUEUE);
928
    t = POP_RUN_QUEUE();
929
930
931

    // Sanity check the thread we're about to run.  This can be
    // expensive if there is lots of thread switching going on...
932
    IF_DEBUG(sanity,checkTSO(t));
933
934

#endif
935
936
937
938
939
940
941
942
    
    /* grab a capability
     */
#ifdef SMP
    cap = free_capabilities;
    free_capabilities = cap->link;
    n_free_capabilities--;
#else
943
    cap = &MainCapability;
944
#endif
945

946
    cap->r.rCurrentTSO = t;
947
    
948
949
950
951
    /* context switches are now initiated by the timer signal, unless
     * the user specified "context switch as often as possible", with
     * +RTS -C0
     */
952
953
954
955
956
957
958
959
    if (
#ifdef PROFILING
	RtsFlags.ProfFlags.profileInterval == 0 ||
#endif
	(RtsFlags.ConcFlags.ctxtSwitchTicks == 0
	 && (run_queue_hd != END_TSO_QUEUE
	     || blocked_queue_hd != END_TSO_QUEUE
	     || sleeping_queue != END_TSO_QUEUE)))
960
961
962
	context_switch = 1;
    else
	context_switch = 0;
963

964
    RELEASE_LOCK(&sched_mutex);
965

966
    IF_DEBUG(scheduler, sched_belch("-->> Running TSO %ld (%p) %s ...", 
967
			      t->id, t, whatNext_strs[t->what_next]));
968

969
970
971
972
#ifdef PROFILING
    startHeapProfTimer();
#endif

973
    /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
974
975
    /* Run the current thread 
     */
976
    switch (cap->r.rCurrentTSO->what_next) {
977
978
    case ThreadKilled:
    case ThreadComplete:
979
980
981
	/* Thread already finished, return to scheduler. */
	ret = ThreadFinished;
	break;
982
    case ThreadEnterGHC:
983
	ret = StgRun((StgFunPtr) stg_enterStackTop, &cap->r);
984
	break;
985
    case ThreadRunGHC:
986
	ret = StgRun((StgFunPtr) stg_returnToStackTop, &cap->r);
987
	break;
988
    case ThreadEnterInterp:
989
990
	ret = interpretBCO(cap);
	break;
991
    default:
992
      barf("schedule: invalid what_next field");
993
    }
994
    /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
995
996
997
    
    /* Costs for the scheduler are assigned to CCS_SYSTEM */
#ifdef PROFILING
998
    stopHeapProfTimer();
999
1000
1001
1002
1003
1004
    CCCS = CCS_SYSTEM;
#endif
    
    ACQUIRE_LOCK(&sched_mutex);

#ifdef SMP
1005
    IF_DEBUG(scheduler,fprintf(stderr,"scheduler (task %ld): ", pthread_self()););
1006
#elif !defined(GRAN) && !defined(PAR)
1007
    IF_DEBUG(scheduler,fprintf(stderr,"scheduler: "););
1008
#endif
1009
    t = cap->r.rCurrentTSO;
1010
    
1011
1012
1013
1014
#if defined(PAR)
    /* HACK 675: if the last thread didn't yield, make sure to print a 
       SCHEDULE event to the log file when StgRunning the next thread, even
       if it is the same one as before */
1015
    LastTSO = t; 
1016
1017
1018
    TimeOfLastYield = CURRENT_TIME;
#endif

1019
1020
    switch (ret) {
    case HeapOverflow:
1021
#if defined(GRAN)
1022
      IF_DEBUG(gran, DumpGranEvent(GR_DESCHEDULE, t));
1023
1024
1025
1026
      globalGranStats.tot_heapover++;
#elif defined(PAR)
      globalParStats.tot_heapover++;
#endif
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080

      // did the task ask for a large block?
      if (cap->r.rHpAlloc > BLOCK_SIZE_W) {
	  // if so, get one and push it on the front of the nursery.
	  bdescr *bd;
	  nat blocks;
	  
	  blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc * sizeof(W_)) / BLOCK_SIZE;

	  IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped: requesting a large block (size %d)", 
				   t->id, t,
				   whatNext_strs[t->what_next], blocks));

	  // don't do this if it would push us over the
	  // alloc_blocks_lim limit; we'll GC first.
	  if (alloc_blocks + blocks < alloc_blocks_lim) {

	      alloc_blocks += blocks;
	      bd = allocGroup( blocks );

	      // link the new group into the list
	      bd->link = cap->r.rCurrentNursery;
	      bd->u.back = cap->r.rCurrentNursery->u.back;
	      if (cap->r.rCurrentNursery->u.back != NULL) {
		  cap->r.rCurrentNursery->u.back->link = bd;
	      } else {
		  ASSERT(g0s0->blocks == cap->r.rCurrentNursery &&
			 g0s0->blocks == cap->r.rNursery);
		  cap->r.rNursery = g0s0->blocks = bd;
	      }		  
	      cap->r.rCurrentNursery->u.back = bd;

	      // initialise it as a nursery block
	      bd->step = g0s0;
	      bd->gen_no = 0;
	      bd->flags = 0;
	      bd->free = bd->start;

	      // don't forget to update the block count in g0s0.
	      g0s0->n_blocks += blocks;
	      ASSERT(countBlocks(g0s0->blocks) == g0s0->n_blocks);

	      // now update the nursery to point to the new block
	      cap->r.rCurrentNursery = bd;

	      // we might be unlucky and have another thread get on the
	      // run queue before us and steal the large block, but in that
	      // case the thread will just end up requesting another large
	      // block.
	      PUSH_ON_RUN_QUEUE(t);
	      break;
	  }
      }

1081
1082
1083
1084
      /* make all the running tasks block on a condition variable,
       * maybe set context_switch and wait till they all pile in,
       * then have them wait on a GC condition variable.
       */
1085
      IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped: HeapOverflow", 
1086
			       t->id, t, whatNext_strs[t->what_next]));
1087
      threadPaused(t);
1088
1089
#if defined(GRAN)
      ASSERT(!is_on_queue(t,CurrentProc));
1090
1091
1092
1093
1094
1095
1096
1097
1098
#elif defined(PAR)
      /* Currently we emit a DESCHEDULE event before GC in GUM.
         ToDo: either add separate event to distinguish SYSTEM time from rest
	       or just nuke this DESCHEDULE (and the following SCHEDULE) */
      if (0 && RtsFlags.ParFlags.ParStats.Full) {
	DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
			 GR_DESCHEDULE, t, (StgClosure *)NULL, 0, 0);
	emitSchedule = rtsTrue;
      }
1099
#endif
1100
1101
1102
1103
      
      ready_to_gc = rtsTrue;
      context_switch = 1;		/* stop other threads ASAP */
      PUSH_ON_RUN_QUEUE(t);
1104
      /* actual GC is done at the end of the while loop */
1105
1106
1107
      break;
      
    case StackOverflow:
1108
1109
1110
1111
1112
1113
1114
1115
1116
#if defined(GRAN)
      IF_DEBUG(gran, 
	       DumpGranEvent(GR_DESCHEDULE, t));
      globalGranStats.tot_stackover++;
#elif defined(PAR)
      // IF_DEBUG(par, 
      // DumpGranEvent(GR_DESCHEDULE, t);
      globalParStats.tot_stackover++;
#endif
1117
      IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped, StackOverflow", 
1118
			       t->id, t, whatNext_strs[t->what_next]));
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
      /* just adjust the stack for this thread, then pop it back
       * on the run queue.
       */
      threadPaused(t);
      { 
	StgMainThread *m;
	/* enlarge the stack */
	StgTSO *new_t = threadStackOverflow(t);
	
	/* This TSO has moved, so update any pointers to it from the
	 * main thread stack.  It better not be on any other queues...
1130
	 * (it shouldn't be).
1131
1132
1133
1134
1135
1136
	 */
	for (m = main_threads; m != NULL; m = m->link) {
	  if (m->tso == t) {
	    m->tso = new_t;
	  }
	}
1137
	threadPaused(new_t);
1138
1139
1140
1141
1142
	PUSH_ON_RUN_QUEUE(new_t);
      }
      break;

    case ThreadYielding:
1143
1144
1145
1146
1147
#if defined(GRAN)
      IF_DEBUG(gran, 
	       DumpGranEvent(GR_DESCHEDULE, t));
      globalGranStats.tot_yields++;
#elif defined(PAR)
1148
1149
1150
      // IF_DEBUG(par, 
      // DumpGranEvent(GR_DESCHEDULE, t);
      globalParStats.tot_yields++;
1151
#endif
1152
1153
1154
1155
1156
      /* put the thread back on the run queue.  Then, if we're ready to
       * GC, check whether this is the last task to stop.  If so, wake
       * up the GC thread.  getThread will block during a GC until the
       * GC is finished.
       */
1157
      IF_DEBUG(scheduler,
1158
               if (t->what_next == ThreadEnterInterp) {
1159
1160
1161
		   /* ToDo: or maybe a timer expired when we were in Hugs?
		    * or maybe someone hit ctrl-C
                    */
1162
                   belch("--<< thread %ld (%p; %s) stopped to switch to Hugs", 
1163
1164
			 t->id, t, whatNext_strs[t->what_next]);
               } else {
1165
                   belch("--<< thread %ld (%p; %s) stopped, yielding", 
1166
1167
1168
			 t->id, t, whatNext_strs[t->what_next]);
               }
               );
1169

1170
      threadPaused(t);
1171

1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
      IF_DEBUG(sanity,
	       //belch("&& Doing sanity check on yielding TSO %ld.", t->id);
	       checkTSO(t));
      ASSERT(t->link == END_TSO_QUEUE);
#if defined(GRAN)
      ASSERT(!is_on_queue(t,CurrentProc));

      IF_DEBUG(sanity,
	       //belch("&& Doing sanity check on all ThreadQueues (and their TSOs).");
	       checkThreadQsSanity(rtsTrue));
#endif
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
#if defined(PAR)
      if (RtsFlags.ParFlags.doFairScheduling) { 
	/* this does round-robin scheduling; good for concurrency */
	APPEND_TO_RUN_QUEUE(t);
      } else {
	/* this does unfair scheduling; good for parallelism */
	PUSH_ON_RUN_QUEUE(t);
      }
#else
      /* this does round-robin scheduling; good for concurrency */
1193
      APPEND_TO_RUN_QUEUE(t);
1194
#endif
1195
1196
1197
1198
1199
1200
1201
1202
#if defined(GRAN)
      /* add a ContinueThread event to actually process the thread */
      new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
		ContinueThread,
		t, (StgClosure*)NULL, (rtsSpark*)NULL);
      IF_GRAN_DEBUG(bq, 
	       belch("GRAN: eventq and runnableq after adding yielded thread to queue again:");
	       G_EVENTQ(0);
1203
	       G_CURR_THREADQ(0));
1204
#endif /* GRAN */
1205
1206
1207
      break;
      
    case ThreadBlocked:
1208
#if defined(GRAN)
1209
      IF_DEBUG(scheduler,
1210
	       belch("--<< thread %ld (%p; %s) stopped, blocking on node %p [PE %d] with BQ: ", 
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
			       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));

      // ??? needed; should emit block before
      IF_DEBUG(gran, 
	       DumpGranEvent(GR_DESCHEDULE, t)); 
      prune_eventq(t, (StgClosure *)NULL); // prune ContinueThreads for t
      /*
	ngoq Dogh!
      ASSERT(procStatus[CurrentProc]==Busy || 
	      ((procStatus[CurrentProc]==Fetching) && 
	      (t->block_info.closure!=(StgClosure*)NULL)));
      if (run_queue_hds[CurrentProc] == END_TSO_QUEUE &&
	  !(!RtsFlags.GranFlags.DoAsyncFetch &&
	    procStatus[CurrentProc]==Fetching)) 
	procStatus[CurrentProc] = Idle;
      */
1228
#elif defined(PAR)
1229
1230
1231
1232
1233
1234
1235
      IF_DEBUG(scheduler,
	       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_PAR_DEBUG(bq,

		   if (t->block_info.closure!=(StgClosure*)NULL) 
		     print_bq(t->block_info.closure));
1236
1237
1238
1239

      /* Send a fetch (if BlockedOnGA) and dump event to log file */
      blockThread(t);

1240
1241
      /* whatever we schedule next, we must log that schedule */
      emitSchedule = rtsTrue;
1242
1243

#else /* !GRAN */
1244
1245
1246
1247
1248
1249
      /* don't need to do anything.  Either the thread is blocked on
       * I/O, in which case we'll have called addToBlockedQueue
       * previously, or it's blocked on an MVar or Blackhole, in which
       * case it'll be on the relevant queue already.
       */
      IF_DEBUG(scheduler,
1250
	       fprintf(stderr, "--<< thread %d (%p) stopped: ", t->id, t);
1251
1252
	       printThreadBlockage(t);
	       fprintf(stderr, "\n"));
1253
1254
1255
1256
1257
1258

      /* Only for dumping event to log file 
	 ToDo: do I need this in GranSim, too?
      blockThread(t);
      */
#endif
1259
1260
1261
1262
1263
1264
1265
1266
1267
      threadPaused(t);
      break;
      
    case ThreadFinished:
      /* Need to check whether this was a main thread, and if so, signal
       * the task that started it with the return value.  If we have no
       * more main threads, we probably need to stop all the tasks until
       * we get a new one.
       */
1268
1269
1270
      /* We also end up here if the thread kills itself with an
       * uncaught exception, see Exception.hc.
       */
1271
      IF_DEBUG(scheduler,belch("--++ thread %d (%p) finished", t->id, t));
1272
#if defined(GRAN)
1273
      endThread(t, CurrentProc); // clean-up the thread
1274
#elif defined(PAR)
1275
1276
      /* For now all are advisory -- HWL */
      //if(t->priority==AdvisoryPriority) ??
1277
      advisory_thread_count--;
1278
1279
1280
1281
1282
1283
1284
1285
      
# ifdef DIST
      if(t->dist.priority==RevalPriority)
	FinishReval(t);
# endif
      
      if (RtsFlags.ParFlags.ParStats.Full &&
	  !RtsFlags.ParFlags.ParStats.Suppressed) 
1286
1287
	DumpEndEvent(CURRENT_PROC, t, rtsFalse /* not mandatory */);
#endif
1288
1289
1290
      break;
      
    default:
1291
      barf("schedule: invalid thread return code %d", (int)ret);
1292
1293
1294
1295
1296
1297
1298
1299
    }
    
#ifdef SMP
    cap->link = free_capabilities;
    free_capabilities = cap;
    n_free_capabilities++;
#endif

1300
1301
#ifdef PROFILING
    if (RtsFlags.ProfFlags.profileInterval==0 || performHeapProfile) {
1302
1303
	GarbageCollect(GetRoots, rtsTrue);
	heapCensus();
1304
1305
1306
1307
1308
	performHeapProfile = rtsFalse;
	ready_to_gc = rtsFalse;	// we already GC'd
    }
#endif

1309
#ifdef SMP
1310
    if (ready_to_gc && n_free_capabilities == RtsFlags.ParFlags.nNodes) 
1311
#else
1312
    if (ready_to_gc) 
1313
#endif
1314
      {
1315
1316
1317
1318
1319
1320
      /* 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
       * broadcast on gc_pending_cond afterward.
       */
#ifdef SMP
1321
      IF_DEBUG(scheduler,sched_belch("doing GC"));
1322
#endif
1323
      GarbageCollect(GetRoots,rtsFalse);
1324
1325
1326
1327
      ready_to_gc = rtsFalse;
#ifdef SMP
      pthread_cond_broadcast(&gc_pending_cond);
#endif
1328
1329
1330
1331
1332
1333
1334
1335
#if defined(GRAN)
      /* add a ContinueThread event to continue execution of current thread */
      new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
		ContinueThread,
		t, (StgClosure*)NULL, (rtsSpark*)NULL);
      IF_GRAN_DEBUG(bq, 
	       fprintf(stderr, "GRAN: eventq and runnableq after Garbage collection:\n");
	       G_EVENTQ(0);
1336
	       G_CURR_THREADQ(0));
1337
#endif /* GRAN */
1338
    }
1339

1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
#if defined(GRAN)
  next_thread:
    IF_GRAN_DEBUG(unused,
		  print_eventq(EventHd));

    event = get_next_event();
#elif defined(PAR)
  next_thread:
    /* ToDo: wait for next message to arrive rather than busy wait */
#endif /* GRAN */
1350

1351
  } /* end of while(1) */
1352

1353
1354
  IF_PAR_DEBUG(verbose,
	       belch("== Leaving schedule() after having received Finish"));
1355
1356
}

1357
1358
1359
1360
1361
1362
1363
/* ---------------------------------------------------------------------------
 * deleteAllThreads():  kill all the live threads.
 *
 * This is used when we catch a user interrupt (^C), before performing
 * any necessary cleanups and running finalizers.
 * ------------------------------------------------------------------------- */
   
1364
1365
1366
void deleteAllThreads ( void )
{
  StgTSO* t;
1367
  IF_DEBUG(scheduler,sched_belch("deleting all threads"));
1368
  for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
1369
      deleteThread(t);
1370
1371
  }
  for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
1372
1373
1374
1375
      deleteThread(t);
  }
  for (t = sleeping_queue; t != END_TSO_QUEUE; t = t->link) {
      deleteThread(t);
1376
1377
1378
  }
  run_queue_hd = run_queue_tl = END_TSO_QUEUE;
  blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
1379
  sleeping_queue = END_TSO_QUEUE;
1380
1381
}

1382
/* startThread and  insertThread are now in GranSim.c -- HWL */