ghc/rts/Schedule.c

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