ghc/rts/Schedule.c

   1 /* ---------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.159 2002/12/11 15:36:50 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * Scheduler
   7  *
   8  * Different GHC ways use this scheduler quite differently (see comments below)
   9  * Here is the global picture:
  10  *
  11  * WAY  Name     CPP flag  What's it for
  12  * --------------------------------------
  13  * mp   GUM      PAR          Parallel execution on a distributed memory machine
  14  * s    SMP      SMP          Parallel execution on a shared memory machine
  15  * mg   GranSim  GRAN         Simulation of parallel execution
  16  * md   GUM/GdH  DIST         Distributed execution (based on GUM)
  17  *
  18  * --------------------------------------------------------------------------*/
  19
  20 //@node Main scheduling code, , ,
  21 //@section Main scheduling code
  22
  23 /*
  24  * Version with scheduler monitor support for SMPs (WAY=s):
  25
  26    This design provides a high-level API to create and schedule threads etc.
  27    as documented in the SMP design document.
  28
  29    It uses a monitor design controlled by a single mutex to exercise control
  30    over accesses to shared data structures, and builds on the Posix threads
  31    library.
  32
  33    The majority of state is shared.  In order to keep essential per-task state,
  34    there is a Capability structure, which contains all the information
  35    needed to run a thread: its STG registers, a pointer to its TSO, a
  36    nursery etc.  During STG execution, a pointer to the capability is
  37    kept in a register (BaseReg).
  38
  39    In a non-SMP build, there is one global capability, namely MainRegTable.
  40
  41    SDM & KH, 10/99
  42
  43  * Version with support for distributed memory parallelism aka GUM (WAY=mp):
  44
  45    The main scheduling loop in GUM iterates until a finish message is received.
  46    In that case a global flag @receivedFinish@ is set and this instance of
  47    the RTS shuts down. See ghc/rts/parallel/HLComms.c:processMessages()
  48    for the handling of incoming messages, such as PP_FINISH.
  49    Note that in the parallel case we have a system manager that coordinates
  50    different PEs, each of which are running one instance of the RTS.
  51    See ghc/rts/parallel/SysMan.c for the main routine of the parallel program.
  52    From this routine processes executing ghc/rts/Main.c are spawned. -- HWL
  53
  54  * Version with support for simulating parallel execution aka GranSim (WAY=mg):
  55
  56    The main scheduling code in GranSim is quite different from that in std
  57    (concurrent) Haskell: while concurrent Haskell just iterates over the
  58    threads in the runnable queue, GranSim is event driven, i.e. it iterates
  59    over the events in the global event queue.  -- HWL
  60 */
  61
  62 //@menu
  63 //* Includes::
  64 //* Variables and Data structures::
  65 //* Main scheduling loop::
  66 //* Suspend and Resume::
  67 //* Run queue code::
  68 //* Garbage Collextion Routines::
  69 //* Blocking Queue Routines::
  70 //* Exception Handling Routines::
  71 //* Debugging Routines::
  72 //* Index::
  73 //@end menu
  74
  75 //@node Includes, Variables and Data structures, Main scheduling code, Main scheduling code
  76 //@subsection Includes
  77
  78 #include "PosixSource.h"
  79 #include "Rts.h"
  80 #include "SchedAPI.h"
  81 #include "RtsUtils.h"
  82 #include "RtsFlags.h"
  83 #include "Storage.h"
  84 #include "StgRun.h"
  85 #include "StgStartup.h"
  86 #include "Hooks.h"
  87 #define COMPILING_SCHEDULER
  88 #include "Schedule.h"
  89 #include "StgMiscClosures.h"
  90 #include "Storage.h"
  91 #include "Interpreter.h"
  92 #include "Exception.h"
  93 #include "Printer.h"
  94 #include "Main.h"
  95 #include "Signals.h"
  96 #include "Sanity.h"
  97 #include "Stats.h"
  98 #include "Itimer.h"
  99 #include "Prelude.h"
 100 #include "ThreadLabels.h"
 101 #ifdef PROFILING
 102 #include "Proftimer.h"
 103 #include "ProfHeap.h"
 104 #endif
 105 #if defined(GRAN) || defined(PAR)
 106 # include "GranSimRts.h"
 107 # include "GranSim.h"
 108 # include "ParallelRts.h"
 109 # include "Parallel.h"
 110 # include "ParallelDebug.h"
 111 # include "FetchMe.h"
 112 # include "HLC.h"
 113 #endif
 114 #include "Sparks.h"
 115 #include "Capability.h"
 116 #include "OSThreads.h"
 117 #include  "Task.h"
 118
 119 #ifdef HAVE_SYS_TYPES_H
 120 #include <sys/types.h>
 121 #endif
 122 #ifdef HAVE_UNISTD_H
 123 #include <unistd.h>
 124 #endif
 125
 126 #include <string.h>
 127 #include <stdlib.h>
 128 #include <stdarg.h>
 129
 130 //@node Variables and Data structures, Prototypes, Includes, Main scheduling code
 131 //@subsection Variables and Data structures
 132
 133 /* Main thread queue.
 134  * Locks required: sched_mutex.
 135  */
 136 StgMainThread *main_threads = NULL;
 137
 138 /* Thread queues.
 139  * Locks required: sched_mutex.
 140  */
 141 #if defined(GRAN)
 142
 143 StgTSO* ActiveTSO = NULL; /* for assigning system costs; GranSim-Light only */
 144 /* rtsTime TimeOfNextEvent, EndOfTimeSlice;            now in GranSim.c */
 145
 146 /*
 147    In GranSim we have a runnable and a blocked queue for each processor.
 148    In order to minimise code changes new arrays run_queue_hds/tls
 149    are created. run_queue_hd is then a short cut (macro) for
 150    run_queue_hds[CurrentProc] (see GranSim.h).
 151    -- HWL
 152 */
 153 StgTSO *run_queue_hds[MAX_PROC], *run_queue_tls[MAX_PROC];
 154 StgTSO *blocked_queue_hds[MAX_PROC], *blocked_queue_tls[MAX_PROC];
 155 StgTSO *ccalling_threadss[MAX_PROC];
 156 /* We use the same global list of threads (all_threads) in GranSim as in
 157    the std RTS (i.e. we are cheating). However, we don't use this list in
 158    the GranSim specific code at the moment (so we are only potentially
 159    cheating).  */
 160
 161 #else /* !GRAN */
 162
 163 StgTSO *run_queue_hd = NULL;
 164 StgTSO *run_queue_tl = NULL;
 165 StgTSO *blocked_queue_hd = NULL;
 166 StgTSO *blocked_queue_tl = NULL;
 167 StgTSO *sleeping_queue = NULL;    /* perhaps replace with a hash table? */
 168
 169 #endif
 170
 171 /* Linked list of all threads.
 172  * Used for detecting garbage collected threads.
 173  */
 174 StgTSO *all_threads = NULL;
 175
 176 /* When a thread performs a safe C call (_ccall_GC, using old
 177  * terminology), it gets put on the suspended_ccalling_threads
 178  * list. Used by the garbage collector.
 179  */
 180 static StgTSO *suspended_ccalling_threads;
 181
 182 static StgTSO *threadStackOverflow(StgTSO *tso);
 183
 184 /* KH: The following two flags are shared memory locations.  There is no need
 185        to lock them, since they are only unset at the end of a scheduler
 186        operation.
 187 */
 188
 189 /* flag set by signal handler to precipitate a context switch */
 190 //@cindex context_switch
 191 nat context_switch = 0;
 192
 193 /* if this flag is set as well, give up execution */
 194 //@cindex interrupted
 195 rtsBool interrupted = rtsFalse;
 196
 197 /* Next thread ID to allocate.
 198  * Locks required: thread_id_mutex
 199  */
 200 //@cindex next_thread_id
 201 static StgThreadID next_thread_id = 1;
 202
 203 /*
 204  * Pointers to the state of the current thread.
 205  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
 206  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
 207  */
 208
 209 /* The smallest stack size that makes any sense is:
 210  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
 211  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
 212  *  + 1                       (the realworld token for an IO thread)
 213  *  + 1                       (the closure to enter)
 214  *
 215  * A thread with this stack will bomb immediately with a stack
 216  * overflow, which will increase its stack size.
 217  */
 218
 219 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
 220
 221
 222 #if defined(GRAN)
 223 StgTSO *CurrentTSO;
 224 #endif
 225
 226 /*  This is used in `TSO.h' and gcc 2.96 insists that this variable actually
 227  *  exists - earlier gccs apparently didn't.
 228  *  -= chak
 229  */
 230 StgTSO dummy_tso;
 231
 232 static rtsBool ready_to_gc;
 233
 234 /*
 235  * Set to TRUE when entering a shutdown state (via shutdownHaskellAndExit()) --
 236  * in an MT setting, needed to signal that a worker thread shouldn't hang around
 237  * in the scheduler when it is out of work.
 238  */
 239 static rtsBool shutting_down_scheduler = rtsFalse;
 240
 241 void            addToBlockedQueue ( StgTSO *tso );
 242
 243 static void     schedule          ( void );
 244        void     interruptStgRts   ( void );
 245
 246 static void     detectBlackHoles  ( void );
 247
 248 #ifdef DEBUG
 249 static void sched_belch(char *s, ...);
 250 #endif
 251
 252 #if defined(RTS_SUPPORTS_THREADS)
 253 /* ToDo: carefully document the invariants that go together
 254  *       with these synchronisation objects.
 255  */
 256 Mutex     sched_mutex       = INIT_MUTEX_VAR;
 257 Mutex     term_mutex        = INIT_MUTEX_VAR;
 258
 259 /*
 260  * A heavyweight solution to the problem of protecting
 261  * the thread_id from concurrent update.
 262  */
 263 Mutex     thread_id_mutex   = INIT_MUTEX_VAR;
 264
 265
 266 # if defined(SMP)
 267 static Condition gc_pending_cond = INIT_COND_VAR;
 268 nat await_death;
 269 # endif
 270
 271 #endif /* RTS_SUPPORTS_THREADS */
 272
 273 #if defined(PAR)
 274 StgTSO *LastTSO;
 275 rtsTime TimeOfLastYield;
 276 rtsBool emitSchedule = rtsTrue;
 277 #endif
 278
 279 #if DEBUG
 280 static char *whatNext_strs[] = {
 281   "ThreadRunGHC",
 282   "ThreadInterpret",
 283   "ThreadKilled",
 284   "ThreadRelocated",
 285   "ThreadComplete"
 286 };
 287 #endif
 288
 289 #if defined(PAR)
 290 StgTSO * createSparkThread(rtsSpark spark);
 291 StgTSO * activateSpark (rtsSpark spark);
 292 #endif
 293
 294 /*
 295  * The thread state for the main thread.
 296 // ToDo: check whether not needed any more
 297 StgTSO   *MainTSO;
 298  */
 299
 300 #if defined(PAR) || defined(RTS_SUPPORTS_THREADS)
 301 static void taskStart(void);
 302 static void
 303 taskStart(void)
 304 {
 305   schedule();
 306 }
 307 #endif
 308
 309
 310
 311
 312 //@node Main scheduling loop, Suspend and Resume, Prototypes, Main scheduling code
 313 //@subsection Main scheduling loop
 314
 315 /* ---------------------------------------------------------------------------
 316    Main scheduling loop.
 317
 318    We use round-robin scheduling, each thread returning to the
 319    scheduler loop when one of these conditions is detected:
 320
 321       * out of heap space
 322       * timer expires (thread yields)
 323       * thread blocks
 324       * thread ends
 325       * stack overflow
 326
 327    Locking notes:  we acquire the scheduler lock once at the beginning
 328    of the scheduler loop, and release it when
 329
 330       * running a thread, or
 331       * waiting for work, or
 332       * waiting for a GC to complete.
 333
 334    GRAN version:
 335      In a GranSim setup this loop iterates over the global event queue.
 336      This revolves around the global event queue, which determines what
 337      to do next. Therefore, it's more complicated than either the
 338      concurrent or the parallel (GUM) setup.
 339
 340    GUM version:
 341      GUM iterates over incoming messages.
 342      It starts with nothing to do (thus CurrentTSO == END_TSO_QUEUE),
 343      and sends out a fish whenever it has nothing to do; in-between
 344      doing the actual reductions (shared code below) it processes the
 345      incoming messages and deals with delayed operations
 346      (see PendingFetches).
 347      This is not the ugliest code you could imagine, but it's bloody close.
 348
 349    ------------------------------------------------------------------------ */
 350 //@cindex schedule
 351 static void
 352 schedule( void )
 353 {
 354   StgTSO *t;
 355   Capability *cap;
 356   StgThreadReturnCode ret;
 357 #if defined(GRAN)
 358   rtsEvent *event;
 359 #elif defined(PAR)
 360   StgSparkPool *pool;
 361   rtsSpark spark;
 362   StgTSO *tso;
 363   GlobalTaskId pe;
 364   rtsBool receivedFinish = rtsFalse;
 365 # if defined(DEBUG)
 366   nat tp_size, sp_size; // stats only
 367 # endif
 368 #endif
 369   rtsBool was_interrupted = rtsFalse;
 370   StgTSOWhatNext prev_what_next;
 371
 372   ACQUIRE_LOCK(&sched_mutex);
 373
 374 #if defined(RTS_SUPPORTS_THREADS)
 375   waitForWorkCapability(&sched_mutex, &cap, rtsFalse);
 376 #else
 377   /* simply initialise it in the non-threaded case */
 378   grabCapability(&cap);
 379 #endif
 380
 381 #if defined(GRAN)
 382   /* set up first event to get things going */
 383   /* ToDo: assign costs for system setup and init MainTSO ! */
 384   new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
 385             ContinueThread,
 386             CurrentTSO, (StgClosure*)NULL, (rtsSpark*)NULL);
 387
 388   IF_DEBUG(gran,
 389            fprintf(stderr, "GRAN: Init CurrentTSO (in schedule) = %p\n", CurrentTSO);
 390            G_TSO(CurrentTSO, 5));
 391
 392   if (RtsFlags.GranFlags.Light) {
 393     /* Save current time; GranSim Light only */
 394     CurrentTSO->gran.clock = CurrentTime[CurrentProc];
 395   }
 396
 397   event = get_next_event();
 398
 399   while (event!=(rtsEvent*)NULL) {
 400     /* Choose the processor with the next event */
 401     CurrentProc = event->proc;
 402     CurrentTSO = event->tso;
 403
 404 #elif defined(PAR)
 405
 406   while (!receivedFinish) {    /* set by processMessages */
 407                                /* when receiving PP_FINISH message         */
 408 #else
 409
 410   while (1) {
 411
 412 #endif
 413
 414     IF_DEBUG(scheduler, printAllThreads());
 415
 416 #if defined(RTS_SUPPORTS_THREADS)
 417     /* Check to see whether there are any worker threads
 418        waiting to deposit external call results. If so,
 419        yield our capability */
 420     yieldToReturningWorker(&sched_mutex, &cap);
 421 #endif
 422
 423     /* If we're interrupted (the user pressed ^C, or some other
 424      * termination condition occurred), kill all the currently running
 425      * threads.
 426      */
 427     if (interrupted) {
 428       IF_DEBUG(scheduler, sched_belch("interrupted"));
 429       deleteAllThreads();
 430       interrupted = rtsFalse;
 431       was_interrupted = rtsTrue;
 432     }
 433
 434     /* Go through the list of main threads and wake up any
 435      * clients whose computations have finished.  ToDo: this
 436      * should be done more efficiently without a linear scan
 437      * of the main threads list, somehow...
 438      */
 439 #if defined(RTS_SUPPORTS_THREADS)
 440     {
 441       StgMainThread *m, **prev;
 442       prev = &main_threads;
 443       for (m = main_threads; m != NULL; m = m->link) {
 444         switch (m->tso->what_next) {
 445         case ThreadComplete:
 446           if (m->ret) {
 447               // NOTE: return val is tso->sp[1] (see StgStartup.hc)
 448               *(m->ret) = (StgClosure *)m->tso->sp[1];
 449           }
 450           *prev = m->link;
 451           m->stat = Success;
 452           broadcastCondition(&m->wakeup);
 453 #ifdef DEBUG
 454           removeThreadLabel((StgWord)m->tso);
 455 #endif
 456           break;
 457         case ThreadKilled:
 458           if (m->ret) *(m->ret) = NULL;
 459           *prev = m->link;
 460           if (was_interrupted) {
 461             m->stat = Interrupted;
 462           } else {
 463             m->stat = Killed;
 464           }
 465           broadcastCondition(&m->wakeup);
 466 #ifdef DEBUG
 467           removeThreadLabel((StgWord)m->tso);
 468 #endif
 469           break;
 470         default:
 471           break;
 472         }
 473       }
 474     }
 475
 476 #else /* not threaded */
 477
 478 # if defined(PAR)
 479     /* in GUM do this only on the Main PE */
 480     if (IAmMainThread)
 481 # endif
 482     /* If our main thread has finished or been killed, return.
 483      */
 484     {
 485       StgMainThread *m = main_threads;
 486       if (m->tso->what_next == ThreadComplete
 487           || m->tso->what_next == ThreadKilled) {
 488 #ifdef DEBUG
 489         removeThreadLabel((StgWord)m->tso);
 490 #endif
 491         main_threads = main_threads->link;
 492         if (m->tso->what_next == ThreadComplete) {
 493             // We finished successfully, fill in the return value
 494             // NOTE: return val is tso->sp[1] (see StgStartup.hc)
 495             if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[1]; };
 496             m->stat = Success;
 497             return;
 498         } else {
 499           if (m->ret) { *(m->ret) = NULL; };
 500           if (was_interrupted) {
 501             m->stat = Interrupted;
 502           } else {
 503             m->stat = Killed;
 504           }
 505           return;
 506         }
 507       }
 508     }
 509 #endif
 510
 511     /* Top up the run queue from our spark pool.  We try to make the
 512      * number of threads in the run queue equal to the number of
 513      * free capabilities.
 514      *
 515      * Disable spark support in SMP for now, non-essential & requires
 516      * a little bit of work to make it compile cleanly. -- sof 1/02.
 517      */
 518 #if 0 /* defined(SMP) */
 519     {
 520       nat n = getFreeCapabilities();
 521       StgTSO *tso = run_queue_hd;
 522
 523       /* Count the run queue */
 524       while (n > 0 && tso != END_TSO_QUEUE) {
 525         tso = tso->link;
 526         n--;
 527       }
 528
 529       for (; n > 0; n--) {
 530         StgClosure *spark;
 531         spark = findSpark(rtsFalse);
 532         if (spark == NULL) {
 533           break; /* no more sparks in the pool */
 534         } else {
 535           /* I'd prefer this to be done in activateSpark -- HWL */
 536           /* tricky - it needs to hold the scheduler lock and
 537            * not try to re-acquire it -- SDM */
 538           createSparkThread(spark);
 539           IF_DEBUG(scheduler,
 540                    sched_belch("==^^ turning spark of closure %p into a thread",
 541                                (StgClosure *)spark));
 542         }
 543       }
 544       /* We need to wake up the other tasks if we just created some
 545        * work for them.
 546        */
 547       if (getFreeCapabilities() - n > 1) {
 548           signalCondition( &thread_ready_cond );
 549       }
 550     }
 551 #endif // SMP
 552
 553     /* check for signals each time around the scheduler */
 554 #ifndef mingw32_TARGET_OS
 555     if (signals_pending()) {
 556       RELEASE_LOCK(&sched_mutex); /* ToDo: kill */
 557       startSignalHandlers();
 558       ACQUIRE_LOCK(&sched_mutex);
 559     }
 560 #endif
 561
 562     /* Check whether any waiting threads need to be woken up.  If the
 563      * run queue is empty, and there are no other tasks running, we
 564      * can wait indefinitely for something to happen.
 565      * ToDo: what if another client comes along & requests another
 566      * main thread?
 567      */
 568     if ( !EMPTY_QUEUE(blocked_queue_hd) || !EMPTY_QUEUE(sleeping_queue) ) {
 569       awaitEvent( EMPTY_RUN_QUEUE()
 570 #if defined(SMP)
 571         && allFreeCapabilities()
 572 #endif
 573         );
 574     }
 575     /* we can be interrupted while waiting for I/O... */
 576     if (interrupted) continue;
 577
 578     /*
 579      * Detect deadlock: when we have no threads to run, there are no
 580      * threads waiting on I/O or sleeping, and all the other tasks are
 581      * waiting for work, we must have a deadlock of some description.
 582      *
 583      * We first try to find threads blocked on themselves (ie. black
 584      * holes), and generate NonTermination exceptions where necessary.
 585      *
 586      * If no threads are black holed, we have a deadlock situation, so
 587      * inform all the main threads.
 588      */
 589 #ifndef PAR
 590     if (   EMPTY_THREAD_QUEUES()
 591 #if defined(RTS_SUPPORTS_THREADS)
 592         && EMPTY_QUEUE(suspended_ccalling_threads)
 593 #endif
 594 #ifdef SMP
 595         && allFreeCapabilities()
 596 #endif
 597         )
 598     {
 599         IF_DEBUG(scheduler, sched_belch("deadlocked, forcing major GC..."));
 600 #if defined(THREADED_RTS)
 601         /* and SMP mode ..? */
 602         releaseCapability(cap);
 603 #endif
 604         // Garbage collection can release some new threads due to
 605         // either (a) finalizers or (b) threads resurrected because
 606         // they are about to be send BlockedOnDeadMVar.  Any threads
 607         // thus released will be immediately runnable.
 608         GarbageCollect(GetRoots,rtsTrue);
 609
 610         if ( !EMPTY_RUN_QUEUE() ) { goto not_deadlocked; }
 611
 612         IF_DEBUG(scheduler,
 613                  sched_belch("still deadlocked, checking for black holes..."));
 614         detectBlackHoles();
 615
 616         if ( !EMPTY_RUN_QUEUE() ) { goto not_deadlocked; }
 617
 618 #ifndef mingw32_TARGET_OS
 619         /* If we have user-installed signal handlers, then wait
 620          * for signals to arrive rather then bombing out with a
 621          * deadlock.
 622          */
 623 #if defined(RTS_SUPPORTS_THREADS)
 624         if ( 0 ) { /* hmm..what to do? Simply stop waiting for
 625                       a signal with no runnable threads (or I/O
 626                       suspended ones) leads nowhere quick.
 627                       For now, simply shut down when we reach this
 628                       condition.
 629
 630                       ToDo: define precisely under what conditions
 631                       the Scheduler should shut down in an MT setting.
 632                    */
 633 #else
 634         if ( anyUserHandlers() ) {
 635 #endif
 636             IF_DEBUG(scheduler,
 637                      sched_belch("still deadlocked, waiting for signals..."));
 638
 639             awaitUserSignals();
 640
 641             // we might be interrupted...
 642             if (interrupted) { continue; }
 643
 644             if (signals_pending()) {
 645                 RELEASE_LOCK(&sched_mutex);
 646                 startSignalHandlers();
 647                 ACQUIRE_LOCK(&sched_mutex);
 648             }
 649             ASSERT(!EMPTY_RUN_QUEUE());
 650             goto not_deadlocked;
 651         }
 652 #endif
 653
 654         /* Probably a real deadlock.  Send the current main thread the
 655          * Deadlock exception (or in the SMP build, send *all* main
 656          * threads the deadlock exception, since none of them can make
 657          * progress).
 658          */
 659         {
 660             StgMainThread *m;
 661 #if defined(RTS_SUPPORTS_THREADS)
 662             for (m = main_threads; m != NULL; m = m->link) {
 663                 switch (m->tso->why_blocked) {
 664                 case BlockedOnBlackHole:
 665                     raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
 666                     break;
 667                 case BlockedOnException:
 668                 case BlockedOnMVar:
 669                     raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
 670                     break;
 671                 default:
 672                     barf("deadlock: main thread blocked in a strange way");
 673                 }
 674             }
 675 #else
 676             m = main_threads;
 677             switch (m->tso->why_blocked) {
 678             case BlockedOnBlackHole:
 679                 raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
 680                 break;
 681             case BlockedOnException:
 682             case BlockedOnMVar:
 683                 raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
 684                 break;
 685             default:
 686                 barf("deadlock: main thread blocked in a strange way");
 687             }
 688 #endif
 689         }
 690
 691 #if defined(RTS_SUPPORTS_THREADS)
 692         /* ToDo: revisit conditions (and mechanism) for shutting
 693            down a multi-threaded world  */
 694         IF_DEBUG(scheduler, sched_belch("all done, i think...shutting down."));
 695         RELEASE_LOCK(&sched_mutex);
 696         shutdownHaskell();
 697         return;
 698 #endif
 699     }
 700   not_deadlocked:
 701
 702 #elif defined(PAR)
 703     /* ToDo: add deadlock detection in GUM (similar to SMP) -- HWL */
 704 #endif
 705
 706 #if defined(SMP)
 707     /* If there's a GC pending, don't do anything until it has
 708      * completed.
 709      */
 710     if (ready_to_gc) {
 711       IF_DEBUG(scheduler,sched_belch("waiting for GC"));
 712       waitCondition( &gc_pending_cond, &sched_mutex );
 713     }
 714 #endif
 715
 716 #if defined(RTS_SUPPORTS_THREADS)
 717     /* block until we've got a thread on the run queue and a free
 718      * capability.
 719      *
 720      */
 721     if ( EMPTY_RUN_QUEUE() ) {
 722       /* Give up our capability */
 723       releaseCapability(cap);
 724
 725       /* If we're in the process of shutting down (& running the
 726        * a batch of finalisers), don't wait around.
 727        */
 728       if ( shutting_down_scheduler ) {
 729         RELEASE_LOCK(&sched_mutex);
 730         return;
 731       }
 732       IF_DEBUG(scheduler, sched_belch("thread %d: waiting for work", osThreadId()));
 733       waitForWorkCapability(&sched_mutex, &cap, rtsTrue);
 734       IF_DEBUG(scheduler, sched_belch("thread %d: work now available", osThreadId()));
 735     }
 736 #endif
 737
 738 #if defined(GRAN)
 739     if (RtsFlags.GranFlags.Light)
 740       GranSimLight_enter_system(event, &ActiveTSO); // adjust ActiveTSO etc
 741
 742     /* adjust time based on time-stamp */
 743     if (event->time > CurrentTime[CurrentProc] &&
 744         event->evttype != ContinueThread)
 745       CurrentTime[CurrentProc] = event->time;
 746
 747     /* Deal with the idle PEs (may issue FindWork or MoveSpark events) */
 748     if (!RtsFlags.GranFlags.Light)
 749       handleIdlePEs();
 750
 751     IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"));
 752
 753     /* main event dispatcher in GranSim */
 754     switch (event->evttype) {
 755       /* Should just be continuing execution */
 756     case ContinueThread:
 757       IF_DEBUG(gran, fprintf(stderr, "GRAN: doing ContinueThread\n"));
 758       /* ToDo: check assertion
 759       ASSERT(run_queue_hd != (StgTSO*)NULL &&
 760              run_queue_hd != END_TSO_QUEUE);
 761       */
 762       /* Ignore ContinueThreads for fetching threads (if synchr comm) */
 763       if (!RtsFlags.GranFlags.DoAsyncFetch &&
 764           procStatus[CurrentProc]==Fetching) {
 765         belch("ghuH: Spurious ContinueThread while Fetching ignored; TSO %d (%p) [PE %d]",
 766               CurrentTSO->id, CurrentTSO, CurrentProc);
 767         goto next_thread;
 768       }
 769       /* Ignore ContinueThreads for completed threads */
 770       if (CurrentTSO->what_next == ThreadComplete) {
 771         belch("ghuH: found a ContinueThread event for completed thread %d (%p) [PE %d] (ignoring ContinueThread)",
 772               CurrentTSO->id, CurrentTSO, CurrentProc);
 773         goto next_thread;
 774       }
 775       /* Ignore ContinueThreads for threads that are being migrated */
 776       if (PROCS(CurrentTSO)==Nowhere) {
 777         belch("ghuH: trying to run the migrating TSO %d (%p) [PE %d] (ignoring ContinueThread)",
 778               CurrentTSO->id, CurrentTSO, CurrentProc);
 779         goto next_thread;
 780       }
 781       /* The thread should be at the beginning of the run queue */
 782       if (CurrentTSO!=run_queue_hds[CurrentProc]) {
 783         belch("ghuH: TSO %d (%p) [PE %d] is not at the start of the run_queue when doing a ContinueThread",
 784               CurrentTSO->id, CurrentTSO, CurrentProc);
 785         break; // run the thread anyway
 786       }
 787       /*
 788       new_event(proc, proc, CurrentTime[proc],
 789                 FindWork,
 790                 (StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
 791       goto next_thread;
 792       */ /* Catches superfluous CONTINUEs -- should be unnecessary */
 793       break; // now actually run the thread; DaH Qu'vam yImuHbej
 794
 795     case FetchNode:
 796       do_the_fetchnode(event);
 797       goto next_thread;             /* handle next event in event queue  */
 798
 799     case GlobalBlock:
 800       do_the_globalblock(event);
 801       goto next_thread;             /* handle next event in event queue  */
 802
 803     case FetchReply:
 804       do_the_fetchreply(event);
 805       goto next_thread;             /* handle next event in event queue  */
 806
 807     case UnblockThread:   /* Move from the blocked queue to the tail of */
 808       do_the_unblock(event);
 809       goto next_thread;             /* handle next event in event queue  */
 810
 811     case ResumeThread:  /* Move from the blocked queue to the tail of */
 812       /* the runnable queue ( i.e. Qu' SImqa'lu') */
 813       event->tso->gran.blocktime +=
 814         CurrentTime[CurrentProc] - event->tso->gran.blockedat;
 815       do_the_startthread(event);
 816       goto next_thread;             /* handle next event in event queue  */
 817
 818     case StartThread:
 819       do_the_startthread(event);
 820       goto next_thread;             /* handle next event in event queue  */
 821
 822     case MoveThread:
 823       do_the_movethread(event);
 824       goto next_thread;             /* handle next event in event queue  */
 825
 826     case MoveSpark:
 827       do_the_movespark(event);
 828       goto next_thread;             /* handle next event in event queue  */
 829
 830     case FindWork:
 831       do_the_findwork(event);
 832       goto next_thread;             /* handle next event in event queue  */
 833
 834     default:
 835       barf("Illegal event type %u\n", event->evttype);
 836     }  /* switch */
 837
 838     /* This point was scheduler_loop in the old RTS */
 839
 840     IF_DEBUG(gran, belch("GRAN: after main switch"));
 841
 842     TimeOfLastEvent = CurrentTime[CurrentProc];
 843     TimeOfNextEvent = get_time_of_next_event();
 844     IgnoreEvents=(TimeOfNextEvent==0); // HWL HACK
 845     // CurrentTSO = ThreadQueueHd;
 846
 847     IF_DEBUG(gran, belch("GRAN: time of next event is: %ld",
 848                          TimeOfNextEvent));
 849
 850     if (RtsFlags.GranFlags.Light)
 851       GranSimLight_leave_system(event, &ActiveTSO);
 852
 853     EndOfTimeSlice = CurrentTime[CurrentProc]+RtsFlags.GranFlags.time_slice;
 854
 855     IF_DEBUG(gran,
 856              belch("GRAN: end of time-slice is %#lx", EndOfTimeSlice));
 857
 858     /* in a GranSim setup the TSO stays on the run queue */
 859     t = CurrentTSO;
 860     /* Take a thread from the run queue. */
 861     t = POP_RUN_QUEUE(); // take_off_run_queue(t);
 862
 863     IF_DEBUG(gran,
 864              fprintf(stderr, "GRAN: About to run current thread, which is\n");
 865              G_TSO(t,5));
 866
 867     context_switch = 0; // turned on via GranYield, checking events and time slice
 868
 869     IF_DEBUG(gran,
 870              DumpGranEvent(GR_SCHEDULE, t));
 871
 872     procStatus[CurrentProc] = Busy;
 873
 874 #elif defined(PAR)
 875     if (PendingFetches != END_BF_QUEUE) {
 876         processFetches();
 877     }
 878
 879     /* ToDo: phps merge with spark activation above */
 880     /* check whether we have local work and send requests if we have none */
 881     if (EMPTY_RUN_QUEUE()) {  /* no runnable threads */
 882       /* :-[  no local threads => look out for local sparks */
 883       /* the spark pool for the current PE */
 884       pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
 885       if (advisory_thread_count < RtsFlags.ParFlags.maxThreads &&
 886           pool->hd < pool->tl) {
 887         /*
 888          * ToDo: add GC code check that we really have enough heap afterwards!!
 889          * Old comment:
 890          * If we're here (no runnable threads) and we have pending
 891          * sparks, we must have a space problem.  Get enough space
 892          * to turn one of those pending sparks into a
 893          * thread...
 894          */
 895
 896         spark = findSpark(rtsFalse);                /* get a spark */
 897         if (spark != (rtsSpark) NULL) {
 898           tso = activateSpark(spark);       /* turn the spark into a thread */
 899           IF_PAR_DEBUG(schedule,
 900                        belch("==== schedule: Created TSO %d (%p); %d threads active",
 901                              tso->id, tso, advisory_thread_count));
 902
 903           if (tso==END_TSO_QUEUE) { /* failed to activate spark->back to loop */
 904             belch("==^^ failed to activate spark");
 905             goto next_thread;
 906           }               /* otherwise fall through & pick-up new tso */
 907         } else {
 908           IF_PAR_DEBUG(verbose,
 909                        belch("==^^ no local sparks (spark pool contains only NFs: %d)",
 910                              spark_queue_len(pool)));
 911           goto next_thread;
 912         }
 913       }
 914
 915       /* If we still have no work we need to send a FISH to get a spark
 916          from another PE
 917       */
 918       if (EMPTY_RUN_QUEUE()) {
 919       /* =8-[  no local sparks => look for work on other PEs */
 920         /*
 921          * We really have absolutely no work.  Send out a fish
 922          * (there may be some out there already), and wait for
 923          * something to arrive.  We clearly can't run any threads
 924          * until a SCHEDULE or RESUME arrives, and so that's what
 925          * we're hoping to see.  (Of course, we still have to
 926          * respond to other types of messages.)
 927          */
 928         TIME now = msTime() /*CURRENT_TIME*/;
 929         IF_PAR_DEBUG(verbose,
 930                      belch("--  now=%ld", now));
 931         IF_PAR_DEBUG(verbose,
 932                      if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
 933                          (last_fish_arrived_at!=0 &&
 934                           last_fish_arrived_at+RtsFlags.ParFlags.fishDelay > now)) {
 935                        belch("--$$ delaying FISH until %ld (last fish %ld, delay %ld, now %ld)",
 936                              last_fish_arrived_at+RtsFlags.ParFlags.fishDelay,
 937                              last_fish_arrived_at,
 938                              RtsFlags.ParFlags.fishDelay, now);
 939                      });
 940
 941         if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
 942             (last_fish_arrived_at==0 ||
 943              (last_fish_arrived_at+RtsFlags.ParFlags.fishDelay <= now))) {
 944           /* outstandingFishes is set in sendFish, processFish;
 945              avoid flooding system with fishes via delay */
 946           pe = choosePE();
 947           sendFish(pe, mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
 948                    NEW_FISH_HUNGER);
 949
 950           // Global statistics: count no. of fishes
 951           if (RtsFlags.ParFlags.ParStats.Global &&
 952               RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
 953             globalParStats.tot_fish_mess++;
 954           }
 955         }
 956
 957         receivedFinish = processMessages();
 958         goto next_thread;
 959       }
 960     } else if (PacketsWaiting()) {  /* Look for incoming messages */
 961       receivedFinish = processMessages();
 962     }
 963
 964     /* Now we are sure that we have some work available */
 965     ASSERT(run_queue_hd != END_TSO_QUEUE);
 966
 967     /* Take a thread from the run queue, if we have work */
 968     t = POP_RUN_QUEUE();  // take_off_run_queue(END_TSO_QUEUE);
 969     IF_DEBUG(sanity,checkTSO(t));
 970
 971     /* ToDo: write something to the log-file
 972     if (RTSflags.ParFlags.granSimStats && !sameThread)
 973         DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
 974
 975     CurrentTSO = t;
 976     */
 977     /* the spark pool for the current PE */
 978     pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
 979
 980     IF_DEBUG(scheduler,
 981              belch("--=^ %d threads, %d sparks on [%#x]",
 982                    run_queue_len(), spark_queue_len(pool), CURRENT_PROC));
 983
 984 # if 1
 985     if (0 && RtsFlags.ParFlags.ParStats.Full &&
 986         t && LastTSO && t->id != LastTSO->id &&
 987         LastTSO->why_blocked == NotBlocked &&
 988         LastTSO->what_next != ThreadComplete) {
 989       // if previously scheduled TSO not blocked we have to record the context switch
 990       DumpVeryRawGranEvent(TimeOfLastYield, CURRENT_PROC, CURRENT_PROC,
 991                            GR_DESCHEDULE, LastTSO, (StgClosure *)NULL, 0, 0);
 992     }
 993
 994     if (RtsFlags.ParFlags.ParStats.Full &&
 995         (emitSchedule /* forced emit */ ||
 996         (t && LastTSO && t->id != LastTSO->id))) {
 997       /*
 998          we are running a different TSO, so write a schedule event to log file
 999          NB: If we use fair scheduling we also have to write  a deschedule
1000              event for LastTSO; with unfair scheduling we know that the
1001              previous tso has blocked whenever we switch to another tso, so
1002              we don't need it in GUM for now
1003       */
1004       DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
1005                        GR_SCHEDULE, t, (StgClosure *)NULL, 0, 0);
1006       emitSchedule = rtsFalse;
1007     }
1008
1009 # endif
1010 #else /* !GRAN && !PAR */
1011
1012     /* grab a thread from the run queue */
1013     ASSERT(run_queue_hd != END_TSO_QUEUE);
1014     t = POP_RUN_QUEUE();
1015     // Sanity check the thread we're about to run.  This can be
1016     // expensive if there is lots of thread switching going on...
1017     IF_DEBUG(sanity,checkTSO(t));
1018 #endif
1019
1020     cap->r.rCurrentTSO = t;
1021
1022     /* context switches are now initiated by the timer signal, unless
1023      * the user specified "context switch as often as possible", with
1024      * +RTS -C0
1025      */
1026     if ((RtsFlags.ConcFlags.ctxtSwitchTicks == 0
1027          && (run_queue_hd != END_TSO_QUEUE
1028              || blocked_queue_hd != END_TSO_QUEUE
1029              || sleeping_queue != END_TSO_QUEUE)))
1030         context_switch = 1;
1031     else
1032         context_switch = 0;
1033
1034     RELEASE_LOCK(&sched_mutex);
1035
1036     IF_DEBUG(scheduler, sched_belch("-->> running thread %ld %s ...",
1037                               t->id, whatNext_strs[t->what_next]));
1038
1039 #ifdef PROFILING
1040     startHeapProfTimer();
1041 #endif
1042
1043     /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
1044     /* Run the current thread
1045      */
1046     prev_what_next = t->what_next;
1047     switch (prev_what_next) {
1048     case ThreadKilled:
1049     case ThreadComplete:
1050         /* Thread already finished, return to scheduler. */
1051         ret = ThreadFinished;
1052         break;
1053     case ThreadRunGHC:
1054         ret = StgRun((StgFunPtr) stg_returnToStackTop, &cap->r);
1055         break;
1056     case ThreadInterpret:
1057         ret = interpretBCO(cap);
1058         break;
1059     default:
1060       barf("schedule: invalid what_next field");
1061     }
1062     /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
1063
1064     /* Costs for the scheduler are assigned to CCS_SYSTEM */
1065 #ifdef PROFILING
1066     stopHeapProfTimer();
1067     CCCS = CCS_SYSTEM;
1068 #endif
1069
1070     ACQUIRE_LOCK(&sched_mutex);
1071
1072 #ifdef SMP
1073     IF_DEBUG(scheduler,fprintf(stderr,"scheduler (task %ld): ", osThreadId()););
1074 #elif !defined(GRAN) && !defined(PAR)
1075     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: "););
1076 #endif
1077     t = cap->r.rCurrentTSO;
1078
1079 #if defined(PAR)
1080     /* HACK 675: if the last thread didn't yield, make sure to print a
1081        SCHEDULE event to the log file when StgRunning the next thread, even
1082        if it is the same one as before */
1083     LastTSO = t;
1084     TimeOfLastYield = CURRENT_TIME;
1085 #endif
1086
1087     switch (ret) {
1088     case HeapOverflow:
1089 #if defined(GRAN)
1090       IF_DEBUG(gran, DumpGranEvent(GR_DESCHEDULE, t));
1091       globalGranStats.tot_heapover++;
1092 #elif defined(PAR)
1093       globalParStats.tot_heapover++;
1094 #endif
1095
1096       // did the task ask for a large block?
1097       if (cap->r.rHpAlloc > BLOCK_SIZE_W) {
1098           // if so, get one and push it on the front of the nursery.
1099           bdescr *bd;
1100           nat blocks;
1101
1102           blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc * sizeof(W_)) / BLOCK_SIZE;
1103
1104           IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: requesting a large block (size %d)",
1105                                    t->id, whatNext_strs[t->what_next], blocks));
1106
1107           // don't do this if it would push us over the
1108           // alloc_blocks_lim limit; we'll GC first.
1109           if (alloc_blocks + blocks < alloc_blocks_lim) {
1110
1111               alloc_blocks += blocks;
1112               bd = allocGroup( blocks );
1113
1114               // link the new group into the list
1115               bd->link = cap->r.rCurrentNursery;
1116               bd->u.back = cap->r.rCurrentNursery->u.back;
1117               if (cap->r.rCurrentNursery->u.back != NULL) {
1118                   cap->r.rCurrentNursery->u.back->link = bd;
1119               } else {
1120                   ASSERT(g0s0->blocks == cap->r.rCurrentNursery &&
1121                          g0s0->blocks == cap->r.rNursery);
1122                   cap->r.rNursery = g0s0->blocks = bd;
1123               }
1124               cap->r.rCurrentNursery->u.back = bd;
1125
1126               // initialise it as a nursery block.  We initialise the
1127               // step, gen_no, and flags field of *every* sub-block in
1128               // this large block, because this is easier than making
1129               // sure that we always find the block head of a large
1130               // block whenever we call Bdescr() (eg. evacuate() and
1131               // isAlive() in the GC would both have to do this, at
1132               // least).
1133               {
1134                   bdescr *x;
1135                   for (x = bd; x < bd + blocks; x++) {
1136                       x->step = g0s0;
1137                       x->gen_no = 0;
1138                       x->flags = 0;
1139                   }
1140               }
1141
1142               // don't forget to update the block count in g0s0.
1143               g0s0->n_blocks += blocks;
1144               // This assert can be a killer if the app is doing lots
1145               // of large block allocations.
1146               ASSERT(countBlocks(g0s0->blocks) == g0s0->n_blocks);
1147
1148               // now update the nursery to point to the new block
1149               cap->r.rCurrentNursery = bd;
1150
1151               // we might be unlucky and have another thread get on the
1152               // run queue before us and steal the large block, but in that
1153               // case the thread will just end up requesting another large
1154               // block.
1155               PUSH_ON_RUN_QUEUE(t);
1156               break;
1157           }
1158       }
1159
1160       /* make all the running tasks block on a condition variable,
1161        * maybe set context_switch and wait till they all pile in,
1162        * then have them wait on a GC condition variable.
1163        */
1164       IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: HeapOverflow",
1165                                t->id, whatNext_strs[t->what_next]));
1166       threadPaused(t);
1167 #if defined(GRAN)
1168       ASSERT(!is_on_queue(t,CurrentProc));
1169 #elif defined(PAR)
1170       /* Currently we emit a DESCHEDULE event before GC in GUM.
1171          ToDo: either add separate event to distinguish SYSTEM time from rest
1172                or just nuke this DESCHEDULE (and the following SCHEDULE) */
1173       if (0 && RtsFlags.ParFlags.ParStats.Full) {
1174         DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
1175                          GR_DESCHEDULE, t, (StgClosure *)NULL, 0, 0);
1176         emitSchedule = rtsTrue;
1177       }
1178 #endif
1179
1180       ready_to_gc = rtsTrue;
1181       context_switch = 1;               /* stop other threads ASAP */
1182       PUSH_ON_RUN_QUEUE(t);
1183       /* actual GC is done at the end of the while loop */
1184       break;
1185
1186     case StackOverflow:
1187 #if defined(GRAN)
1188       IF_DEBUG(gran,
1189                DumpGranEvent(GR_DESCHEDULE, t));
1190       globalGranStats.tot_stackover++;
1191 #elif defined(PAR)
1192       // IF_DEBUG(par,
1193       // DumpGranEvent(GR_DESCHEDULE, t);
1194       globalParStats.tot_stackover++;
1195 #endif
1196       IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped, StackOverflow",
1197                                t->id, whatNext_strs[t->what_next]));
1198       /* just adjust the stack for this thread, then pop it back
1199        * on the run queue.
1200        */
1201       threadPaused(t);
1202       {
1203         StgMainThread *m;
1204         /* enlarge the stack */
1205         StgTSO *new_t = threadStackOverflow(t);
1206
1207         /* This TSO has moved, so update any pointers to it from the
1208          * main thread stack.  It better not be on any other queues...
1209          * (it shouldn't be).
1210          */
1211         for (m = main_threads; m != NULL; m = m->link) {
1212           if (m->tso == t) {
1213             m->tso = new_t;
1214           }
1215         }
1216         threadPaused(new_t);
1217         PUSH_ON_RUN_QUEUE(new_t);
1218       }
1219       break;
1220
1221     case ThreadYielding:
1222 #if defined(GRAN)
1223       IF_DEBUG(gran,
1224                DumpGranEvent(GR_DESCHEDULE, t));
1225       globalGranStats.tot_yields++;
1226 #elif defined(PAR)
1227       // IF_DEBUG(par,
1228       // DumpGranEvent(GR_DESCHEDULE, t);
1229       globalParStats.tot_yields++;
1230 #endif
1231       /* put the thread back on the run queue.  Then, if we're ready to
1232        * GC, check whether this is the last task to stop.  If so, wake
1233        * up the GC thread.  getThread will block during a GC until the
1234        * GC is finished.
1235        */
1236       IF_DEBUG(scheduler,
1237                if (t->what_next != prev_what_next) {
1238                    /* ToDo: or maybe a timer expired when we were in Hugs?
1239                     * or maybe someone hit ctrl-C
1240                     */
1241                    belch("--<< thread %ld (%s) stopped to switch evaluators",
1242                          t->id, whatNext_strs[t->what_next]);
1243                } else {
1244                    belch("--<< thread %ld (%s) stopped, yielding",
1245                          t->id, whatNext_strs[t->what_next]);
1246                }
1247                );
1248
1249       threadPaused(t);
1250
1251       IF_DEBUG(sanity,
1252                //belch("&& Doing sanity check on yielding TSO %ld.", t->id);
1253                checkTSO(t));
1254       ASSERT(t->link == END_TSO_QUEUE);
1255 #if defined(GRAN)
1256       ASSERT(!is_on_queue(t,CurrentProc));
1257
1258       IF_DEBUG(sanity,
1259                //belch("&& Doing sanity check on all ThreadQueues (and their TSOs).");
1260                checkThreadQsSanity(rtsTrue));
1261 #endif
1262 #if defined(PAR)
1263       if (RtsFlags.ParFlags.doFairScheduling) {
1264         /* this does round-robin scheduling; good for concurrency */
1265         APPEND_TO_RUN_QUEUE(t);
1266       } else {
1267         /* this does unfair scheduling; good for parallelism */
1268         PUSH_ON_RUN_QUEUE(t);
1269       }
1270 #else
1271       if (t->what_next != prev_what_next) {
1272           // switching evaluators; don't context-switch
1273           PUSH_ON_RUN_QUEUE(t);
1274       } else {
1275           // this does round-robin scheduling; good for concurrency
1276           APPEND_TO_RUN_QUEUE(t);
1277       }
1278 #endif
1279 #if defined(GRAN)
1280       /* add a ContinueThread event to actually process the thread */
1281       new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
1282                 ContinueThread,
1283                 t, (StgClosure*)NULL, (rtsSpark*)NULL);
1284       IF_GRAN_DEBUG(bq,
1285                belch("GRAN: eventq and runnableq after adding yielded thread to queue again:");
1286                G_EVENTQ(0);
1287                G_CURR_THREADQ(0));
1288 #endif /* GRAN */
1289       break;
1290
1291     case ThreadBlocked:
1292 #if defined(GRAN)
1293       IF_DEBUG(scheduler,
1294                belch("--<< thread %ld (%p; %s) stopped, blocking on node %p [PE %d] with BQ: ",
1295                                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)));
1296                if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
1297
1298       // ??? needed; should emit block before
1299       IF_DEBUG(gran,
1300                DumpGranEvent(GR_DESCHEDULE, t));
1301       prune_eventq(t, (StgClosure *)NULL); // prune ContinueThreads for t
1302       /*
1303         ngoq Dogh!
1304       ASSERT(procStatus[CurrentProc]==Busy ||
1305               ((procStatus[CurrentProc]==Fetching) &&
1306               (t->block_info.closure!=(StgClosure*)NULL)));
1307       if (run_queue_hds[CurrentProc] == END_TSO_QUEUE &&
1308           !(!RtsFlags.GranFlags.DoAsyncFetch &&
1309             procStatus[CurrentProc]==Fetching))
1310         procStatus[CurrentProc] = Idle;
1311       */
1312 #elif defined(PAR)
1313       IF_DEBUG(scheduler,
1314                belch("--<< thread %ld (%p; %s) stopped, blocking on node %p with BQ: ",
1315                      t->id, t, whatNext_strs[t->what_next], t->block_info.closure));
1316       IF_PAR_DEBUG(bq,
1317
1318                    if (t->block_info.closure!=(StgClosure*)NULL)
1319                      print_bq(t->block_info.closure));
1320
1321       /* Send a fetch (if BlockedOnGA) and dump event to log file */
1322       blockThread(t);
1323
1324       /* whatever we schedule next, we must log that schedule */
1325       emitSchedule = rtsTrue;
1326
1327 #else /* !GRAN */
1328       /* don't need to do anything.  Either the thread is blocked on
1329        * I/O, in which case we'll have called addToBlockedQueue
1330        * previously, or it's blocked on an MVar or Blackhole, in which
1331        * case it'll be on the relevant queue already.
1332        */
1333       IF_DEBUG(scheduler,
1334                fprintf(stderr, "--<< thread %d (%s) stopped: ",
1335                        t->id, whatNext_strs[t->what_next]);
1336                printThreadBlockage(t);
1337                fprintf(stderr, "\n"));
1338
1339       /* Only for dumping event to log file
1340          ToDo: do I need this in GranSim, too?
1341       blockThread(t);
1342       */
1343 #endif
1344       threadPaused(t);
1345       break;
1346
1347     case ThreadFinished:
1348       /* Need to check whether this was a main thread, and if so, signal
1349        * the task that started it with the return value.  If we have no
1350        * more main threads, we probably need to stop all the tasks until
1351        * we get a new one.
1352        */
1353       /* We also end up here if the thread kills itself with an
1354        * uncaught exception, see Exception.hc.
1355        */
1356       IF_DEBUG(scheduler,belch("--++ thread %d (%s) finished",
1357                                t->id, whatNext_strs[t->what_next]));
1358 #if defined(GRAN)
1359       endThread(t, CurrentProc); // clean-up the thread
1360 #elif defined(PAR)
1361       /* For now all are advisory -- HWL */
1362       //if(t->priority==AdvisoryPriority) ??
1363       advisory_thread_count--;
1364
1365 # ifdef DIST
1366       if(t->dist.priority==RevalPriority)
1367         FinishReval(t);
1368 # endif
1369
1370       if (RtsFlags.ParFlags.ParStats.Full &&
1371           !RtsFlags.ParFlags.ParStats.Suppressed)
1372         DumpEndEvent(CURRENT_PROC, t, rtsFalse /* not mandatory */);
1373 #endif
1374       break;
1375
1376     default:
1377       barf("schedule: invalid thread return code %d", (int)ret);
1378     }
1379
1380 #ifdef PROFILING
1381     // When we have +RTS -i0 and we're heap profiling, do a census at
1382     // every GC.  This lets us get repeatable runs for debugging.
1383     if (performHeapProfile ||
1384         (RtsFlags.ProfFlags.profileInterval==0 &&
1385          RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) {
1386         GarbageCollect(GetRoots, rtsTrue);
1387         heapCensus();
1388         performHeapProfile = rtsFalse;
1389         ready_to_gc = rtsFalse; // we already GC'd
1390     }
1391 #endif
1392
1393     if (ready_to_gc
1394 #ifdef SMP
1395         && allFreeCapabilities()
1396 #endif
1397         ) {
1398       /* everybody back, start the GC.
1399        * Could do it in this thread, or signal a condition var
1400        * to do it in another thread.  Either way, we need to
1401        * broadcast on gc_pending_cond afterward.
1402        */
1403 #if defined(RTS_SUPPORTS_THREADS)
1404       IF_DEBUG(scheduler,sched_belch("doing GC"));
1405 #endif
1406       GarbageCollect(GetRoots,rtsFalse);
1407       ready_to_gc = rtsFalse;
1408 #ifdef SMP
1409       broadcastCondition(&gc_pending_cond);
1410 #endif
1411 #if defined(GRAN)
1412       /* add a ContinueThread event to continue execution of current thread */
1413       new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
1414                 ContinueThread,
1415                 t, (StgClosure*)NULL, (rtsSpark*)NULL);
1416       IF_GRAN_DEBUG(bq,
1417                fprintf(stderr, "GRAN: eventq and runnableq after Garbage collection:\n");
1418                G_EVENTQ(0);
1419                G_CURR_THREADQ(0));
1420 #endif /* GRAN */
1421     }
1422
1423 #if defined(GRAN)
1424   next_thread:
1425     IF_GRAN_DEBUG(unused,
1426                   print_eventq(EventHd));
1427
1428     event = get_next_event();
1429 #elif defined(PAR)
1430   next_thread:
1431     /* ToDo: wait for next message to arrive rather than busy wait */
1432 #endif /* GRAN */
1433
1434   } /* end of while(1) */
1435
1436   IF_PAR_DEBUG(verbose,
1437                belch("== Leaving schedule() after having received Finish"));
1438 }
1439
1440 /* ---------------------------------------------------------------------------
1441  * Singleton fork(). Do not copy any running threads.
1442  * ------------------------------------------------------------------------- */
1443
1444 StgInt forkProcess(StgTSO* tso) {
1445
1446 #ifndef mingw32_TARGET_OS
1447   pid_t pid;
1448   StgTSO* t,*next;
1449   StgMainThread *m;
1450   rtsBool doKill;
1451
1452   IF_DEBUG(scheduler,sched_belch("forking!"));
1453
1454   pid = fork();
1455   if (pid) { /* parent */
1456
1457   /* just return the pid */
1458
1459   } else { /* child */
1460   /* wipe all other threads */
1461   run_queue_hd = run_queue_tl = tso;
1462   tso->link = END_TSO_QUEUE;
1463
1464   /* When clearing out the threads, we need to ensure
1465      that a 'main thread' is left behind; if there isn't,
1466      the Scheduler will shutdown next time it is entered.
1467
1468      ==> we don't kill a thread that's on the main_threads
1469          list (nor the current thread.)
1470
1471      [ Attempts at implementing the more ambitious scheme of
1472        killing the main_threads also, and then adding the
1473        current thread onto the main_threads list if it wasn't
1474        there already, failed -- waitThread() (for one) wasn't
1475        up to it. If it proves to be desirable to also kill
1476        the main threads, then this scheme will have to be
1477        revisited (and fully debugged!)
1478
1479        -- sof 7/2002
1480      ]
1481   */
1482   /* DO NOT TOUCH THE QUEUES directly because most of the code around
1483      us is picky about finding the thread still in its queue when
1484      handling the deleteThread() */
1485
1486   for (t = all_threads; t != END_TSO_QUEUE; t = next) {
1487     next = t->link;
1488
1489     /* Don't kill the current thread.. */
1490     if (t->id == tso->id) continue;
1491     doKill=rtsTrue;
1492     /* ..or a main thread */
1493     for (m = main_threads; m != NULL; m = m->link) {
1494         if (m->tso->id == t->id) {
1495           doKill=rtsFalse;
1496           break;
1497         }
1498     }
1499     if (doKill) {
1500       deleteThread(t);
1501     }
1502   }
1503   }
1504   return pid;
1505 #else /* mingw32 */
1506   barf("forkProcess#: primop not implemented for mingw32, sorry! (%u)\n", tso->id);
1507   /* pointlessly printing out the TSOs 'id' to avoid CC unused warning. */
1508   return -1;
1509 #endif /* mingw32 */
1510 }
1511
1512 /* ---------------------------------------------------------------------------
1513  * deleteAllThreads():  kill all the live threads.
1514  *
1515  * This is used when we catch a user interrupt (^C), before performing
1516  * any necessary cleanups and running finalizers.
1517  *
1518  * Locks: sched_mutex held.
1519  * ------------------------------------------------------------------------- */
1520
1521 void deleteAllThreads ( void )
1522 {
1523   StgTSO* t, *next;
1524   IF_DEBUG(scheduler,sched_belch("deleting all threads"));
1525   for (t = all_threads; t != END_TSO_QUEUE; t = next) {
1526       next = t->global_link;
1527       deleteThread(t);
1528   }
1529   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
1530   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
1531   sleeping_queue = END_TSO_QUEUE;
1532 }
1533
1534 /* startThread and  insertThread are now in GranSim.c -- HWL */
1535
1536
1537 //@node Suspend and Resume, Run queue code, Main scheduling loop, Main scheduling code
1538 //@subsection Suspend and Resume
1539
1540 /* ---------------------------------------------------------------------------
1541  * Suspending & resuming Haskell threads.
1542  *
1543  * When making a "safe" call to C (aka _ccall_GC), the task gives back
1544  * its capability before calling the C function.  This allows another
1545  * task to pick up the capability and carry on running Haskell
1546  * threads.  It also means that if the C call blocks, it won't lock
1547  * the whole system.
1548  *
1549  * The Haskell thread making the C call is put to sleep for the
1550  * duration of the call, on the susepended_ccalling_threads queue.  We
1551  * give out a token to the task, which it can use to resume the thread
1552  * on return from the C function.
1553  * ------------------------------------------------------------------------- */
1554
1555 StgInt
1556 suspendThread( StgRegTable *reg,
1557                rtsBool concCall
1558 #if !defined(RTS_SUPPORTS_THREADS) && !defined(DEBUG)
1559                STG_UNUSED
1560 #endif
1561                )
1562 {
1563   nat tok;
1564   Capability *cap;
1565
1566   /* assume that *reg is a pointer to the StgRegTable part
1567    * of a Capability.
1568    */
1569   cap = (Capability *)((void *)reg - sizeof(StgFunTable));
1570
1571   ACQUIRE_LOCK(&sched_mutex);
1572
1573   IF_DEBUG(scheduler,
1574            sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
1575
1576   // XXX this might not be necessary --SDM
1577   cap->r.rCurrentTSO->what_next = ThreadRunGHC;
1578
1579   threadPaused(cap->r.rCurrentTSO);
1580   cap->r.rCurrentTSO->link = suspended_ccalling_threads;
1581   suspended_ccalling_threads = cap->r.rCurrentTSO;
1582
1583 #if defined(RTS_SUPPORTS_THREADS)
1584   cap->r.rCurrentTSO->why_blocked  = BlockedOnCCall;
1585 #endif
1586
1587   /* Use the thread ID as the token; it should be unique */
1588   tok = cap->r.rCurrentTSO->id;
1589
1590   /* Hand back capability */
1591   releaseCapability(cap);
1592
1593 #if defined(RTS_SUPPORTS_THREADS)
1594   /* Preparing to leave the RTS, so ensure there's a native thread/task
1595      waiting to take over.
1596
1597      ToDo: optimise this and only create a new task if there's a need
1598      for one (i.e., if there's only one Concurrent Haskell thread alive,
1599      there's no need to create a new task).
1600   */
1601   IF_DEBUG(scheduler, sched_belch("worker thread (%d): leaving RTS", tok));
1602   if (concCall) {
1603     startTask(taskStart);
1604   }
1605 #endif
1606
1607   /* Other threads _might_ be available for execution; signal this */
1608   THREAD_RUNNABLE();
1609   RELEASE_LOCK(&sched_mutex);
1610   return tok;
1611 }
1612
1613 StgRegTable *
1614 resumeThread( StgInt tok,
1615               rtsBool concCall
1616 #if !defined(RTS_SUPPORTS_THREADS)
1617                STG_UNUSED
1618 #endif
1619               )
1620 {
1621   StgTSO *tso, **prev;
1622   Capability *cap;
1623
1624 #if defined(RTS_SUPPORTS_THREADS)
1625   /* Wait for permission to re-enter the RTS with the result. */
1626   if ( concCall ) {
1627     ACQUIRE_LOCK(&sched_mutex);
1628     grabReturnCapability(&sched_mutex, &cap);
1629   } else {
1630     grabCapability(&cap);
1631   }
1632 #else
1633   grabCapability(&cap);
1634 #endif
1635
1636   /* Remove the thread off of the suspended list */
1637   prev = &suspended_ccalling_threads;
1638   for (tso = suspended_ccalling_threads;
1639        tso != END_TSO_QUEUE;
1640        prev = &tso->link, tso = tso->link) {
1641     if (tso->id == (StgThreadID)tok) {
1642       *prev = tso->link;
1643       break;
1644     }
1645   }
1646   if (tso == END_TSO_QUEUE) {
1647     barf("resumeThread: thread not found");
1648   }
1649   tso->link = END_TSO_QUEUE;
1650   /* Reset blocking status */
1651   tso->why_blocked  = NotBlocked;
1652
1653   cap->r.rCurrentTSO = tso;
1654   RELEASE_LOCK(&sched_mutex);
1655   return &cap->r;
1656 }
1657
1658
1659 /* ---------------------------------------------------------------------------
1660  * Static functions
1661  * ------------------------------------------------------------------------ */
1662 static void unblockThread(StgTSO *tso);
1663
1664 /* ---------------------------------------------------------------------------
1665  * Comparing Thread ids.
1666  *
1667  * This is used from STG land in the implementation of the
1668  * instances of Eq/Ord for ThreadIds.
1669  * ------------------------------------------------------------------------ */
1670
1671 int
1672 cmp_thread(StgPtr tso1, StgPtr tso2)
1673 {
1674   StgThreadID id1 = ((StgTSO *)tso1)->id;
1675   StgThreadID id2 = ((StgTSO *)tso2)->id;
1676
1677   if (id1 < id2) return (-1);
1678   if (id1 > id2) return 1;
1679   return 0;
1680 }
1681
1682 /* ---------------------------------------------------------------------------
1683  * Fetching the ThreadID from an StgTSO.
1684  *
1685  * This is used in the implementation of Show for ThreadIds.
1686  * ------------------------------------------------------------------------ */
1687 int
1688 rts_getThreadId(StgPtr tso)
1689 {
1690   return ((StgTSO *)tso)->id;
1691 }
1692
1693 #ifdef DEBUG
1694 void
1695 labelThread(StgPtr tso, char *label)
1696 {
1697   int len;
1698   void *buf;
1699
1700   /* Caveat: Once set, you can only set the thread name to "" */
1701   len = strlen(label)+1;
1702   buf = malloc(len);
1703   if (buf == NULL) {
1704     fprintf(stderr,"insufficient memory for labelThread!\n");
1705   } else
1706     strncpy(buf,label,len);
1707   /* Update will free the old memory for us */
1708   updateThreadLabel((StgWord)tso,buf);
1709 }
1710 #endif /* DEBUG */
1711
1712 /* ---------------------------------------------------------------------------
1713    Create a new thread.
1714
1715    The new thread starts with the given stack size.  Before the
1716    scheduler can run, however, this thread needs to have a closure
1717    (and possibly some arguments) pushed on its stack.  See
1718    pushClosure() in Schedule.h.
1719
1720    createGenThread() and createIOThread() (in SchedAPI.h) are
1721    convenient packaged versions of this function.
1722
1723    currently pri (priority) is only used in a GRAN setup -- HWL
1724    ------------------------------------------------------------------------ */
1725 //@cindex createThread
1726 #if defined(GRAN)
1727 /*   currently pri (priority) is only used in a GRAN setup -- HWL */
1728 StgTSO *
1729 createThread(nat size, StgInt pri)
1730 #else
1731 StgTSO *
1732 createThread(nat size)
1733 #endif
1734 {
1735
1736     StgTSO *tso;
1737     nat stack_size;
1738
1739     /* First check whether we should create a thread at all */
1740 #if defined(PAR)
1741   /* check that no more than RtsFlags.ParFlags.maxThreads threads are created */
1742   if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads) {
1743     threadsIgnored++;
1744     belch("{createThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
1745           RtsFlags.ParFlags.maxThreads, advisory_thread_count);
1746     return END_TSO_QUEUE;
1747   }
1748   threadsCreated++;
1749 #endif
1750
1751 #if defined(GRAN)
1752   ASSERT(!RtsFlags.GranFlags.Light || CurrentProc==0);
1753 #endif
1754
1755   // ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW
1756
1757   /* catch ridiculously small stack sizes */
1758   if (size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
1759     size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
1760   }
1761
1762   stack_size = size - TSO_STRUCT_SIZEW;
1763
1764   tso = (StgTSO *)allocate(size);
1765   TICK_ALLOC_TSO(stack_size, 0);
1766
1767   SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
1768 #if defined(GRAN)
1769   SET_GRAN_HDR(tso, ThisPE);
1770 #endif
1771
1772   // Always start with the compiled code evaluator
1773   tso->what_next = ThreadRunGHC;
1774
1775   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
1776    * protect the increment operation on next_thread_id.
1777    * In future, we could use an atomic increment instead.
1778    */
1779   ACQUIRE_LOCK(&thread_id_mutex);
1780   tso->id = next_thread_id++;
1781   RELEASE_LOCK(&thread_id_mutex);
1782
1783   tso->why_blocked  = NotBlocked;
1784   tso->blocked_exceptions = NULL;
1785
1786   tso->stack_size   = stack_size;
1787   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
1788                               - TSO_STRUCT_SIZEW;
1789   tso->sp           = (P_)&(tso->stack) + stack_size;
1790
1791 #ifdef PROFILING
1792   tso->prof.CCCS = CCS_MAIN;
1793 #endif
1794
1795   /* put a stop frame on the stack */
1796   tso->sp -= sizeofW(StgStopFrame);
1797   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
1798   // ToDo: check this
1799 #if defined(GRAN)
1800   tso->link = END_TSO_QUEUE;
1801   /* uses more flexible routine in GranSim */
1802   insertThread(tso, CurrentProc);
1803 #else
1804   /* In a non-GranSim setup the pushing of a TSO onto the runq is separated
1805    * from its creation
1806    */
1807 #endif
1808
1809 #if defined(GRAN)
1810   if (RtsFlags.GranFlags.GranSimStats.Full)
1811     DumpGranEvent(GR_START,tso);
1812 #elif defined(PAR)
1813   if (RtsFlags.ParFlags.ParStats.Full)
1814     DumpGranEvent(GR_STARTQ,tso);
1815   /* HACk to avoid SCHEDULE
1816      LastTSO = tso; */
1817 #endif
1818
1819   /* Link the new thread on the global thread list.
1820    */
1821   tso->global_link = all_threads;
1822   all_threads = tso;
1823
1824 #if defined(DIST)
1825   tso->dist.priority = MandatoryPriority; //by default that is...
1826 #endif
1827
1828 #if defined(GRAN)
1829   tso->gran.pri = pri;
1830 # if defined(DEBUG)
1831   tso->gran.magic = TSO_MAGIC; // debugging only
1832 # endif
1833   tso->gran.sparkname   = 0;
1834   tso->gran.startedat   = CURRENT_TIME;
1835   tso->gran.exported    = 0;
1836   tso->gran.basicblocks = 0;
1837   tso->gran.allocs      = 0;
1838   tso->gran.exectime    = 0;
1839   tso->gran.fetchtime   = 0;
1840   tso->gran.fetchcount  = 0;
1841   tso->gran.blocktime   = 0;
1842   tso->gran.blockcount  = 0;
1843   tso->gran.blockedat   = 0;
1844   tso->gran.globalsparks = 0;
1845   tso->gran.localsparks  = 0;
1846   if (RtsFlags.GranFlags.Light)
1847     tso->gran.clock  = Now; /* local clock */
1848   else
1849     tso->gran.clock  = 0;
1850
1851   IF_DEBUG(gran,printTSO(tso));
1852 #elif defined(PAR)
1853 # if defined(DEBUG)
1854   tso->par.magic = TSO_MAGIC; // debugging only
1855 # endif
1856   tso->par.sparkname   = 0;
1857   tso->par.startedat   = CURRENT_TIME;
1858   tso->par.exported    = 0;
1859   tso->par.basicblocks = 0;
1860   tso->par.allocs      = 0;
1861   tso->par.exectime    = 0;
1862   tso->par.fetchtime   = 0;
1863   tso->par.fetchcount  = 0;
1864   tso->par.blocktime   = 0;
1865   tso->par.blockcount  = 0;
1866   tso->par.blockedat   = 0;
1867   tso->par.globalsparks = 0;
1868   tso->par.localsparks  = 0;
1869 #endif
1870
1871 #if defined(GRAN)
1872   globalGranStats.tot_threads_created++;
1873   globalGranStats.threads_created_on_PE[CurrentProc]++;
1874   globalGranStats.tot_sq_len += spark_queue_len(CurrentProc);
1875   globalGranStats.tot_sq_probes++;
1876 #elif defined(PAR)
1877   // collect parallel global statistics (currently done together with GC stats)
1878   if (RtsFlags.ParFlags.ParStats.Global &&
1879       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
1880     //fprintf(stderr, "Creating thread %d @ %11.2f\n", tso->id, usertime());
1881     globalParStats.tot_threads_created++;
1882   }
1883 #endif
1884
1885 #if defined(GRAN)
1886   IF_GRAN_DEBUG(pri,
1887                 belch("==__ schedule: Created TSO %d (%p);",
1888                       CurrentProc, tso, tso->id));
1889 #elif defined(PAR)
1890     IF_PAR_DEBUG(verbose,
1891                  belch("==__ schedule: Created TSO %d (%p); %d threads active",
1892                        tso->id, tso, advisory_thread_count));
1893 #else
1894   IF_DEBUG(scheduler,sched_belch("created thread %ld, stack size = %lx words",
1895                                  tso->id, tso->stack_size));
1896 #endif
1897   return tso;
1898 }
1899
1900 #if defined(PAR)
1901 /* RFP:
1902    all parallel thread creation calls should fall through the following routine.
1903 */
1904 StgTSO *
1905 createSparkThread(rtsSpark spark)
1906 { StgTSO *tso;
1907   ASSERT(spark != (rtsSpark)NULL);
1908   if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads)
1909   { threadsIgnored++;
1910     barf("{createSparkThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
1911           RtsFlags.ParFlags.maxThreads, advisory_thread_count);
1912     return END_TSO_QUEUE;
1913   }
1914   else
1915   { threadsCreated++;
1916     tso = createThread(RtsFlags.GcFlags.initialStkSize);
1917     if (tso==END_TSO_QUEUE)
1918       barf("createSparkThread: Cannot create TSO");
1919 #if defined(DIST)
1920     tso->priority = AdvisoryPriority;
1921 #endif
1922     pushClosure(tso,spark);
1923     PUSH_ON_RUN_QUEUE(tso);
1924     advisory_thread_count++;
1925   }
1926   return tso;
1927 }
1928 #endif
1929
1930 /*
1931   Turn a spark into a thread.
1932   ToDo: fix for SMP (needs to acquire SCHED_MUTEX!)
1933 */
1934 #if defined(PAR)
1935 //@cindex activateSpark
1936 StgTSO *
1937 activateSpark (rtsSpark spark)
1938 {
1939   StgTSO *tso;
1940
1941   tso = createSparkThread(spark);
1942   if (RtsFlags.ParFlags.ParStats.Full) {
1943     //ASSERT(run_queue_hd == END_TSO_QUEUE); // I think ...
1944     IF_PAR_DEBUG(verbose,
1945                  belch("==^^ activateSpark: turning spark of closure %p (%s) into a thread",
1946                        (StgClosure *)spark, info_type((StgClosure *)spark)));
1947   }
1948   // ToDo: fwd info on local/global spark to thread -- HWL
1949   // tso->gran.exported =  spark->exported;
1950   // tso->gran.locked =   !spark->global;
1951   // tso->gran.sparkname = spark->name;
1952
1953   return tso;
1954 }
1955 #endif
1956
1957 static SchedulerStatus waitThread_(/*out*/StgMainThread* m
1958 #if defined(THREADED_RTS)
1959                                    , rtsBool blockWaiting
1960 #endif
1961                                    );
1962
1963
1964 /* ---------------------------------------------------------------------------
1965  * scheduleThread()
1966  *
1967  * scheduleThread puts a thread on the head of the runnable queue.
1968  * This will usually be done immediately after a thread is created.
1969  * The caller of scheduleThread must create the thread using e.g.
1970  * createThread and push an appropriate closure
1971  * on this thread's stack before the scheduler is invoked.
1972  * ------------------------------------------------------------------------ */
1973
1974 static void scheduleThread_ (StgTSO* tso, rtsBool createTask);
1975
1976 void
1977 scheduleThread_(StgTSO *tso
1978                , rtsBool createTask
1979 #if !defined(THREADED_RTS)
1980                  STG_UNUSED
1981 #endif
1982               )
1983 {
1984   // Precondition: sched_mutex must be held.
1985
1986   /* Put the new thread on the head of the runnable queue.  The caller
1987    * better push an appropriate closure on this thread's stack
1988    * beforehand.  In the SMP case, the thread may start running as
1989    * soon as we release the scheduler lock below.
1990    */
1991   PUSH_ON_RUN_QUEUE(tso);
1992 #if defined(THREADED_RTS)
1993   /* If main() is scheduling a thread, don't bother creating a
1994    * new task.
1995    */
1996   if ( createTask ) {
1997     startTask(taskStart);
1998   }
1999 #endif
2000   THREAD_RUNNABLE();
2001
2002 #if 0
2003   IF_DEBUG(scheduler,printTSO(tso));
2004 #endif
2005 }
2006
2007 void scheduleThread(StgTSO* tso)
2008 {
2009   ACQUIRE_LOCK(&sched_mutex);
2010   scheduleThread_(tso, rtsFalse);
2011   RELEASE_LOCK(&sched_mutex);
2012 }
2013
2014 SchedulerStatus
2015 scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret)
2016 {
2017   StgMainThread *m;
2018
2019   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
2020   m->tso = tso;
2021   m->ret = ret;
2022   m->stat = NoStatus;
2023 #if defined(RTS_SUPPORTS_THREADS)
2024   initCondition(&m->wakeup);
2025 #endif
2026
2027   /* Put the thread on the main-threads list prior to scheduling the TSO.
2028      Failure to do so introduces a race condition in the MT case (as
2029      identified by Wolfgang Thaller), whereby the new task/OS thread
2030      created by scheduleThread_() would complete prior to the thread
2031      that spawned it managed to put 'itself' on the main-threads list.
2032      The upshot of it all being that the worker thread wouldn't get to
2033      signal the completion of the its work item for the main thread to
2034      see (==> it got stuck waiting.)    -- sof 6/02.
2035   */
2036   ACQUIRE_LOCK(&sched_mutex);
2037   IF_DEBUG(scheduler, sched_belch("waiting for thread (%d)\n", tso->id));
2038
2039   m->link = main_threads;
2040   main_threads = m;
2041
2042   scheduleThread_(tso, rtsTrue);
2043 #if defined(THREADED_RTS)
2044   return waitThread_(m, rtsTrue);       // waitThread_ releases sched_mutex
2045 #else
2046   return waitThread_(m);
2047 #endif
2048 }
2049
2050 /* ---------------------------------------------------------------------------
2051  * initScheduler()
2052  *
2053  * Initialise the scheduler.  This resets all the queues - if the
2054  * queues contained any threads, they'll be garbage collected at the
2055  * next pass.
2056  *
2057  * ------------------------------------------------------------------------ */
2058
2059 #ifdef SMP
2060 static void
2061 term_handler(int sig STG_UNUSED)
2062 {
2063   stat_workerStop();
2064   ACQUIRE_LOCK(&term_mutex);
2065   await_death--;
2066   RELEASE_LOCK(&term_mutex);
2067   shutdownThread();
2068 }
2069 #endif
2070
2071 void
2072 initScheduler(void)
2073 {
2074 #if defined(GRAN)
2075   nat i;
2076
2077   for (i=0; i<=MAX_PROC; i++) {
2078     run_queue_hds[i]      = END_TSO_QUEUE;
2079     run_queue_tls[i]      = END_TSO_QUEUE;
2080     blocked_queue_hds[i]  = END_TSO_QUEUE;
2081     blocked_queue_tls[i]  = END_TSO_QUEUE;
2082     ccalling_threadss[i]  = END_TSO_QUEUE;
2083     sleeping_queue        = END_TSO_QUEUE;
2084   }
2085 #else
2086   run_queue_hd      = END_TSO_QUEUE;
2087   run_queue_tl      = END_TSO_QUEUE;
2088   blocked_queue_hd  = END_TSO_QUEUE;
2089   blocked_queue_tl  = END_TSO_QUEUE;
2090   sleeping_queue    = END_TSO_QUEUE;
2091 #endif
2092
2093   suspended_ccalling_threads  = END_TSO_QUEUE;
2094
2095   main_threads = NULL;
2096   all_threads  = END_TSO_QUEUE;
2097
2098   context_switch = 0;
2099   interrupted    = 0;
2100
2101   RtsFlags.ConcFlags.ctxtSwitchTicks =
2102       RtsFlags.ConcFlags.ctxtSwitchTime / TICK_MILLISECS;
2103
2104 #if defined(RTS_SUPPORTS_THREADS)
2105   /* Initialise the mutex and condition variables used by
2106    * the scheduler. */
2107   initMutex(&sched_mutex);
2108   initMutex(&term_mutex);
2109   initMutex(&thread_id_mutex);
2110
2111   initCondition(&thread_ready_cond);
2112 #endif
2113
2114 #if defined(SMP)
2115   initCondition(&gc_pending_cond);
2116 #endif
2117
2118 #if defined(RTS_SUPPORTS_THREADS)
2119   ACQUIRE_LOCK(&sched_mutex);
2120 #endif
2121
2122   /* Install the SIGHUP handler */
2123 #if defined(SMP)
2124   {
2125     struct sigaction action,oact;
2126
2127     action.sa_handler = term_handler;
2128     sigemptyset(&action.sa_mask);
2129     action.sa_flags = 0;
2130     if (sigaction(SIGTERM, &action, &oact) != 0) {
2131       barf("can't install TERM handler");
2132     }
2133   }
2134 #endif
2135
2136   /* A capability holds the state a native thread needs in
2137    * order to execute STG code. At least one capability is
2138    * floating around (only SMP builds have more than one).
2139    */
2140   initCapabilities();
2141
2142 #if defined(RTS_SUPPORTS_THREADS)
2143     /* start our haskell execution tasks */
2144 # if defined(SMP)
2145     startTaskManager(RtsFlags.ParFlags.nNodes, taskStart);
2146 # else
2147     startTaskManager(0,taskStart);
2148 # endif
2149 #endif
2150
2151 #if /* defined(SMP) ||*/ defined(PAR)
2152   initSparkPools();
2153 #endif
2154
2155 #if defined(RTS_SUPPORTS_THREADS)
2156   RELEASE_LOCK(&sched_mutex);
2157 #endif
2158
2159 }
2160
2161 void
2162 exitScheduler( void )
2163 {
2164 #if defined(RTS_SUPPORTS_THREADS)
2165   stopTaskManager();
2166 #endif
2167   shutting_down_scheduler = rtsTrue;
2168 }
2169
2170 /* -----------------------------------------------------------------------------
2171    Managing the per-task allocation areas.
2172
2173    Each capability comes with an allocation area.  These are
2174    fixed-length block lists into which allocation can be done.
2175
2176    ToDo: no support for two-space collection at the moment???
2177    -------------------------------------------------------------------------- */
2178
2179 /* -----------------------------------------------------------------------------
2180  * waitThread is the external interface for running a new computation
2181  * and waiting for the result.
2182  *
2183  * In the non-SMP case, we create a new main thread, push it on the
2184  * main-thread stack, and invoke the scheduler to run it.  The
2185  * scheduler will return when the top main thread on the stack has
2186  * completed or died, and fill in the necessary fields of the
2187  * main_thread structure.
2188  *
2189  * In the SMP case, we create a main thread as before, but we then
2190  * create a new condition variable and sleep on it.  When our new
2191  * main thread has completed, we'll be woken up and the status/result
2192  * will be in the main_thread struct.
2193  * -------------------------------------------------------------------------- */
2194
2195 int
2196 howManyThreadsAvail ( void )
2197 {
2198    int i = 0;
2199    StgTSO* q;
2200    for (q = run_queue_hd; q != END_TSO_QUEUE; q = q->link)
2201       i++;
2202    for (q = blocked_queue_hd; q != END_TSO_QUEUE; q = q->link)
2203       i++;
2204    for (q = sleeping_queue; q != END_TSO_QUEUE; q = q->link)
2205       i++;
2206    return i;
2207 }
2208
2209 void
2210 finishAllThreads ( void )
2211 {
2212    do {
2213       while (run_queue_hd != END_TSO_QUEUE) {
2214          waitThread ( run_queue_hd, NULL);
2215       }
2216       while (blocked_queue_hd != END_TSO_QUEUE) {
2217          waitThread ( blocked_queue_hd, NULL);
2218       }
2219       while (sleeping_queue != END_TSO_QUEUE) {
2220          waitThread ( blocked_queue_hd, NULL);
2221       }
2222    } while
2223       (blocked_queue_hd != END_TSO_QUEUE ||
2224        run_queue_hd     != END_TSO_QUEUE ||
2225        sleeping_queue   != END_TSO_QUEUE);
2226 }
2227
2228 SchedulerStatus
2229 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
2230 {
2231   StgMainThread *m;
2232
2233   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
2234   m->tso = tso;
2235   m->ret = ret;
2236   m->stat = NoStatus;
2237 #if defined(RTS_SUPPORTS_THREADS)
2238   initCondition(&m->wakeup);
2239 #endif
2240
2241   /* see scheduleWaitThread() comment */
2242   ACQUIRE_LOCK(&sched_mutex);
2243   m->link = main_threads;
2244   main_threads = m;
2245
2246   IF_DEBUG(scheduler, sched_belch("waiting for thread %d", tso->id));
2247 #if defined(THREADED_RTS)
2248   return waitThread_(m, rtsFalse);      // waitThread_ releases sched_mutex
2249 #else
2250   return waitThread_(m);
2251 #endif
2252 }
2253
2254 static
2255 SchedulerStatus
2256 waitThread_(StgMainThread* m
2257 #if defined(THREADED_RTS)
2258             , rtsBool blockWaiting
2259 #endif
2260            )
2261 {
2262   SchedulerStatus stat;
2263
2264   // Precondition: sched_mutex must be held.
2265   IF_DEBUG(scheduler, sched_belch("== scheduler: new main thread (%d)\n", m->tso->id));
2266
2267 #if defined(RTS_SUPPORTS_THREADS)
2268
2269 # if defined(THREADED_RTS)
2270   if (!blockWaiting) {
2271     /* In the threaded case, the OS thread that called main()
2272      * gets to enter the RTS directly without going via another
2273      * task/thread.
2274      */
2275     RELEASE_LOCK(&sched_mutex);
2276     schedule();
2277     ASSERT(m->stat != NoStatus);
2278   } else
2279 # endif
2280   {
2281     do {
2282       waitCondition(&m->wakeup, &sched_mutex);
2283     } while (m->stat == NoStatus);
2284   }
2285 #elif defined(GRAN)
2286   /* GranSim specific init */
2287   CurrentTSO = m->tso;                // the TSO to run
2288   procStatus[MainProc] = Busy;        // status of main PE
2289   CurrentProc = MainProc;             // PE to run it on
2290
2291   RELEASE_LOCK(&sched_mutex);
2292   schedule();
2293 #else
2294   RELEASE_LOCK(&sched_mutex);
2295   schedule();
2296   ASSERT(m->stat != NoStatus);
2297 #endif
2298
2299   stat = m->stat;
2300
2301 #if defined(RTS_SUPPORTS_THREADS)
2302   closeCondition(&m->wakeup);
2303 #endif
2304
2305   IF_DEBUG(scheduler, fprintf(stderr, "== scheduler: main thread (%d) finished\n",
2306                               m->tso->id));
2307   free(m);
2308
2309 #if defined(THREADED_RTS)
2310   if (blockWaiting)
2311 #endif
2312     RELEASE_LOCK(&sched_mutex);
2313
2314   // Postcondition: sched_mutex must not be held
2315   return stat;
2316 }
2317
2318 //@node Run queue code, Garbage Collextion Routines, Suspend and Resume, Main scheduling code
2319 //@subsection Run queue code
2320
2321 #if 0
2322 /*
2323    NB: In GranSim we have many run queues; run_queue_hd is actually a macro
2324        unfolding to run_queue_hds[CurrentProc], thus CurrentProc is an
2325        implicit global variable that has to be correct when calling these
2326        fcts -- HWL
2327 */
2328
2329 /* Put the new thread on the head of the runnable queue.
2330  * The caller of createThread better push an appropriate closure
2331  * on this thread's stack before the scheduler is invoked.
2332  */
2333 static /* inline */ void
2334 add_to_run_queue(tso)
2335 StgTSO* tso;
2336 {
2337   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
2338   tso->link = run_queue_hd;
2339   run_queue_hd = tso;
2340   if (run_queue_tl == END_TSO_QUEUE) {
2341     run_queue_tl = tso;
2342   }
2343 }
2344
2345 /* Put the new thread at the end of the runnable queue. */
2346 static /* inline */ void
2347 push_on_run_queue(tso)
2348 StgTSO* tso;
2349 {
2350   ASSERT(get_itbl((StgClosure *)tso)->type == TSO);
2351   ASSERT(run_queue_hd!=NULL && run_queue_tl!=NULL);
2352   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
2353   if (run_queue_hd == END_TSO_QUEUE) {
2354     run_queue_hd = tso;
2355   } else {
2356     run_queue_tl->link = tso;
2357   }
2358   run_queue_tl = tso;
2359 }
2360
2361 /*
2362    Should be inlined because it's used very often in schedule.  The tso
2363    argument is actually only needed in GranSim, where we want to have the
2364    possibility to schedule *any* TSO on the run queue, irrespective of the
2365    actual ordering. Therefore, if tso is not the nil TSO then we traverse
2366    the run queue and dequeue the tso, adjusting the links in the queue.
2367 */
2368 //@cindex take_off_run_queue
2369 static /* inline */ StgTSO*
2370 take_off_run_queue(StgTSO *tso) {
2371   StgTSO *t, *prev;
2372
2373   /*
2374      qetlaHbogh Qu' ngaSbogh ghomDaQ {tso} yIteq!
2375
2376      if tso is specified, unlink that tso from the run_queue (doesn't have
2377      to be at the beginning of the queue); GranSim only
2378   */
2379   if (tso!=END_TSO_QUEUE) {
2380     /* find tso in queue */
2381     for (t=run_queue_hd, prev=END_TSO_QUEUE;
2382          t!=END_TSO_QUEUE && t!=tso;
2383          prev=t, t=t->link)
2384       /* nothing */ ;
2385     ASSERT(t==tso);
2386     /* now actually dequeue the tso */
2387     if (prev!=END_TSO_QUEUE) {
2388       ASSERT(run_queue_hd!=t);
2389       prev->link = t->link;
2390     } else {
2391       /* t is at beginning of thread queue */
2392       ASSERT(run_queue_hd==t);
2393       run_queue_hd = t->link;
2394     }
2395     /* t is at end of thread queue */
2396     if (t->link==END_TSO_QUEUE) {
2397       ASSERT(t==run_queue_tl);
2398       run_queue_tl = prev;
2399     } else {
2400       ASSERT(run_queue_tl!=t);
2401     }
2402     t->link = END_TSO_QUEUE;
2403   } else {
2404     /* take tso from the beginning of the queue; std concurrent code */
2405     t = run_queue_hd;
2406     if (t != END_TSO_QUEUE) {
2407       run_queue_hd = t->link;
2408       t->link = END_TSO_QUEUE;
2409       if (run_queue_hd == END_TSO_QUEUE) {
2410         run_queue_tl = END_TSO_QUEUE;
2411       }
2412     }
2413   }
2414   return t;
2415 }
2416
2417 #endif /* 0 */
2418
2419 //@node Garbage Collextion Routines, Blocking Queue Routines, Run queue code, Main scheduling code
2420 //@subsection Garbage Collextion Routines
2421
2422 /* ---------------------------------------------------------------------------
2423    Where are the roots that we know about?
2424
2425         - all the threads on the runnable queue
2426         - all the threads on the blocked queue
2427         - all the threads on the sleeping queue
2428         - all the thread currently executing a _ccall_GC
2429         - all the "main threads"
2430
2431    ------------------------------------------------------------------------ */
2432
2433 /* This has to be protected either by the scheduler monitor, or by the
2434         garbage collection monitor (probably the latter).
2435         KH @ 25/10/99
2436 */
2437
2438 void
2439 GetRoots(evac_fn evac)
2440 {
2441 #if defined(GRAN)
2442   {
2443     nat i;
2444     for (i=0; i<=RtsFlags.GranFlags.proc; i++) {
2445       if ((run_queue_hds[i] != END_TSO_QUEUE) && ((run_queue_hds[i] != NULL)))
2446           evac((StgClosure **)&run_queue_hds[i]);
2447       if ((run_queue_tls[i] != END_TSO_QUEUE) && ((run_queue_tls[i] != NULL)))
2448           evac((StgClosure **)&run_queue_tls[i]);
2449
2450       if ((blocked_queue_hds[i] != END_TSO_QUEUE) && ((blocked_queue_hds[i] != NULL)))
2451           evac((StgClosure **)&blocked_queue_hds[i]);
2452       if ((blocked_queue_tls[i] != END_TSO_QUEUE) && ((blocked_queue_tls[i] != NULL)))
2453           evac((StgClosure **)&blocked_queue_tls[i]);
2454       if ((ccalling_threadss[i] != END_TSO_QUEUE) && ((ccalling_threadss[i] != NULL)))
2455           evac((StgClosure **)&ccalling_threads[i]);
2456     }
2457   }
2458
2459   markEventQueue();
2460
2461 #else /* !GRAN */
2462   if (run_queue_hd != END_TSO_QUEUE) {
2463       ASSERT(run_queue_tl != END_TSO_QUEUE);
2464       evac((StgClosure **)&run_queue_hd);
2465       evac((StgClosure **)&run_queue_tl);
2466   }
2467
2468   if (blocked_queue_hd != END_TSO_QUEUE) {
2469       ASSERT(blocked_queue_tl != END_TSO_QUEUE);
2470       evac((StgClosure **)&blocked_queue_hd);
2471       evac((StgClosure **)&blocked_queue_tl);
2472   }
2473
2474   if (sleeping_queue != END_TSO_QUEUE) {
2475       evac((StgClosure **)&sleeping_queue);
2476   }
2477 #endif
2478
2479   if (suspended_ccalling_threads != END_TSO_QUEUE) {
2480       evac((StgClosure **)&suspended_ccalling_threads);
2481   }
2482
2483 #if defined(PAR) || defined(GRAN)
2484   markSparkQueue(evac);
2485 #endif
2486
2487 #ifndef mingw32_TARGET_OS
2488   // mark the signal handlers (signals should be already blocked)
2489   markSignalHandlers(evac);
2490 #endif
2491
2492   // main threads which have completed need to be retained until they
2493   // are dealt with in the main scheduler loop.  They won't be
2494   // retained any other way: the GC will drop them from the
2495   // all_threads list, so we have to be careful to treat them as roots
2496   // here.
2497   {
2498       StgMainThread *m;
2499       for (m = main_threads; m != NULL; m = m->link) {
2500           switch (m->tso->what_next) {
2501           case ThreadComplete:
2502           case ThreadKilled:
2503               evac((StgClosure **)&m->tso);
2504               break;
2505           default:
2506               break;
2507           }
2508       }
2509   }
2510 }
2511
2512 /* -----------------------------------------------------------------------------
2513    performGC
2514
2515    This is the interface to the garbage collector from Haskell land.
2516    We provide this so that external C code can allocate and garbage
2517    collect when called from Haskell via _ccall_GC.
2518
2519    It might be useful to provide an interface whereby the programmer
2520    can specify more roots (ToDo).
2521
2522    This needs to be protected by the GC condition variable above.  KH.
2523    -------------------------------------------------------------------------- */
2524
2525 static void (*extra_roots)(evac_fn);
2526
2527 void
2528 performGC(void)
2529 {
2530   /* Obligated to hold this lock upon entry */
2531   ACQUIRE_LOCK(&sched_mutex);
2532   GarbageCollect(GetRoots,rtsFalse);
2533   RELEASE_LOCK(&sched_mutex);
2534 }
2535
2536 void
2537 performMajorGC(void)
2538 {
2539   ACQUIRE_LOCK(&sched_mutex);
2540   GarbageCollect(GetRoots,rtsTrue);
2541   RELEASE_LOCK(&sched_mutex);
2542 }
2543
2544 static void
2545 AllRoots(evac_fn evac)
2546 {
2547     GetRoots(evac);             // the scheduler's roots
2548     extra_roots(evac);          // the user's roots
2549 }
2550
2551 void
2552 performGCWithRoots(void (*get_roots)(evac_fn))
2553 {
2554   ACQUIRE_LOCK(&sched_mutex);
2555   extra_roots = get_roots;
2556   GarbageCollect(AllRoots,rtsFalse);
2557   RELEASE_LOCK(&sched_mutex);
2558 }
2559
2560 /* -----------------------------------------------------------------------------
2561    Stack overflow
2562
2563    If the thread has reached its maximum stack size, then raise the
2564    StackOverflow exception in the offending thread.  Otherwise
2565    relocate the TSO into a larger chunk of memory and adjust its stack
2566    size appropriately.
2567    -------------------------------------------------------------------------- */
2568
2569 static StgTSO *
2570 threadStackOverflow(StgTSO *tso)
2571 {
2572   nat new_stack_size, new_tso_size, diff, stack_words;
2573   StgPtr new_sp;
2574   StgTSO *dest;
2575
2576   IF_DEBUG(sanity,checkTSO(tso));
2577   if (tso->stack_size >= tso->max_stack_size) {
2578
2579     IF_DEBUG(gc,
2580              belch("@@ threadStackOverflow of TSO %d (%p): stack too large (now %ld; max is %ld",
2581                    tso->id, tso, tso->stack_size, tso->max_stack_size);
2582              /* If we're debugging, just print out the top of the stack */
2583              printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2584                                               tso->sp+64)));
2585
2586     /* Send this thread the StackOverflow exception */
2587     raiseAsync(tso, (StgClosure *)stackOverflow_closure);
2588     return tso;
2589   }
2590
2591   /* Try to double the current stack size.  If that takes us over the
2592    * maximum stack size for this thread, then use the maximum instead.
2593    * Finally round up so the TSO ends up as a whole number of blocks.
2594    */
2595   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
2596   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
2597                                        TSO_STRUCT_SIZE)/sizeof(W_);
2598   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
2599   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
2600
2601   IF_DEBUG(scheduler, fprintf(stderr,"== scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
2602
2603   dest = (StgTSO *)allocate(new_tso_size);
2604   TICK_ALLOC_TSO(new_stack_size,0);
2605
2606   /* copy the TSO block and the old stack into the new area */
2607   memcpy(dest,tso,TSO_STRUCT_SIZE);
2608   stack_words = tso->stack + tso->stack_size - tso->sp;
2609   new_sp = (P_)dest + new_tso_size - stack_words;
2610   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
2611
2612   /* relocate the stack pointers... */
2613   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
2614   dest->sp    = new_sp;
2615   dest->stack_size = new_stack_size;
2616
2617   /* Mark the old TSO as relocated.  We have to check for relocated
2618    * TSOs in the garbage collector and any primops that deal with TSOs.
2619    *
2620    * It's important to set the sp value to just beyond the end
2621    * of the stack, so we don't attempt to scavenge any part of the
2622    * dead TSO's stack.
2623    */
2624   tso->what_next = ThreadRelocated;
2625   tso->link = dest;
2626   tso->sp = (P_)&(tso->stack[tso->stack_size]);
2627   tso->why_blocked = NotBlocked;
2628   dest->mut_link = NULL;
2629
2630   IF_PAR_DEBUG(verbose,
2631                belch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld",
2632                      tso->id, tso, tso->stack_size);
2633                /* If we're debugging, just print out the top of the stack */
2634                printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2635                                                 tso->sp+64)));
2636
2637   IF_DEBUG(sanity,checkTSO(tso));
2638 #if 0
2639   IF_DEBUG(scheduler,printTSO(dest));
2640 #endif
2641
2642   return dest;
2643 }
2644
2645 //@node Blocking Queue Routines, Exception Handling Routines, Garbage Collextion Routines, Main scheduling code
2646 //@subsection Blocking Queue Routines
2647
2648 /* ---------------------------------------------------------------------------
2649    Wake up a queue that was blocked on some resource.
2650    ------------------------------------------------------------------------ */
2651
2652 #if defined(GRAN)
2653 static inline void
2654 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
2655 {
2656 }
2657 #elif defined(PAR)
2658 static inline void
2659 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
2660 {
2661   /* write RESUME events to log file and
2662      update blocked and fetch time (depending on type of the orig closure) */
2663   if (RtsFlags.ParFlags.ParStats.Full) {
2664     DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
2665                      GR_RESUMEQ, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
2666                      0, 0 /* spark_queue_len(ADVISORY_POOL) */);
2667     if (EMPTY_RUN_QUEUE())
2668       emitSchedule = rtsTrue;
2669
2670     switch (get_itbl(node)->type) {
2671         case FETCH_ME_BQ:
2672           ((StgTSO *)bqe)->par.fetchtime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
2673           break;
2674         case RBH:
2675         case FETCH_ME:
2676         case BLACKHOLE_BQ:
2677           ((StgTSO *)bqe)->par.blocktime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
2678           break;
2679 #ifdef DIST
2680         case MVAR:
2681           break;
2682 #endif
2683         default:
2684           barf("{unblockOneLocked}Daq Qagh: unexpected closure in blocking queue");
2685         }
2686       }
2687 }
2688 #endif
2689
2690 #if defined(GRAN)
2691 static StgBlockingQueueElement *
2692 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
2693 {
2694     StgTSO *tso;
2695     PEs node_loc, tso_loc;
2696
2697     node_loc = where_is(node); // should be lifted out of loop
2698     tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
2699     tso_loc = where_is((StgClosure *)tso);
2700     if (IS_LOCAL_TO(PROCS(node),tso_loc)) { // TSO is local
2701       /* !fake_fetch => TSO is on CurrentProc is same as IS_LOCAL_TO */
2702       ASSERT(CurrentProc!=node_loc || tso_loc==CurrentProc);
2703       CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.lunblocktime;
2704       // insertThread(tso, node_loc);
2705       new_event(tso_loc, tso_loc, CurrentTime[CurrentProc],
2706                 ResumeThread,
2707                 tso, node, (rtsSpark*)NULL);
2708       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
2709       // len_local++;
2710       // len++;
2711     } else { // TSO is remote (actually should be FMBQ)
2712       CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime +
2713                                   RtsFlags.GranFlags.Costs.gunblocktime +
2714                                   RtsFlags.GranFlags.Costs.latency;
2715       new_event(tso_loc, CurrentProc, CurrentTime[CurrentProc],
2716                 UnblockThread,
2717                 tso, node, (rtsSpark*)NULL);
2718       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
2719       // len++;
2720     }
2721     /* the thread-queue-overhead is accounted for in either Resume or UnblockThread */
2722     IF_GRAN_DEBUG(bq,
2723                   fprintf(stderr," %s TSO %d (%p) [PE %d] (block_info.closure=%p) (next=%p) ,",
2724                           (node_loc==tso_loc ? "Local" : "Global"),
2725                           tso->id, tso, CurrentProc, tso->block_info.closure, tso->link));
2726     tso->block_info.closure = NULL;
2727     IF_DEBUG(scheduler,belch("-- Waking up thread %ld (%p)",
2728                              tso->id, tso));
2729 }
2730 #elif defined(PAR)
2731 static StgBlockingQueueElement *
2732 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
2733 {
2734     StgBlockingQueueElement *next;
2735
2736     switch (get_itbl(bqe)->type) {
2737     case TSO:
2738       ASSERT(((StgTSO *)bqe)->why_blocked != NotBlocked);
2739       /* if it's a TSO just push it onto the run_queue */
2740       next = bqe->link;
2741       // ((StgTSO *)bqe)->link = END_TSO_QUEUE; // debugging?
2742       PUSH_ON_RUN_QUEUE((StgTSO *)bqe);
2743       THREAD_RUNNABLE();
2744       unblockCount(bqe, node);
2745       /* reset blocking status after dumping event */
2746       ((StgTSO *)bqe)->why_blocked = NotBlocked;
2747       break;
2748
2749     case BLOCKED_FETCH:
2750       /* if it's a BLOCKED_FETCH put it on the PendingFetches list */
2751       next = bqe->link;
2752       bqe->link = (StgBlockingQueueElement *)PendingFetches;
2753       PendingFetches = (StgBlockedFetch *)bqe;
2754       break;
2755
2756 # if defined(DEBUG)
2757       /* can ignore this case in a non-debugging setup;
2758          see comments on RBHSave closures above */
2759     case CONSTR:
2760       /* check that the closure is an RBHSave closure */
2761       ASSERT(get_itbl((StgClosure *)bqe) == &stg_RBH_Save_0_info ||
2762              get_itbl((StgClosure *)bqe) == &stg_RBH_Save_1_info ||
2763              get_itbl((StgClosure *)bqe) == &stg_RBH_Save_2_info);
2764       break;
2765
2766     default:
2767       barf("{unblockOneLocked}Daq Qagh: Unexpected IP (%#lx; %s) in blocking queue at %#lx\n",
2768            get_itbl((StgClosure *)bqe), info_type((StgClosure *)bqe),
2769            (StgClosure *)bqe);
2770 # endif
2771     }
2772   IF_PAR_DEBUG(bq, fprintf(stderr, ", %p (%s)", bqe, info_type((StgClosure*)bqe)));
2773   return next;
2774 }
2775
2776 #else /* !GRAN && !PAR */
2777 static StgTSO *
2778 unblockOneLocked(StgTSO *tso)
2779 {
2780   StgTSO *next;
2781
2782   ASSERT(get_itbl(tso)->type == TSO);
2783   ASSERT(tso->why_blocked != NotBlocked);
2784   tso->why_blocked = NotBlocked;
2785   next = tso->link;
2786   PUSH_ON_RUN_QUEUE(tso);
2787   THREAD_RUNNABLE();
2788   IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
2789   return next;
2790 }
2791 #endif
2792
2793 #if defined(GRAN) || defined(PAR)
2794 inline StgBlockingQueueElement *
2795 unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
2796 {
2797   ACQUIRE_LOCK(&sched_mutex);
2798   bqe = unblockOneLocked(bqe, node);
2799   RELEASE_LOCK(&sched_mutex);
2800   return bqe;
2801 }
2802 #else
2803 inline StgTSO *
2804 unblockOne(StgTSO *tso)
2805 {
2806   ACQUIRE_LOCK(&sched_mutex);
2807   tso = unblockOneLocked(tso);
2808   RELEASE_LOCK(&sched_mutex);
2809   return tso;
2810 }
2811 #endif
2812
2813 #if defined(GRAN)
2814 void
2815 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
2816 {
2817   StgBlockingQueueElement *bqe;
2818   PEs node_loc;
2819   nat len = 0;
2820
2821   IF_GRAN_DEBUG(bq,
2822                 belch("##-_ AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
2823                       node, CurrentProc, CurrentTime[CurrentProc],
2824                       CurrentTSO->id, CurrentTSO));
2825
2826   node_loc = where_is(node);
2827
2828   ASSERT(q == END_BQ_QUEUE ||
2829          get_itbl(q)->type == TSO ||   // q is either a TSO or an RBHSave
2830          get_itbl(q)->type == CONSTR); // closure (type constructor)
2831   ASSERT(is_unique(node));
2832
2833   /* FAKE FETCH: magically copy the node to the tso's proc;
2834      no Fetch necessary because in reality the node should not have been
2835      moved to the other PE in the first place
2836   */
2837   if (CurrentProc!=node_loc) {
2838     IF_GRAN_DEBUG(bq,
2839                   belch("## node %p is on PE %d but CurrentProc is %d (TSO %d); assuming fake fetch and adjusting bitmask (old: %#x)",
2840                         node, node_loc, CurrentProc, CurrentTSO->id,
2841                         // CurrentTSO, where_is(CurrentTSO),
2842                         node->header.gran.procs));
2843     node->header.gran.procs = (node->header.gran.procs) | PE_NUMBER(CurrentProc);
2844     IF_GRAN_DEBUG(bq,
2845                   belch("## new bitmask of node %p is %#x",
2846                         node, node->header.gran.procs));
2847     if (RtsFlags.GranFlags.GranSimStats.Global) {
2848       globalGranStats.tot_fake_fetches++;
2849     }
2850   }
2851
2852   bqe = q;
2853   // ToDo: check: ASSERT(CurrentProc==node_loc);
2854   while (get_itbl(bqe)->type==TSO) { // q != END_TSO_QUEUE) {
2855     //next = bqe->link;
2856     /*
2857        bqe points to the current element in the queue
2858        next points to the next element in the queue
2859     */
2860     //tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
2861     //tso_loc = where_is(tso);
2862     len++;
2863     bqe = unblockOneLocked(bqe, node);
2864   }
2865
2866   /* if this is the BQ of an RBH, we have to put back the info ripped out of
2867      the closure to make room for the anchor of the BQ */
2868   if (bqe!=END_BQ_QUEUE) {
2869     ASSERT(get_itbl(node)->type == RBH && get_itbl(bqe)->type == CONSTR);
2870     /*
2871     ASSERT((info_ptr==&RBH_Save_0_info) ||
2872            (info_ptr==&RBH_Save_1_info) ||
2873            (info_ptr==&RBH_Save_2_info));
2874     */
2875     /* cf. convertToRBH in RBH.c for writing the RBHSave closure */
2876     ((StgRBH *)node)->blocking_queue = (StgBlockingQueueElement *)((StgRBHSave *)bqe)->payload[0];
2877     ((StgRBH *)node)->mut_link       = (StgMutClosure *)((StgRBHSave *)bqe)->payload[1];
2878
2879     IF_GRAN_DEBUG(bq,
2880                   belch("## Filled in RBH_Save for %p (%s) at end of AwBQ",
2881                         node, info_type(node)));
2882   }
2883
2884   /* statistics gathering */
2885   if (RtsFlags.GranFlags.GranSimStats.Global) {
2886     // globalGranStats.tot_bq_processing_time += bq_processing_time;
2887     globalGranStats.tot_bq_len += len;      // total length of all bqs awakened
2888     // globalGranStats.tot_bq_len_local += len_local;  // same for local TSOs only
2889     globalGranStats.tot_awbq++;             // total no. of bqs awakened
2890   }
2891   IF_GRAN_DEBUG(bq,
2892                 fprintf(stderr,"## BQ Stats of %p: [%d entries] %s\n",
2893                         node, len, (bqe!=END_BQ_QUEUE) ? "RBH" : ""));
2894 }
2895 #elif defined(PAR)
2896 void
2897 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
2898 {
2899   StgBlockingQueueElement *bqe;
2900
2901   ACQUIRE_LOCK(&sched_mutex);
2902
2903   IF_PAR_DEBUG(verbose,
2904                belch("##-_ AwBQ for node %p on [%x]: ",
2905                      node, mytid));
2906 #ifdef DIST
2907   //RFP
2908   if(get_itbl(q)->type == CONSTR || q==END_BQ_QUEUE) {
2909     IF_PAR_DEBUG(verbose, belch("## ... nothing to unblock so lets just return. RFP (BUG?)"));
2910     return;
2911   }
2912 #endif
2913
2914   ASSERT(q == END_BQ_QUEUE ||
2915          get_itbl(q)->type == TSO ||
2916          get_itbl(q)->type == BLOCKED_FETCH ||
2917          get_itbl(q)->type == CONSTR);
2918
2919   bqe = q;
2920   while (get_itbl(bqe)->type==TSO ||
2921          get_itbl(bqe)->type==BLOCKED_FETCH) {
2922     bqe = unblockOneLocked(bqe, node);
2923   }
2924   RELEASE_LOCK(&sched_mutex);
2925 }
2926
2927 #else   /* !GRAN && !PAR */
2928 void
2929 awakenBlockedQueue(StgTSO *tso)
2930 {
2931   ACQUIRE_LOCK(&sched_mutex);
2932   while (tso != END_TSO_QUEUE) {
2933     tso = unblockOneLocked(tso);
2934   }
2935   RELEASE_LOCK(&sched_mutex);
2936 }
2937 #endif
2938
2939 //@node Exception Handling Routines, Debugging Routines, Blocking Queue Routines, Main scheduling code
2940 //@subsection Exception Handling Routines
2941
2942 /* ---------------------------------------------------------------------------
2943    Interrupt execution
2944    - usually called inside a signal handler so it mustn't do anything fancy.
2945    ------------------------------------------------------------------------ */
2946
2947 void
2948 interruptStgRts(void)
2949 {
2950     interrupted    = 1;
2951     context_switch = 1;
2952 }
2953
2954 /* -----------------------------------------------------------------------------
2955    Unblock a thread
2956
2957    This is for use when we raise an exception in another thread, which
2958    may be blocked.
2959    This has nothing to do with the UnblockThread event in GranSim. -- HWL
2960    -------------------------------------------------------------------------- */
2961
2962 #if defined(GRAN) || defined(PAR)
2963 /*
2964   NB: only the type of the blocking queue is different in GranSim and GUM
2965       the operations on the queue-elements are the same
2966       long live polymorphism!
2967
2968   Locks: sched_mutex is held upon entry and exit.
2969
2970 */
2971 static void
2972 unblockThread(StgTSO *tso)
2973 {
2974   StgBlockingQueueElement *t, **last;
2975
2976   switch (tso->why_blocked) {
2977
2978   case NotBlocked:
2979     return;  /* not blocked */
2980
2981   case BlockedOnMVar:
2982     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
2983     {
2984       StgBlockingQueueElement *last_tso = END_BQ_QUEUE;
2985       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
2986
2987       last = (StgBlockingQueueElement **)&mvar->head;
2988       for (t = (StgBlockingQueueElement *)mvar->head;
2989            t != END_BQ_QUEUE;
2990            last = &t->link, last_tso = t, t = t->link) {
2991         if (t == (StgBlockingQueueElement *)tso) {
2992           *last = (StgBlockingQueueElement *)tso->link;
2993           if (mvar->tail == tso) {
2994             mvar->tail = (StgTSO *)last_tso;
2995           }
2996           goto done;
2997         }
2998       }
2999       barf("unblockThread (MVAR): TSO not found");
3000     }
3001
3002   case BlockedOnBlackHole:
3003     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
3004     {
3005       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
3006
3007       last = &bq->blocking_queue;
3008       for (t = bq->blocking_queue;
3009            t != END_BQ_QUEUE;
3010            last = &t->link, t = t->link) {
3011         if (t == (StgBlockingQueueElement *)tso) {
3012           *last = (StgBlockingQueueElement *)tso->link;
3013           goto done;
3014         }
3015       }
3016       barf("unblockThread (BLACKHOLE): TSO not found");
3017     }
3018
3019   case BlockedOnException:
3020     {
3021       StgTSO *target  = tso->block_info.tso;
3022
3023       ASSERT(get_itbl(target)->type == TSO);
3024
3025       if (target->what_next == ThreadRelocated) {
3026           target = target->link;
3027           ASSERT(get_itbl(target)->type == TSO);
3028       }
3029
3030       ASSERT(target->blocked_exceptions != NULL);
3031
3032       last = (StgBlockingQueueElement **)&target->blocked_exceptions;
3033       for (t = (StgBlockingQueueElement *)target->blocked_exceptions;
3034            t != END_BQ_QUEUE;
3035            last = &t->link, t = t->link) {
3036         ASSERT(get_itbl(t)->type == TSO);
3037         if (t == (StgBlockingQueueElement *)tso) {
3038           *last = (StgBlockingQueueElement *)tso->link;
3039           goto done;
3040         }
3041       }
3042       barf("unblockThread (Exception): TSO not found");
3043     }
3044
3045   case BlockedOnRead:
3046   case BlockedOnWrite:
3047     {
3048       /* take TSO off blocked_queue */
3049       StgBlockingQueueElement *prev = NULL;
3050       for (t = (StgBlockingQueueElement *)blocked_queue_hd; t != END_BQ_QUEUE;
3051            prev = t, t = t->link) {
3052         if (t == (StgBlockingQueueElement *)tso) {
3053           if (prev == NULL) {
3054             blocked_queue_hd = (StgTSO *)t->link;
3055             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
3056               blocked_queue_tl = END_TSO_QUEUE;
3057             }
3058           } else {
3059             prev->link = t->link;
3060             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
3061               blocked_queue_tl = (StgTSO *)prev;
3062             }
3063           }
3064           goto done;
3065         }
3066       }
3067       barf("unblockThread (I/O): TSO not found");
3068     }
3069
3070   case BlockedOnDelay:
3071     {
3072       /* take TSO off sleeping_queue */
3073       StgBlockingQueueElement *prev = NULL;
3074       for (t = (StgBlockingQueueElement *)sleeping_queue; t != END_BQ_QUEUE;
3075            prev = t, t = t->link) {
3076         if (t == (StgBlockingQueueElement *)tso) {
3077           if (prev == NULL) {
3078             sleeping_queue = (StgTSO *)t->link;
3079           } else {
3080             prev->link = t->link;
3081           }
3082           goto done;
3083         }
3084       }
3085       barf("unblockThread (I/O): TSO not found");
3086     }
3087
3088   default:
3089     barf("unblockThread");
3090   }
3091
3092  done:
3093   tso->link = END_TSO_QUEUE;
3094   tso->why_blocked = NotBlocked;
3095   tso->block_info.closure = NULL;
3096   PUSH_ON_RUN_QUEUE(tso);
3097 }
3098 #else
3099 static void
3100 unblockThread(StgTSO *tso)
3101 {
3102   StgTSO *t, **last;
3103
3104   /* To avoid locking unnecessarily. */
3105   if (tso->why_blocked == NotBlocked) {
3106     return;
3107   }
3108
3109   switch (tso->why_blocked) {
3110
3111   case BlockedOnMVar:
3112     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
3113     {
3114       StgTSO *last_tso = END_TSO_QUEUE;
3115       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
3116
3117       last = &mvar->head;
3118       for (t = mvar->head; t != END_TSO_QUEUE;
3119            last = &t->link, last_tso = t, t = t->link) {
3120         if (t == tso) {
3121           *last = tso->link;
3122           if (mvar->tail == tso) {
3123             mvar->tail = last_tso;
3124           }
3125           goto done;
3126         }
3127       }
3128       barf("unblockThread (MVAR): TSO not found");
3129     }
3130
3131   case BlockedOnBlackHole:
3132     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
3133     {
3134       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
3135
3136       last = &bq->blocking_queue;
3137       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
3138            last = &t->link, t = t->link) {
3139         if (t == tso) {
3140           *last = tso->link;
3141           goto done;
3142         }
3143       }
3144       barf("unblockThread (BLACKHOLE): TSO not found");
3145     }
3146
3147   case BlockedOnException:
3148     {
3149       StgTSO *target  = tso->block_info.tso;
3150
3151       ASSERT(get_itbl(target)->type == TSO);
3152
3153       while (target->what_next == ThreadRelocated) {
3154           target = target->link;
3155           ASSERT(get_itbl(target)->type == TSO);
3156       }
3157
3158       ASSERT(target->blocked_exceptions != NULL);
3159
3160       last = &target->blocked_exceptions;
3161       for (t = target->blocked_exceptions; t != END_TSO_QUEUE;
3162            last = &t->link, t = t->link) {
3163         ASSERT(get_itbl(t)->type == TSO);
3164         if (t == tso) {
3165           *last = tso->link;
3166           goto done;
3167         }
3168       }
3169       barf("unblockThread (Exception): TSO not found");
3170     }
3171
3172   case BlockedOnRead:
3173   case BlockedOnWrite:
3174     {
3175       StgTSO *prev = NULL;
3176       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
3177            prev = t, t = t->link) {
3178         if (t == tso) {
3179           if (prev == NULL) {
3180             blocked_queue_hd = t->link;
3181             if (blocked_queue_tl == t) {
3182               blocked_queue_tl = END_TSO_QUEUE;
3183             }
3184           } else {
3185             prev->link = t->link;
3186             if (blocked_queue_tl == t) {
3187               blocked_queue_tl = prev;
3188             }
3189           }
3190           goto done;
3191         }
3192       }
3193       barf("unblockThread (I/O): TSO not found");
3194     }
3195
3196   case BlockedOnDelay:
3197     {
3198       StgTSO *prev = NULL;
3199       for (t = sleeping_queue; t != END_TSO_QUEUE;
3200            prev = t, t = t->link) {
3201         if (t == tso) {
3202           if (prev == NULL) {
3203             sleeping_queue = t->link;
3204           } else {
3205             prev->link = t->link;
3206           }
3207           goto done;
3208         }
3209       }
3210       barf("unblockThread (I/O): TSO not found");
3211     }
3212
3213   default:
3214     barf("unblockThread");
3215   }
3216
3217  done:
3218   tso->link = END_TSO_QUEUE;
3219   tso->why_blocked = NotBlocked;
3220   tso->block_info.closure = NULL;
3221   PUSH_ON_RUN_QUEUE(tso);
3222 }
3223 #endif
3224
3225 /* -----------------------------------------------------------------------------
3226  * raiseAsync()
3227  *
3228  * The following function implements the magic for raising an
3229  * asynchronous exception in an existing thread.
3230  *
3231  * We first remove the thread from any queue on which it might be
3232  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
3233  *
3234  * We strip the stack down to the innermost CATCH_FRAME, building
3235  * thunks in the heap for all the active computations, so they can
3236  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
3237  * an application of the handler to the exception, and push it on
3238  * the top of the stack.
3239  *
3240  * How exactly do we save all the active computations?  We create an
3241  * AP_STACK for every UpdateFrame on the stack.  Entering one of these
3242  * AP_STACKs pushes everything from the corresponding update frame
3243  * upwards onto the stack.  (Actually, it pushes everything up to the
3244  * next update frame plus a pointer to the next AP_STACK object.
3245  * Entering the next AP_STACK object pushes more onto the stack until we
3246  * reach the last AP_STACK object - at which point the stack should look
3247  * exactly as it did when we killed the TSO and we can continue
3248  * execution by entering the closure on top of the stack.
3249  *
3250  * We can also kill a thread entirely - this happens if either (a) the
3251  * exception passed to raiseAsync is NULL, or (b) there's no
3252  * CATCH_FRAME on the stack.  In either case, we strip the entire
3253  * stack and replace the thread with a zombie.
3254  *
3255  * Locks: sched_mutex held upon entry nor exit.
3256  *
3257  * -------------------------------------------------------------------------- */
3258
3259 void
3260 deleteThread(StgTSO *tso)
3261 {
3262   raiseAsync(tso,NULL);
3263 }
3264
3265 void
3266 raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
3267 {
3268   /* When raising async exs from contexts where sched_mutex isn't held;
3269      use raiseAsyncWithLock(). */
3270   ACQUIRE_LOCK(&sched_mutex);
3271   raiseAsync(tso,exception);
3272   RELEASE_LOCK(&sched_mutex);
3273 }
3274
3275 void
3276 raiseAsync(StgTSO *tso, StgClosure *exception)
3277 {
3278     StgRetInfoTable *info;
3279     StgPtr sp;
3280
3281     // Thread already dead?
3282     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
3283         return;
3284     }
3285
3286     IF_DEBUG(scheduler,
3287              sched_belch("raising exception in thread %ld.", tso->id));
3288
3289     // Remove it from any blocking queues
3290     unblockThread(tso);
3291
3292     sp = tso->sp;
3293
3294     // The stack freezing code assumes there's a closure pointer on
3295     // the top of the stack, so we have to arrange that this is the case...
3296     //
3297     if (sp[0] == (W_)&stg_enter_info) {
3298         sp++;
3299     } else {
3300         sp--;
3301         sp[0] = (W_)&stg_dummy_ret_closure;
3302     }
3303
3304     while (1) {
3305         nat i;
3306
3307         // 1. Let the top of the stack be the "current closure"
3308         //
3309         // 2. Walk up the stack until we find either an UPDATE_FRAME or a
3310         // CATCH_FRAME.
3311         //
3312         // 3. If it's an UPDATE_FRAME, then make an AP_STACK containing the
3313         // current closure applied to the chunk of stack up to (but not
3314         // including) the update frame.  This closure becomes the "current
3315         // closure".  Go back to step 2.
3316         //
3317         // 4. If it's a CATCH_FRAME, then leave the exception handler on
3318         // top of the stack applied to the exception.
3319         //
3320         // 5. If it's a STOP_FRAME, then kill the thread.
3321
3322         StgPtr frame;
3323
3324         frame = sp + 1;
3325         info = get_ret_itbl((StgClosure *)frame);
3326
3327         while (info->i.type != UPDATE_FRAME
3328                && (info->i.type != CATCH_FRAME || exception == NULL)
3329                && info->i.type != STOP_FRAME) {
3330             frame += stack_frame_sizeW((StgClosure *)frame);
3331             info = get_ret_itbl((StgClosure *)frame);
3332         }
3333
3334         switch (info->i.type) {
3335
3336         case CATCH_FRAME:
3337             // If we find a CATCH_FRAME, and we've got an exception to raise,
3338             // then build the THUNK raise(exception), and leave it on
3339             // top of the CATCH_FRAME ready to enter.
3340             //
3341         {
3342 #ifdef PROFILING
3343             StgCatchFrame *cf = (StgCatchFrame *)frame;
3344 #endif
3345             StgClosure *raise;
3346
3347             // we've got an exception to raise, so let's pass it to the
3348             // handler in this frame.
3349             //
3350             raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
3351             TICK_ALLOC_SE_THK(1,0);
3352             SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
3353             raise->payload[0] = exception;
3354
3355             // throw away the stack from Sp up to the CATCH_FRAME.
3356             //
3357             sp = frame - 1;
3358
3359             /* Ensure that async excpetions are blocked now, so we don't get
3360              * a surprise exception before we get around to executing the
3361              * handler.
3362              */
3363             if (tso->blocked_exceptions == NULL) {
3364                 tso->blocked_exceptions = END_TSO_QUEUE;
3365             }
3366
3367             /* Put the newly-built THUNK on top of the stack, ready to execute
3368              * when the thread restarts.
3369              */
3370             sp[0] = (W_)raise;
3371             sp[-1] = (W_)&stg_enter_info;
3372             tso->sp = sp-1;
3373             tso->what_next = ThreadRunGHC;
3374             IF_DEBUG(sanity, checkTSO(tso));
3375             return;
3376         }
3377
3378         case UPDATE_FRAME:
3379         {
3380             StgAP_STACK * ap;
3381             nat words;
3382
3383             // First build an AP_STACK consisting of the stack chunk above the
3384             // current update frame, with the top word on the stack as the
3385             // fun field.
3386             //
3387             words = frame - sp - 1;
3388             ap = (StgAP_STACK *)allocate(PAP_sizeW(words));
3389
3390             ap->size = words;
3391             ap->fun  = (StgClosure *)sp[0];
3392             sp++;
3393             for(i=0; i < (nat)words; ++i) {
3394                 ap->payload[i] = (StgClosure *)*sp++;
3395             }
3396
3397             SET_HDR(ap,&stg_AP_STACK_info,
3398                     ((StgClosure *)frame)->header.prof.ccs /* ToDo */);
3399             TICK_ALLOC_UP_THK(words+1,0);
3400
3401             IF_DEBUG(scheduler,
3402                      fprintf(stderr,  "scheduler: Updating ");
3403                      printPtr((P_)((StgUpdateFrame *)frame)->updatee);
3404                      fprintf(stderr,  " with ");
3405                      printObj((StgClosure *)ap);
3406                 );
3407
3408             // Replace the updatee with an indirection - happily
3409             // this will also wake up any threads currently
3410             // waiting on the result.
3411             //
3412             // Warning: if we're in a loop, more than one update frame on
3413             // the stack may point to the same object.  Be careful not to
3414             // overwrite an IND_OLDGEN in this case, because we'll screw
3415             // up the mutable lists.  To be on the safe side, don't
3416             // overwrite any kind of indirection at all.  See also
3417             // threadSqueezeStack in GC.c, where we have to make a similar
3418             // check.
3419             //
3420             if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
3421                 // revert the black hole
3422                 UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,ap);
3423             }
3424             sp += sizeofW(StgUpdateFrame) - 1;
3425             sp[0] = (W_)ap; // push onto stack
3426             break;
3427         }
3428
3429         case STOP_FRAME:
3430             // We've stripped the entire stack, the thread is now dead.
3431             sp += sizeofW(StgStopFrame);
3432             tso->what_next = ThreadKilled;
3433             tso->sp = sp;
3434             return;
3435
3436         default:
3437             barf("raiseAsync");
3438         }
3439     }
3440     barf("raiseAsync");
3441 }
3442
3443 /* -----------------------------------------------------------------------------
3444    resurrectThreads is called after garbage collection on the list of
3445    threads found to be garbage.  Each of these threads will be woken
3446    up and sent a signal: BlockedOnDeadMVar if the thread was blocked
3447    on an MVar, or NonTermination if the thread was blocked on a Black
3448    Hole.
3449
3450    Locks: sched_mutex isn't held upon entry nor exit.
3451    -------------------------------------------------------------------------- */
3452
3453 void
3454 resurrectThreads( StgTSO *threads )
3455 {
3456   StgTSO *tso, *next;
3457
3458   for (tso = threads; tso != END_TSO_QUEUE; tso = next) {
3459     next = tso->global_link;
3460     tso->global_link = all_threads;
3461     all_threads = tso;
3462     IF_DEBUG(scheduler, sched_belch("resurrecting thread %d", tso->id));
3463
3464     switch (tso->why_blocked) {
3465     case BlockedOnMVar:
3466     case BlockedOnException:
3467       /* Called by GC - sched_mutex lock is currently held. */
3468       raiseAsync(tso,(StgClosure *)BlockedOnDeadMVar_closure);
3469       break;
3470     case BlockedOnBlackHole:
3471       raiseAsync(tso,(StgClosure *)NonTermination_closure);
3472       break;
3473     case NotBlocked:
3474       /* This might happen if the thread was blocked on a black hole
3475        * belonging to a thread that we've just woken up (raiseAsync
3476        * can wake up threads, remember...).
3477        */
3478       continue;
3479     default:
3480       barf("resurrectThreads: thread blocked in a strange way");
3481     }
3482   }
3483 }
3484
3485 /* -----------------------------------------------------------------------------
3486  * Blackhole detection: if we reach a deadlock, test whether any
3487  * threads are blocked on themselves.  Any threads which are found to
3488  * be self-blocked get sent a NonTermination exception.
3489  *
3490  * This is only done in a deadlock situation in order to avoid
3491  * performance overhead in the normal case.
3492  *
3493  * Locks: sched_mutex is held upon entry and exit.
3494  * -------------------------------------------------------------------------- */
3495
3496 static void
3497 detectBlackHoles( void )
3498 {
3499     StgTSO *tso = all_threads;
3500     StgClosure *frame;
3501     StgClosure *blocked_on;
3502     StgRetInfoTable *info;
3503
3504     for (tso = all_threads; tso != END_TSO_QUEUE; tso = tso->global_link) {
3505
3506         while (tso->what_next == ThreadRelocated) {
3507             tso = tso->link;
3508             ASSERT(get_itbl(tso)->type == TSO);
3509         }
3510
3511         if (tso->why_blocked != BlockedOnBlackHole) {
3512             continue;
3513         }
3514
3515         blocked_on = tso->block_info.closure;
3516
3517         frame = (StgClosure *)tso->sp;
3518
3519         while(1) {
3520             info = get_ret_itbl(frame);
3521             switch (info->i.type) {
3522
3523             case UPDATE_FRAME:
3524                 if (((StgUpdateFrame *)frame)->updatee == blocked_on) {
3525                     /* We are blocking on one of our own computations, so
3526                      * send this thread the NonTermination exception.
3527                      */
3528                     IF_DEBUG(scheduler,
3529                              sched_belch("thread %d is blocked on itself", tso->id));
3530                     raiseAsync(tso, (StgClosure *)NonTermination_closure);
3531                     goto done;
3532                 }
3533
3534                 frame = (StgClosure *) ((StgUpdateFrame *)frame + 1);
3535                 continue;
3536
3537             case STOP_FRAME:
3538                 goto done;
3539
3540                 // normal stack frames; do nothing except advance the pointer
3541             default:
3542                 (StgPtr)frame += stack_frame_sizeW(frame);
3543             }
3544         }
3545         done: ;
3546     }
3547 }
3548
3549 //@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
3550 //@subsection Debugging Routines
3551
3552 /* -----------------------------------------------------------------------------
3553  * Debugging: why is a thread blocked
3554  * [Also provides useful information when debugging threaded programs
3555  *  at the Haskell source code level, so enable outside of DEBUG. --sof 7/02]
3556    -------------------------------------------------------------------------- */
3557
3558 static
3559 void
3560 printThreadBlockage(StgTSO *tso)
3561 {
3562   switch (tso->why_blocked) {
3563   case BlockedOnRead:
3564     fprintf(stderr,"is blocked on read from fd %d", tso->block_info.fd);
3565     break;
3566   case BlockedOnWrite:
3567     fprintf(stderr,"is blocked on write to fd %d", tso->block_info.fd);
3568     break;
3569   case BlockedOnDelay:
3570     fprintf(stderr,"is blocked until %d", tso->block_info.target);
3571     break;
3572   case BlockedOnMVar:
3573     fprintf(stderr,"is blocked on an MVar");
3574     break;
3575   case BlockedOnException:
3576     fprintf(stderr,"is blocked on delivering an exception to thread %d",
3577             tso->block_info.tso->id);
3578     break;
3579   case BlockedOnBlackHole:
3580     fprintf(stderr,"is blocked on a black hole");
3581     break;
3582   case NotBlocked:
3583     fprintf(stderr,"is not blocked");
3584     break;
3585 #if defined(PAR)
3586   case BlockedOnGA:
3587     fprintf(stderr,"is blocked on global address; local FM_BQ is %p (%s)",
3588             tso->block_info.closure, info_type(tso->block_info.closure));
3589     break;
3590   case BlockedOnGA_NoSend:
3591     fprintf(stderr,"is blocked on global address (no send); local FM_BQ is %p (%s)",
3592             tso->block_info.closure, info_type(tso->block_info.closure));
3593     break;
3594 #endif
3595 #if defined(RTS_SUPPORTS_THREADS)
3596   case BlockedOnCCall:
3597     fprintf(stderr,"is blocked on an external call");
3598     break;
3599 #endif
3600   default:
3601     barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
3602          tso->why_blocked, tso->id, tso);
3603   }
3604 }
3605
3606 static
3607 void
3608 printThreadStatus(StgTSO *tso)
3609 {
3610   switch (tso->what_next) {
3611   case ThreadKilled:
3612     fprintf(stderr,"has been killed");
3613     break;
3614   case ThreadComplete:
3615     fprintf(stderr,"has completed");
3616     break;
3617   default:
3618     printThreadBlockage(tso);
3619   }
3620 }
3621
3622 void
3623 printAllThreads(void)
3624 {
3625   StgTSO *t;
3626   void *label;
3627
3628 # if defined(GRAN)
3629   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
3630   ullong_format_string(TIME_ON_PROC(CurrentProc),
3631                        time_string, rtsFalse/*no commas!*/);
3632
3633   fprintf(stderr, "all threads at [%s]:\n", time_string);
3634 # elif defined(PAR)
3635   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
3636   ullong_format_string(CURRENT_TIME,
3637                        time_string, rtsFalse/*no commas!*/);
3638
3639   fprintf(stderr,"all threads at [%s]:\n", time_string);
3640 # else
3641   fprintf(stderr,"all threads:\n");
3642 # endif
3643
3644   for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3645     fprintf(stderr, "\tthread %d @ %p ", t->id, (void *)t);
3646     label = lookupThreadLabel((StgWord)t);
3647     if (label) fprintf(stderr,"[\"%s\"] ",(char *)label);
3648     printThreadStatus(t);
3649     fprintf(stderr,"\n");
3650   }
3651 }
3652
3653 #ifdef DEBUG
3654
3655 /*
3656    Print a whole blocking queue attached to node (debugging only).
3657 */
3658 //@cindex print_bq
3659 # if defined(PAR)
3660 void
3661 print_bq (StgClosure *node)
3662 {
3663   StgBlockingQueueElement *bqe;
3664   StgTSO *tso;
3665   rtsBool end;
3666
3667   fprintf(stderr,"## BQ of closure %p (%s): ",
3668           node, info_type(node));
3669
3670   /* should cover all closures that may have a blocking queue */
3671   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
3672          get_itbl(node)->type == FETCH_ME_BQ ||
3673          get_itbl(node)->type == RBH ||
3674          get_itbl(node)->type == MVAR);
3675
3676   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3677
3678   print_bqe(((StgBlockingQueue*)node)->blocking_queue);
3679 }
3680
3681 /*
3682    Print a whole blocking queue starting with the element bqe.
3683 */
3684 void
3685 print_bqe (StgBlockingQueueElement *bqe)
3686 {
3687   rtsBool end;
3688
3689   /*
3690      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
3691   */
3692   for (end = (bqe==END_BQ_QUEUE);
3693        !end; // iterate until bqe points to a CONSTR
3694        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE),
3695        bqe = end ? END_BQ_QUEUE : bqe->link) {
3696     ASSERT(bqe != END_BQ_QUEUE);                               // sanity check
3697     ASSERT(bqe != (StgBlockingQueueElement *)NULL);            // sanity check
3698     /* types of closures that may appear in a blocking queue */
3699     ASSERT(get_itbl(bqe)->type == TSO ||
3700            get_itbl(bqe)->type == BLOCKED_FETCH ||
3701            get_itbl(bqe)->type == CONSTR);
3702     /* only BQs of an RBH end with an RBH_Save closure */
3703     //ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
3704
3705     switch (get_itbl(bqe)->type) {
3706     case TSO:
3707       fprintf(stderr," TSO %u (%x),",
3708               ((StgTSO *)bqe)->id, ((StgTSO *)bqe));
3709       break;
3710     case BLOCKED_FETCH:
3711       fprintf(stderr," BF (node=%p, ga=((%x, %d, %x)),",
3712               ((StgBlockedFetch *)bqe)->node,
3713               ((StgBlockedFetch *)bqe)->ga.payload.gc.gtid,
3714               ((StgBlockedFetch *)bqe)->ga.payload.gc.slot,
3715               ((StgBlockedFetch *)bqe)->ga.weight);
3716       break;
3717     case CONSTR:
3718       fprintf(stderr," %s (IP %p),",
3719               (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
3720                get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
3721                get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
3722                "RBH_Save_?"), get_itbl(bqe));
3723       break;
3724     default:
3725       barf("Unexpected closure type %s in blocking queue", // of %p (%s)",
3726            info_type((StgClosure *)bqe)); // , node, info_type(node));
3727       break;
3728     }
3729   } /* for */
3730   fputc('\n', stderr);
3731 }
3732 # elif defined(GRAN)
3733 void
3734 print_bq (StgClosure *node)
3735 {
3736   StgBlockingQueueElement *bqe;
3737   PEs node_loc, tso_loc;
3738   rtsBool end;
3739
3740   /* should cover all closures that may have a blocking queue */
3741   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
3742          get_itbl(node)->type == FETCH_ME_BQ ||
3743          get_itbl(node)->type == RBH);
3744
3745   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3746   node_loc = where_is(node);
3747
3748   fprintf(stderr,"## BQ of closure %p (%s) on [PE %d]: ",
3749           node, info_type(node), node_loc);
3750
3751   /*
3752      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
3753   */
3754   for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
3755        !end; // iterate until bqe points to a CONSTR
3756        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
3757     ASSERT(bqe != END_BQ_QUEUE);             // sanity check
3758     ASSERT(bqe != (StgBlockingQueueElement *)NULL);  // sanity check
3759     /* types of closures that may appear in a blocking queue */
3760     ASSERT(get_itbl(bqe)->type == TSO ||
3761            get_itbl(bqe)->type == CONSTR);
3762     /* only BQs of an RBH end with an RBH_Save closure */
3763     ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
3764
3765     tso_loc = where_is((StgClosure *)bqe);
3766     switch (get_itbl(bqe)->type) {
3767     case TSO:
3768       fprintf(stderr," TSO %d (%p) on [PE %d],",
3769               ((StgTSO *)bqe)->id, (StgTSO *)bqe, tso_loc);
3770       break;
3771     case CONSTR:
3772       fprintf(stderr," %s (IP %p),",
3773               (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
3774                get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
3775                get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
3776                "RBH_Save_?"), get_itbl(bqe));
3777       break;
3778     default:
3779       barf("Unexpected closure type %s in blocking queue of %p (%s)",
3780            info_type((StgClosure *)bqe), node, info_type(node));
3781       break;
3782     }
3783   } /* for */
3784   fputc('\n', stderr);
3785 }
3786 #else
3787 /*
3788    Nice and easy: only TSOs on the blocking queue
3789 */
3790 void
3791 print_bq (StgClosure *node)
3792 {
3793   StgTSO *tso;
3794
3795   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3796   for (tso = ((StgBlockingQueue*)node)->blocking_queue;
3797        tso != END_TSO_QUEUE;
3798        tso=tso->link) {
3799     ASSERT(tso!=NULL && tso!=END_TSO_QUEUE);   // sanity check
3800     ASSERT(get_itbl(tso)->type == TSO);  // guess what, sanity check
3801     fprintf(stderr," TSO %d (%p),", tso->id, tso);
3802   }
3803   fputc('\n', stderr);
3804 }
3805 # endif
3806
3807 #if defined(PAR)
3808 static nat
3809 run_queue_len(void)
3810 {
3811   nat i;
3812   StgTSO *tso;
3813
3814   for (i=0, tso=run_queue_hd;
3815        tso != END_TSO_QUEUE;
3816        i++, tso=tso->link)
3817     /* nothing */
3818
3819   return i;
3820 }
3821 #endif
3822
3823 static void
3824 sched_belch(char *s, ...)
3825 {
3826   va_list ap;
3827   va_start(ap,s);
3828 #ifdef SMP
3829   fprintf(stderr, "scheduler (task %ld): ", osThreadId());
3830 #elif defined(PAR)
3831   fprintf(stderr, "== ");
3832 #else
3833   fprintf(stderr, "scheduler: ");
3834 #endif
3835   vfprintf(stderr, s, ap);
3836   fprintf(stderr, "\n");
3837   va_end(ap);
3838 }
3839
3840 #endif /* DEBUG */
3841
3842
3843 //@node Index,  , Debugging Routines, Main scheduling code
3844 //@subsection Index
3845
3846 //@index
3847 //* StgMainThread::  @cindex\s-+StgMainThread
3848 //* awaken_blocked_queue::  @cindex\s-+awaken_blocked_queue
3849 //* blocked_queue_hd::  @cindex\s-+blocked_queue_hd
3850 //* blocked_queue_tl::  @cindex\s-+blocked_queue_tl
3851 //* context_switch::  @cindex\s-+context_switch
3852 //* createThread::  @cindex\s-+createThread
3853 //* gc_pending_cond::  @cindex\s-+gc_pending_cond
3854 //* initScheduler::  @cindex\s-+initScheduler
3855 //* interrupted::  @cindex\s-+interrupted
3856 //* next_thread_id::  @cindex\s-+next_thread_id
3857 //* print_bq::  @cindex\s-+print_bq
3858 //* run_queue_hd::  @cindex\s-+run_queue_hd
3859 //* run_queue_tl::  @cindex\s-+run_queue_tl
3860 //* sched_mutex::  @cindex\s-+sched_mutex
3861 //* schedule::  @cindex\s-+schedule
3862 //* take_off_run_queue::  @cindex\s-+take_off_run_queue
3863 //* term_mutex::  @cindex\s-+term_mutex
3864 //@end index