ghc/rts/Schedule.c

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