ghc/rts/Schedule.c

   1 /* ---------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.150 2002/07/19 18:45:21 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 doKill;
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; if there isn't,
1463      the Scheduler will shutdown next time it is entered.
1464
1465      ==> we don't kill a thread that's on the main_threads
1466          list (nor the current thread.)
1467
1468      [ Attempts at implementing the more ambitious scheme of
1469        killing the main_threads also, and then adding the
1470        current thread onto the main_threads list if it wasn't
1471        there already, failed -- waitThread() (for one) wasn't
1472        up to it. If it proves to be desirable to also kill
1473        the main threads, then this scheme will have to be
1474        revisited (and fully debugged!)
1475
1476        -- sof 7/2002
1477      ]
1478   */
1479   /* DO NOT TOUCH THE QUEUES directly because most of the code around
1480      us is picky about finding the thread still in its queue when
1481      handling the deleteThread() */
1482
1483   for (t = all_threads; t != END_TSO_QUEUE; t = next) {
1484     next = t->link;
1485
1486     /* Don't kill the current thread.. */
1487     if (t->id == tso->id) continue;
1488     doKill=rtsTrue;
1489     /* ..or a main thread */
1490     for (m = main_threads; m != NULL; m = m->link) {
1491         if (m->tso->id == t->id) {
1492           doKill=rtsFalse;
1493           break;
1494         }
1495     }
1496     if (doKill) {
1497       deleteThread(t);
1498     }
1499   }
1500   }
1501   return pid;
1502 #else /* mingw32 */
1503   barf("forkProcess#: primop not implemented for mingw32, sorry! (%u)\n", tso->id);
1504   /* pointlessly printing out the TSOs 'id' to avoid CC unused warning. */
1505   return -1;
1506 #endif /* mingw32 */
1507 }
1508
1509 /* ---------------------------------------------------------------------------
1510  * deleteAllThreads():  kill all the live threads.
1511  *
1512  * This is used when we catch a user interrupt (^C), before performing
1513  * any necessary cleanups and running finalizers.
1514  *
1515  * Locks: sched_mutex held.
1516  * ------------------------------------------------------------------------- */
1517
1518 void deleteAllThreads ( void )
1519 {
1520   StgTSO* t, *next;
1521   IF_DEBUG(scheduler,sched_belch("deleting all threads"));
1522   for (t = all_threads; t != END_TSO_QUEUE; t = next) {
1523       next = t->global_link;
1524       deleteThread(t);
1525   }
1526   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
1527   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
1528   sleeping_queue = END_TSO_QUEUE;
1529 }
1530
1531 /* startThread and  insertThread are now in GranSim.c -- HWL */
1532
1533
1534 //@node Suspend and Resume, Run queue code, Main scheduling loop, Main scheduling code
1535 //@subsection Suspend and Resume
1536
1537 /* ---------------------------------------------------------------------------
1538  * Suspending & resuming Haskell threads.
1539  *
1540  * When making a "safe" call to C (aka _ccall_GC), the task gives back
1541  * its capability before calling the C function.  This allows another
1542  * task to pick up the capability and carry on running Haskell
1543  * threads.  It also means that if the C call blocks, it won't lock
1544  * the whole system.
1545  *
1546  * The Haskell thread making the C call is put to sleep for the
1547  * duration of the call, on the susepended_ccalling_threads queue.  We
1548  * give out a token to the task, which it can use to resume the thread
1549  * on return from the C function.
1550  * ------------------------------------------------------------------------- */
1551
1552 StgInt
1553 suspendThread( StgRegTable *reg,
1554                rtsBool concCall
1555 #if !defined(RTS_SUPPORTS_THREADS) && !defined(DEBUG)
1556                STG_UNUSED
1557 #endif
1558                )
1559 {
1560   nat tok;
1561   Capability *cap;
1562
1563   /* assume that *reg is a pointer to the StgRegTable part
1564    * of a Capability.
1565    */
1566   cap = (Capability *)((void *)reg - sizeof(StgFunTable));
1567
1568   ACQUIRE_LOCK(&sched_mutex);
1569
1570   IF_DEBUG(scheduler,
1571            sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
1572
1573   threadPaused(cap->r.rCurrentTSO);
1574   cap->r.rCurrentTSO->link = suspended_ccalling_threads;
1575   suspended_ccalling_threads = cap->r.rCurrentTSO;
1576
1577 #if defined(RTS_SUPPORTS_THREADS)
1578   cap->r.rCurrentTSO->why_blocked  = BlockedOnCCall;
1579 #endif
1580
1581   /* Use the thread ID as the token; it should be unique */
1582   tok = cap->r.rCurrentTSO->id;
1583
1584   /* Hand back capability */
1585   releaseCapability(cap);
1586
1587 #if defined(RTS_SUPPORTS_THREADS)
1588   /* Preparing to leave the RTS, so ensure there's a native thread/task
1589      waiting to take over.
1590
1591      ToDo: optimise this and only create a new task if there's a need
1592      for one (i.e., if there's only one Concurrent Haskell thread alive,
1593      there's no need to create a new task).
1594   */
1595   IF_DEBUG(scheduler, sched_belch("worker thread (%d): leaving RTS", tok));
1596   if (concCall) {
1597     startTask(taskStart);
1598   }
1599 #endif
1600
1601   /* Other threads _might_ be available for execution; signal this */
1602   THREAD_RUNNABLE();
1603   RELEASE_LOCK(&sched_mutex);
1604   return tok;
1605 }
1606
1607 StgRegTable *
1608 resumeThread( StgInt tok,
1609               rtsBool concCall
1610 #if !defined(RTS_SUPPORTS_THREADS)
1611                STG_UNUSED
1612 #endif
1613               )
1614 {
1615   StgTSO *tso, **prev;
1616   Capability *cap;
1617
1618 #if defined(RTS_SUPPORTS_THREADS)
1619   /* Wait for permission to re-enter the RTS with the result. */
1620   if ( concCall ) {
1621     ACQUIRE_LOCK(&sched_mutex);
1622     grabReturnCapability(&sched_mutex, &cap);
1623   } else {
1624     grabCapability(&cap);
1625   }
1626 #else
1627   grabCapability(&cap);
1628 #endif
1629
1630   /* Remove the thread off of the suspended list */
1631   prev = &suspended_ccalling_threads;
1632   for (tso = suspended_ccalling_threads;
1633        tso != END_TSO_QUEUE;
1634        prev = &tso->link, tso = tso->link) {
1635     if (tso->id == (StgThreadID)tok) {
1636       *prev = tso->link;
1637       break;
1638     }
1639   }
1640   if (tso == END_TSO_QUEUE) {
1641     barf("resumeThread: thread not found");
1642   }
1643   tso->link = END_TSO_QUEUE;
1644   /* Reset blocking status */
1645   tso->why_blocked  = NotBlocked;
1646
1647   cap->r.rCurrentTSO = tso;
1648   RELEASE_LOCK(&sched_mutex);
1649   return &cap->r;
1650 }
1651
1652
1653 /* ---------------------------------------------------------------------------
1654  * Static functions
1655  * ------------------------------------------------------------------------ */
1656 static void unblockThread(StgTSO *tso);
1657
1658 /* ---------------------------------------------------------------------------
1659  * Comparing Thread ids.
1660  *
1661  * This is used from STG land in the implementation of the
1662  * instances of Eq/Ord for ThreadIds.
1663  * ------------------------------------------------------------------------ */
1664
1665 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
1666 {
1667   StgThreadID id1 = tso1->id;
1668   StgThreadID id2 = tso2->id;
1669
1670   if (id1 < id2) return (-1);
1671   if (id1 > id2) return 1;
1672   return 0;
1673 }
1674
1675 /* ---------------------------------------------------------------------------
1676  * Fetching the ThreadID from an StgTSO.
1677  *
1678  * This is used in the implementation of Show for ThreadIds.
1679  * ------------------------------------------------------------------------ */
1680 int rts_getThreadId(const StgTSO *tso)
1681 {
1682   return tso->id;
1683 }
1684
1685 #ifdef DEBUG
1686 void labelThread(StgTSO *tso, char *label)
1687 {
1688   int len;
1689   void *buf;
1690
1691   /* Caveat: Once set, you can only set the thread name to "" */
1692   len = strlen(label)+1;
1693   buf = malloc(len);
1694   if (buf == NULL) {
1695     fprintf(stderr,"insufficient memory for labelThread!\n");
1696   } else
1697     strncpy(buf,label,len);
1698   /* Update will free the old memory for us */
1699   updateThreadLabel((StgWord)tso,buf);
1700 }
1701 #endif /* DEBUG */
1702
1703 /* ---------------------------------------------------------------------------
1704    Create a new thread.
1705
1706    The new thread starts with the given stack size.  Before the
1707    scheduler can run, however, this thread needs to have a closure
1708    (and possibly some arguments) pushed on its stack.  See
1709    pushClosure() in Schedule.h.
1710
1711    createGenThread() and createIOThread() (in SchedAPI.h) are
1712    convenient packaged versions of this function.
1713
1714    currently pri (priority) is only used in a GRAN setup -- HWL
1715    ------------------------------------------------------------------------ */
1716 //@cindex createThread
1717 #if defined(GRAN)
1718 /*   currently pri (priority) is only used in a GRAN setup -- HWL */
1719 StgTSO *
1720 createThread(nat size, StgInt pri)
1721 #else
1722 StgTSO *
1723 createThread(nat size)
1724 #endif
1725 {
1726
1727     StgTSO *tso;
1728     nat stack_size;
1729
1730     /* First check whether we should create a thread at all */
1731 #if defined(PAR)
1732   /* check that no more than RtsFlags.ParFlags.maxThreads threads are created */
1733   if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads) {
1734     threadsIgnored++;
1735     belch("{createThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
1736           RtsFlags.ParFlags.maxThreads, advisory_thread_count);
1737     return END_TSO_QUEUE;
1738   }
1739   threadsCreated++;
1740 #endif
1741
1742 #if defined(GRAN)
1743   ASSERT(!RtsFlags.GranFlags.Light || CurrentProc==0);
1744 #endif
1745
1746   // ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW
1747
1748   /* catch ridiculously small stack sizes */
1749   if (size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
1750     size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
1751   }
1752
1753   stack_size = size - TSO_STRUCT_SIZEW;
1754
1755   tso = (StgTSO *)allocate(size);
1756   TICK_ALLOC_TSO(stack_size, 0);
1757
1758   SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
1759 #if defined(GRAN)
1760   SET_GRAN_HDR(tso, ThisPE);
1761 #endif
1762   tso->what_next     = ThreadEnterGHC;
1763
1764   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
1765    * protect the increment operation on next_thread_id.
1766    * In future, we could use an atomic increment instead.
1767    */
1768   ACQUIRE_LOCK(&thread_id_mutex);
1769   tso->id = next_thread_id++;
1770   RELEASE_LOCK(&thread_id_mutex);
1771
1772   tso->why_blocked  = NotBlocked;
1773   tso->blocked_exceptions = NULL;
1774
1775   tso->stack_size   = stack_size;
1776   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
1777                               - TSO_STRUCT_SIZEW;
1778   tso->sp           = (P_)&(tso->stack) + stack_size;
1779
1780 #ifdef PROFILING
1781   tso->prof.CCCS = CCS_MAIN;
1782 #endif
1783
1784   /* put a stop frame on the stack */
1785   tso->sp -= sizeofW(StgStopFrame);
1786   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
1787   tso->su = (StgUpdateFrame*)tso->sp;
1788
1789   // ToDo: check this
1790 #if defined(GRAN)
1791   tso->link = END_TSO_QUEUE;
1792   /* uses more flexible routine in GranSim */
1793   insertThread(tso, CurrentProc);
1794 #else
1795   /* In a non-GranSim setup the pushing of a TSO onto the runq is separated
1796    * from its creation
1797    */
1798 #endif
1799
1800 #if defined(GRAN)
1801   if (RtsFlags.GranFlags.GranSimStats.Full)
1802     DumpGranEvent(GR_START,tso);
1803 #elif defined(PAR)
1804   if (RtsFlags.ParFlags.ParStats.Full)
1805     DumpGranEvent(GR_STARTQ,tso);
1806   /* HACk to avoid SCHEDULE
1807      LastTSO = tso; */
1808 #endif
1809
1810   /* Link the new thread on the global thread list.
1811    */
1812   tso->global_link = all_threads;
1813   all_threads = tso;
1814
1815 #if defined(DIST)
1816   tso->dist.priority = MandatoryPriority; //by default that is...
1817 #endif
1818
1819 #if defined(GRAN)
1820   tso->gran.pri = pri;
1821 # if defined(DEBUG)
1822   tso->gran.magic = TSO_MAGIC; // debugging only
1823 # endif
1824   tso->gran.sparkname   = 0;
1825   tso->gran.startedat   = CURRENT_TIME;
1826   tso->gran.exported    = 0;
1827   tso->gran.basicblocks = 0;
1828   tso->gran.allocs      = 0;
1829   tso->gran.exectime    = 0;
1830   tso->gran.fetchtime   = 0;
1831   tso->gran.fetchcount  = 0;
1832   tso->gran.blocktime   = 0;
1833   tso->gran.blockcount  = 0;
1834   tso->gran.blockedat   = 0;
1835   tso->gran.globalsparks = 0;
1836   tso->gran.localsparks  = 0;
1837   if (RtsFlags.GranFlags.Light)
1838     tso->gran.clock  = Now; /* local clock */
1839   else
1840     tso->gran.clock  = 0;
1841
1842   IF_DEBUG(gran,printTSO(tso));
1843 #elif defined(PAR)
1844 # if defined(DEBUG)
1845   tso->par.magic = TSO_MAGIC; // debugging only
1846 # endif
1847   tso->par.sparkname   = 0;
1848   tso->par.startedat   = CURRENT_TIME;
1849   tso->par.exported    = 0;
1850   tso->par.basicblocks = 0;
1851   tso->par.allocs      = 0;
1852   tso->par.exectime    = 0;
1853   tso->par.fetchtime   = 0;
1854   tso->par.fetchcount  = 0;
1855   tso->par.blocktime   = 0;
1856   tso->par.blockcount  = 0;
1857   tso->par.blockedat   = 0;
1858   tso->par.globalsparks = 0;
1859   tso->par.localsparks  = 0;
1860 #endif
1861
1862 #if defined(GRAN)
1863   globalGranStats.tot_threads_created++;
1864   globalGranStats.threads_created_on_PE[CurrentProc]++;
1865   globalGranStats.tot_sq_len += spark_queue_len(CurrentProc);
1866   globalGranStats.tot_sq_probes++;
1867 #elif defined(PAR)
1868   // collect parallel global statistics (currently done together with GC stats)
1869   if (RtsFlags.ParFlags.ParStats.Global &&
1870       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
1871     //fprintf(stderr, "Creating thread %d @ %11.2f\n", tso->id, usertime());
1872     globalParStats.tot_threads_created++;
1873   }
1874 #endif
1875
1876 #if defined(GRAN)
1877   IF_GRAN_DEBUG(pri,
1878                 belch("==__ schedule: Created TSO %d (%p);",
1879                       CurrentProc, tso, tso->id));
1880 #elif defined(PAR)
1881     IF_PAR_DEBUG(verbose,
1882                  belch("==__ schedule: Created TSO %d (%p); %d threads active",
1883                        tso->id, tso, advisory_thread_count));
1884 #else
1885   IF_DEBUG(scheduler,sched_belch("created thread %ld, stack size = %lx words",
1886                                  tso->id, tso->stack_size));
1887 #endif
1888   return tso;
1889 }
1890
1891 #if defined(PAR)
1892 /* RFP:
1893    all parallel thread creation calls should fall through the following routine.
1894 */
1895 StgTSO *
1896 createSparkThread(rtsSpark spark)
1897 { StgTSO *tso;
1898   ASSERT(spark != (rtsSpark)NULL);
1899   if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads)
1900   { threadsIgnored++;
1901     barf("{createSparkThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
1902           RtsFlags.ParFlags.maxThreads, advisory_thread_count);
1903     return END_TSO_QUEUE;
1904   }
1905   else
1906   { threadsCreated++;
1907     tso = createThread(RtsFlags.GcFlags.initialStkSize);
1908     if (tso==END_TSO_QUEUE)
1909       barf("createSparkThread: Cannot create TSO");
1910 #if defined(DIST)
1911     tso->priority = AdvisoryPriority;
1912 #endif
1913     pushClosure(tso,spark);
1914     PUSH_ON_RUN_QUEUE(tso);
1915     advisory_thread_count++;
1916   }
1917   return tso;
1918 }
1919 #endif
1920
1921 /*
1922   Turn a spark into a thread.
1923   ToDo: fix for SMP (needs to acquire SCHED_MUTEX!)
1924 */
1925 #if defined(PAR)
1926 //@cindex activateSpark
1927 StgTSO *
1928 activateSpark (rtsSpark spark)
1929 {
1930   StgTSO *tso;
1931
1932   tso = createSparkThread(spark);
1933   if (RtsFlags.ParFlags.ParStats.Full) {
1934     //ASSERT(run_queue_hd == END_TSO_QUEUE); // I think ...
1935     IF_PAR_DEBUG(verbose,
1936                  belch("==^^ activateSpark: turning spark of closure %p (%s) into a thread",
1937                        (StgClosure *)spark, info_type((StgClosure *)spark)));
1938   }
1939   // ToDo: fwd info on local/global spark to thread -- HWL
1940   // tso->gran.exported =  spark->exported;
1941   // tso->gran.locked =   !spark->global;
1942   // tso->gran.sparkname = spark->name;
1943
1944   return tso;
1945 }
1946 #endif
1947
1948 static SchedulerStatus waitThread_(/*out*/StgMainThread* m
1949 #if defined(THREADED_RTS)
1950                                    , rtsBool blockWaiting
1951 #endif
1952                                    );
1953
1954
1955 /* ---------------------------------------------------------------------------
1956  * scheduleThread()
1957  *
1958  * scheduleThread puts a thread on the head of the runnable queue.
1959  * This will usually be done immediately after a thread is created.
1960  * The caller of scheduleThread must create the thread using e.g.
1961  * createThread and push an appropriate closure
1962  * on this thread's stack before the scheduler is invoked.
1963  * ------------------------------------------------------------------------ */
1964
1965 static void scheduleThread_ (StgTSO* tso, rtsBool createTask);
1966
1967 void
1968 scheduleThread_(StgTSO *tso
1969                , rtsBool createTask
1970 #if !defined(THREADED_RTS)
1971                  STG_UNUSED
1972 #endif
1973               )
1974 {
1975   ACQUIRE_LOCK(&sched_mutex);
1976
1977   /* Put the new thread on the head of the runnable queue.  The caller
1978    * better push an appropriate closure on this thread's stack
1979    * beforehand.  In the SMP case, the thread may start running as
1980    * soon as we release the scheduler lock below.
1981    */
1982   PUSH_ON_RUN_QUEUE(tso);
1983 #if defined(THREADED_RTS)
1984   /* If main() is scheduling a thread, don't bother creating a
1985    * new task.
1986    */
1987   if ( createTask ) {
1988     startTask(taskStart);
1989   }
1990 #endif
1991   THREAD_RUNNABLE();
1992
1993 #if 0
1994   IF_DEBUG(scheduler,printTSO(tso));
1995 #endif
1996   RELEASE_LOCK(&sched_mutex);
1997 }
1998
1999 void scheduleThread(StgTSO* tso)
2000 {
2001   scheduleThread_(tso, rtsFalse);
2002 }
2003
2004 SchedulerStatus
2005 scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret)
2006 {
2007   StgMainThread *m;
2008
2009   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
2010   m->tso = tso;
2011   m->ret = ret;
2012   m->stat = NoStatus;
2013 #if defined(RTS_SUPPORTS_THREADS)
2014   initCondition(&m->wakeup);
2015 #endif
2016
2017   /* Put the thread on the main-threads list prior to scheduling the TSO.
2018      Failure to do so introduces a race condition in the MT case (as
2019      identified by Wolfgang Thaller), whereby the new task/OS thread
2020      created by scheduleThread_() would complete prior to the thread
2021      that spawned it managed to put 'itself' on the main-threads list.
2022      The upshot of it all being that the worker thread wouldn't get to
2023      signal the completion of the its work item for the main thread to
2024      see (==> it got stuck waiting.)    -- sof 6/02.
2025   */
2026   ACQUIRE_LOCK(&sched_mutex);
2027   IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
2028
2029   m->link = main_threads;
2030   main_threads = m;
2031
2032   /* Inefficient (scheduleThread_() acquires it again right away),
2033    * but obviously correct.
2034    */
2035   RELEASE_LOCK(&sched_mutex);
2036
2037   scheduleThread_(tso, rtsTrue);
2038 #if defined(THREADED_RTS)
2039   return waitThread_(m, rtsTrue);
2040 #else
2041   return waitThread_(m);
2042 #endif
2043 }
2044
2045 /* ---------------------------------------------------------------------------
2046  * initScheduler()
2047  *
2048  * Initialise the scheduler.  This resets all the queues - if the
2049  * queues contained any threads, they'll be garbage collected at the
2050  * next pass.
2051  *
2052  * ------------------------------------------------------------------------ */
2053
2054 #ifdef SMP
2055 static void
2056 term_handler(int sig STG_UNUSED)
2057 {
2058   stat_workerStop();
2059   ACQUIRE_LOCK(&term_mutex);
2060   await_death--;
2061   RELEASE_LOCK(&term_mutex);
2062   shutdownThread();
2063 }
2064 #endif
2065
2066 void
2067 initScheduler(void)
2068 {
2069 #if defined(GRAN)
2070   nat i;
2071
2072   for (i=0; i<=MAX_PROC; i++) {
2073     run_queue_hds[i]      = END_TSO_QUEUE;
2074     run_queue_tls[i]      = END_TSO_QUEUE;
2075     blocked_queue_hds[i]  = END_TSO_QUEUE;
2076     blocked_queue_tls[i]  = END_TSO_QUEUE;
2077     ccalling_threadss[i]  = END_TSO_QUEUE;
2078     sleeping_queue        = END_TSO_QUEUE;
2079   }
2080 #else
2081   run_queue_hd      = END_TSO_QUEUE;
2082   run_queue_tl      = END_TSO_QUEUE;
2083   blocked_queue_hd  = END_TSO_QUEUE;
2084   blocked_queue_tl  = END_TSO_QUEUE;
2085   sleeping_queue    = END_TSO_QUEUE;
2086 #endif
2087
2088   suspended_ccalling_threads  = END_TSO_QUEUE;
2089
2090   main_threads = NULL;
2091   all_threads  = END_TSO_QUEUE;
2092
2093   context_switch = 0;
2094   interrupted    = 0;
2095
2096   RtsFlags.ConcFlags.ctxtSwitchTicks =
2097       RtsFlags.ConcFlags.ctxtSwitchTime / TICK_MILLISECS;
2098
2099 #if defined(RTS_SUPPORTS_THREADS)
2100   /* Initialise the mutex and condition variables used by
2101    * the scheduler. */
2102   initMutex(&sched_mutex);
2103   initMutex(&term_mutex);
2104   initMutex(&thread_id_mutex);
2105
2106   initCondition(&thread_ready_cond);
2107 #endif
2108
2109 #if defined(SMP)
2110   initCondition(&gc_pending_cond);
2111 #endif
2112
2113 #if defined(RTS_SUPPORTS_THREADS)
2114   ACQUIRE_LOCK(&sched_mutex);
2115 #endif
2116
2117   /* Install the SIGHUP handler */
2118 #if defined(SMP)
2119   {
2120     struct sigaction action,oact;
2121
2122     action.sa_handler = term_handler;
2123     sigemptyset(&action.sa_mask);
2124     action.sa_flags = 0;
2125     if (sigaction(SIGTERM, &action, &oact) != 0) {
2126       barf("can't install TERM handler");
2127     }
2128   }
2129 #endif
2130
2131   /* A capability holds the state a native thread needs in
2132    * order to execute STG code. At least one capability is
2133    * floating around (only SMP builds have more than one).
2134    */
2135   initCapabilities();
2136
2137 #if defined(RTS_SUPPORTS_THREADS)
2138     /* start our haskell execution tasks */
2139 # if defined(SMP)
2140     startTaskManager(RtsFlags.ParFlags.nNodes, taskStart);
2141 # else
2142     startTaskManager(0,taskStart);
2143 # endif
2144 #endif
2145
2146 #if /* defined(SMP) ||*/ defined(PAR)
2147   initSparkPools();
2148 #endif
2149
2150 #if defined(RTS_SUPPORTS_THREADS)
2151   RELEASE_LOCK(&sched_mutex);
2152 #endif
2153
2154 }
2155
2156 void
2157 exitScheduler( void )
2158 {
2159 #if defined(RTS_SUPPORTS_THREADS)
2160   stopTaskManager();
2161 #endif
2162   shutting_down_scheduler = rtsTrue;
2163 }
2164
2165 /* -----------------------------------------------------------------------------
2166    Managing the per-task allocation areas.
2167
2168    Each capability comes with an allocation area.  These are
2169    fixed-length block lists into which allocation can be done.
2170
2171    ToDo: no support for two-space collection at the moment???
2172    -------------------------------------------------------------------------- */
2173
2174 /* -----------------------------------------------------------------------------
2175  * waitThread is the external interface for running a new computation
2176  * and waiting for the result.
2177  *
2178  * In the non-SMP case, we create a new main thread, push it on the
2179  * main-thread stack, and invoke the scheduler to run it.  The
2180  * scheduler will return when the top main thread on the stack has
2181  * completed or died, and fill in the necessary fields of the
2182  * main_thread structure.
2183  *
2184  * In the SMP case, we create a main thread as before, but we then
2185  * create a new condition variable and sleep on it.  When our new
2186  * main thread has completed, we'll be woken up and the status/result
2187  * will be in the main_thread struct.
2188  * -------------------------------------------------------------------------- */
2189
2190 int
2191 howManyThreadsAvail ( void )
2192 {
2193    int i = 0;
2194    StgTSO* q;
2195    for (q = run_queue_hd; q != END_TSO_QUEUE; q = q->link)
2196       i++;
2197    for (q = blocked_queue_hd; q != END_TSO_QUEUE; q = q->link)
2198       i++;
2199    for (q = sleeping_queue; q != END_TSO_QUEUE; q = q->link)
2200       i++;
2201    return i;
2202 }
2203
2204 void
2205 finishAllThreads ( void )
2206 {
2207    do {
2208       while (run_queue_hd != END_TSO_QUEUE) {
2209          waitThread ( run_queue_hd, NULL);
2210       }
2211       while (blocked_queue_hd != END_TSO_QUEUE) {
2212          waitThread ( blocked_queue_hd, NULL);
2213       }
2214       while (sleeping_queue != END_TSO_QUEUE) {
2215          waitThread ( blocked_queue_hd, NULL);
2216       }
2217    } while
2218       (blocked_queue_hd != END_TSO_QUEUE ||
2219        run_queue_hd     != END_TSO_QUEUE ||
2220        sleeping_queue   != END_TSO_QUEUE);
2221 }
2222
2223 SchedulerStatus
2224 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
2225 {
2226   StgMainThread *m;
2227
2228   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
2229   m->tso = tso;
2230   m->ret = ret;
2231   m->stat = NoStatus;
2232 #if defined(RTS_SUPPORTS_THREADS)
2233   initCondition(&m->wakeup);
2234 #endif
2235
2236   /* see scheduleWaitThread() comment */
2237   ACQUIRE_LOCK(&sched_mutex);
2238   IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
2239   m->link = main_threads;
2240   main_threads = m;
2241   RELEASE_LOCK(&sched_mutex);
2242
2243   IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
2244 #if defined(THREADED_RTS)
2245   return waitThread_(m, rtsFalse);
2246 #else
2247   return waitThread_(m);
2248 #endif
2249 }
2250
2251 static
2252 SchedulerStatus
2253 waitThread_(StgMainThread* m
2254 #if defined(THREADED_RTS)
2255             , rtsBool blockWaiting
2256 #endif
2257            )
2258 {
2259   SchedulerStatus stat;
2260
2261   IF_DEBUG(scheduler, sched_belch("== scheduler: new main thread (%d)\n", m->tso->id));
2262
2263 #if defined(RTS_SUPPORTS_THREADS)
2264
2265 # if defined(THREADED_RTS)
2266   if (!blockWaiting) {
2267     /* In the threaded case, the OS thread that called main()
2268      * gets to enter the RTS directly without going via another
2269      * task/thread.
2270      */
2271     schedule();
2272     ASSERT(m->stat != NoStatus);
2273   } else
2274 # endif
2275   {
2276     ACQUIRE_LOCK(&sched_mutex);
2277     do {
2278       waitCondition(&m->wakeup, &sched_mutex);
2279     } while (m->stat == NoStatus);
2280   }
2281 #elif defined(GRAN)
2282   /* GranSim specific init */
2283   CurrentTSO = m->tso;                // the TSO to run
2284   procStatus[MainProc] = Busy;        // status of main PE
2285   CurrentProc = MainProc;             // PE to run it on
2286
2287   schedule();
2288 #else
2289   RELEASE_LOCK(&sched_mutex);
2290   schedule();
2291   ASSERT(m->stat != NoStatus);
2292 #endif
2293
2294   stat = m->stat;
2295
2296 #if defined(RTS_SUPPORTS_THREADS)
2297   closeCondition(&m->wakeup);
2298 #endif
2299
2300   IF_DEBUG(scheduler, fprintf(stderr, "== scheduler: main thread (%d) finished\n",
2301                               m->tso->id));
2302   free(m);
2303
2304 #if defined(THREADED_RTS)
2305   if (blockWaiting)
2306 #endif
2307     RELEASE_LOCK(&sched_mutex);
2308
2309   return stat;
2310 }
2311
2312 //@node Run queue code, Garbage Collextion Routines, Suspend and Resume, Main scheduling code
2313 //@subsection Run queue code
2314
2315 #if 0
2316 /*
2317    NB: In GranSim we have many run queues; run_queue_hd is actually a macro
2318        unfolding to run_queue_hds[CurrentProc], thus CurrentProc is an
2319        implicit global variable that has to be correct when calling these
2320        fcts -- HWL
2321 */
2322
2323 /* Put the new thread on the head of the runnable queue.
2324  * The caller of createThread better push an appropriate closure
2325  * on this thread's stack before the scheduler is invoked.
2326  */
2327 static /* inline */ void
2328 add_to_run_queue(tso)
2329 StgTSO* tso;
2330 {
2331   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
2332   tso->link = run_queue_hd;
2333   run_queue_hd = tso;
2334   if (run_queue_tl == END_TSO_QUEUE) {
2335     run_queue_tl = tso;
2336   }
2337 }
2338
2339 /* Put the new thread at the end of the runnable queue. */
2340 static /* inline */ void
2341 push_on_run_queue(tso)
2342 StgTSO* tso;
2343 {
2344   ASSERT(get_itbl((StgClosure *)tso)->type == TSO);
2345   ASSERT(run_queue_hd!=NULL && run_queue_tl!=NULL);
2346   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
2347   if (run_queue_hd == END_TSO_QUEUE) {
2348     run_queue_hd = tso;
2349   } else {
2350     run_queue_tl->link = tso;
2351   }
2352   run_queue_tl = tso;
2353 }
2354
2355 /*
2356    Should be inlined because it's used very often in schedule.  The tso
2357    argument is actually only needed in GranSim, where we want to have the
2358    possibility to schedule *any* TSO on the run queue, irrespective of the
2359    actual ordering. Therefore, if tso is not the nil TSO then we traverse
2360    the run queue and dequeue the tso, adjusting the links in the queue.
2361 */
2362 //@cindex take_off_run_queue
2363 static /* inline */ StgTSO*
2364 take_off_run_queue(StgTSO *tso) {
2365   StgTSO *t, *prev;
2366
2367   /*
2368      qetlaHbogh Qu' ngaSbogh ghomDaQ {tso} yIteq!
2369
2370      if tso is specified, unlink that tso from the run_queue (doesn't have
2371      to be at the beginning of the queue); GranSim only
2372   */
2373   if (tso!=END_TSO_QUEUE) {
2374     /* find tso in queue */
2375     for (t=run_queue_hd, prev=END_TSO_QUEUE;
2376          t!=END_TSO_QUEUE && t!=tso;
2377          prev=t, t=t->link)
2378       /* nothing */ ;
2379     ASSERT(t==tso);
2380     /* now actually dequeue the tso */
2381     if (prev!=END_TSO_QUEUE) {
2382       ASSERT(run_queue_hd!=t);
2383       prev->link = t->link;
2384     } else {
2385       /* t is at beginning of thread queue */
2386       ASSERT(run_queue_hd==t);
2387       run_queue_hd = t->link;
2388     }
2389     /* t is at end of thread queue */
2390     if (t->link==END_TSO_QUEUE) {
2391       ASSERT(t==run_queue_tl);
2392       run_queue_tl = prev;
2393     } else {
2394       ASSERT(run_queue_tl!=t);
2395     }
2396     t->link = END_TSO_QUEUE;
2397   } else {
2398     /* take tso from the beginning of the queue; std concurrent code */
2399     t = run_queue_hd;
2400     if (t != END_TSO_QUEUE) {
2401       run_queue_hd = t->link;
2402       t->link = END_TSO_QUEUE;
2403       if (run_queue_hd == END_TSO_QUEUE) {
2404         run_queue_tl = END_TSO_QUEUE;
2405       }
2406     }
2407   }
2408   return t;
2409 }
2410
2411 #endif /* 0 */
2412
2413 //@node Garbage Collextion Routines, Blocking Queue Routines, Run queue code, Main scheduling code
2414 //@subsection Garbage Collextion Routines
2415
2416 /* ---------------------------------------------------------------------------
2417    Where are the roots that we know about?
2418
2419         - all the threads on the runnable queue
2420         - all the threads on the blocked queue
2421         - all the threads on the sleeping queue
2422         - all the thread currently executing a _ccall_GC
2423         - all the "main threads"
2424
2425    ------------------------------------------------------------------------ */
2426
2427 /* This has to be protected either by the scheduler monitor, or by the
2428         garbage collection monitor (probably the latter).
2429         KH @ 25/10/99
2430 */
2431
2432 void
2433 GetRoots(evac_fn evac)
2434 {
2435 #if defined(GRAN)
2436   {
2437     nat i;
2438     for (i=0; i<=RtsFlags.GranFlags.proc; i++) {
2439       if ((run_queue_hds[i] != END_TSO_QUEUE) && ((run_queue_hds[i] != NULL)))
2440           evac((StgClosure **)&run_queue_hds[i]);
2441       if ((run_queue_tls[i] != END_TSO_QUEUE) && ((run_queue_tls[i] != NULL)))
2442           evac((StgClosure **)&run_queue_tls[i]);
2443
2444       if ((blocked_queue_hds[i] != END_TSO_QUEUE) && ((blocked_queue_hds[i] != NULL)))
2445           evac((StgClosure **)&blocked_queue_hds[i]);
2446       if ((blocked_queue_tls[i] != END_TSO_QUEUE) && ((blocked_queue_tls[i] != NULL)))
2447           evac((StgClosure **)&blocked_queue_tls[i]);
2448       if ((ccalling_threadss[i] != END_TSO_QUEUE) && ((ccalling_threadss[i] != NULL)))
2449           evac((StgClosure **)&ccalling_threads[i]);
2450     }
2451   }
2452
2453   markEventQueue();
2454
2455 #else /* !GRAN */
2456   if (run_queue_hd != END_TSO_QUEUE) {
2457       ASSERT(run_queue_tl != END_TSO_QUEUE);
2458       evac((StgClosure **)&run_queue_hd);
2459       evac((StgClosure **)&run_queue_tl);
2460   }
2461
2462   if (blocked_queue_hd != END_TSO_QUEUE) {
2463       ASSERT(blocked_queue_tl != END_TSO_QUEUE);
2464       evac((StgClosure **)&blocked_queue_hd);
2465       evac((StgClosure **)&blocked_queue_tl);
2466   }
2467
2468   if (sleeping_queue != END_TSO_QUEUE) {
2469       evac((StgClosure **)&sleeping_queue);
2470   }
2471 #endif
2472
2473   if (suspended_ccalling_threads != END_TSO_QUEUE) {
2474       evac((StgClosure **)&suspended_ccalling_threads);
2475   }
2476
2477 #if defined(PAR) || defined(GRAN)
2478   markSparkQueue(evac);
2479 #endif
2480 }
2481
2482 /* -----------------------------------------------------------------------------
2483    performGC
2484
2485    This is the interface to the garbage collector from Haskell land.
2486    We provide this so that external C code can allocate and garbage
2487    collect when called from Haskell via _ccall_GC.
2488
2489    It might be useful to provide an interface whereby the programmer
2490    can specify more roots (ToDo).
2491
2492    This needs to be protected by the GC condition variable above.  KH.
2493    -------------------------------------------------------------------------- */
2494
2495 void (*extra_roots)(evac_fn);
2496
2497 void
2498 performGC(void)
2499 {
2500   /* Obligated to hold this lock upon entry */
2501   ACQUIRE_LOCK(&sched_mutex);
2502   GarbageCollect(GetRoots,rtsFalse);
2503   RELEASE_LOCK(&sched_mutex);
2504 }
2505
2506 void
2507 performMajorGC(void)
2508 {
2509   ACQUIRE_LOCK(&sched_mutex);
2510   GarbageCollect(GetRoots,rtsTrue);
2511   RELEASE_LOCK(&sched_mutex);
2512 }
2513
2514 static void
2515 AllRoots(evac_fn evac)
2516 {
2517     GetRoots(evac);             // the scheduler's roots
2518     extra_roots(evac);          // the user's roots
2519 }
2520
2521 void
2522 performGCWithRoots(void (*get_roots)(evac_fn))
2523 {
2524   ACQUIRE_LOCK(&sched_mutex);
2525   extra_roots = get_roots;
2526   GarbageCollect(AllRoots,rtsFalse);
2527   RELEASE_LOCK(&sched_mutex);
2528 }
2529
2530 /* -----------------------------------------------------------------------------
2531    Stack overflow
2532
2533    If the thread has reached its maximum stack size, then raise the
2534    StackOverflow exception in the offending thread.  Otherwise
2535    relocate the TSO into a larger chunk of memory and adjust its stack
2536    size appropriately.
2537    -------------------------------------------------------------------------- */
2538
2539 static StgTSO *
2540 threadStackOverflow(StgTSO *tso)
2541 {
2542   nat new_stack_size, new_tso_size, diff, stack_words;
2543   StgPtr new_sp;
2544   StgTSO *dest;
2545
2546   IF_DEBUG(sanity,checkTSO(tso));
2547   if (tso->stack_size >= tso->max_stack_size) {
2548
2549     IF_DEBUG(gc,
2550              belch("@@ threadStackOverflow of TSO %d (%p): stack too large (now %ld; max is %ld",
2551                    tso->id, tso, tso->stack_size, tso->max_stack_size);
2552              /* If we're debugging, just print out the top of the stack */
2553              printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2554                                               tso->sp+64)));
2555
2556     /* Send this thread the StackOverflow exception */
2557     raiseAsync(tso, (StgClosure *)stackOverflow_closure);
2558     return tso;
2559   }
2560
2561   /* Try to double the current stack size.  If that takes us over the
2562    * maximum stack size for this thread, then use the maximum instead.
2563    * Finally round up so the TSO ends up as a whole number of blocks.
2564    */
2565   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
2566   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
2567                                        TSO_STRUCT_SIZE)/sizeof(W_);
2568   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
2569   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
2570
2571   IF_DEBUG(scheduler, fprintf(stderr,"== scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
2572
2573   dest = (StgTSO *)allocate(new_tso_size);
2574   TICK_ALLOC_TSO(new_stack_size,0);
2575
2576   /* copy the TSO block and the old stack into the new area */
2577   memcpy(dest,tso,TSO_STRUCT_SIZE);
2578   stack_words = tso->stack + tso->stack_size - tso->sp;
2579   new_sp = (P_)dest + new_tso_size - stack_words;
2580   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
2581
2582   /* relocate the stack pointers... */
2583   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
2584   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
2585   dest->sp    = new_sp;
2586   dest->stack_size = new_stack_size;
2587
2588   /* and relocate the update frame list */
2589   relocate_stack(dest, diff);
2590
2591   /* Mark the old TSO as relocated.  We have to check for relocated
2592    * TSOs in the garbage collector and any primops that deal with TSOs.
2593    *
2594    * It's important to set the sp and su values to just beyond the end
2595    * of the stack, so we don't attempt to scavenge any part of the
2596    * dead TSO's stack.
2597    */
2598   tso->what_next = ThreadRelocated;
2599   tso->link = dest;
2600   tso->sp = (P_)&(tso->stack[tso->stack_size]);
2601   tso->su = (StgUpdateFrame *)tso->sp;
2602   tso->why_blocked = NotBlocked;
2603   dest->mut_link = NULL;
2604
2605   IF_PAR_DEBUG(verbose,
2606                belch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld",
2607                      tso->id, tso, tso->stack_size);
2608                /* If we're debugging, just print out the top of the stack */
2609                printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2610                                                 tso->sp+64)));
2611
2612   IF_DEBUG(sanity,checkTSO(tso));
2613 #if 0
2614   IF_DEBUG(scheduler,printTSO(dest));
2615 #endif
2616
2617   return dest;
2618 }
2619
2620 //@node Blocking Queue Routines, Exception Handling Routines, Garbage Collextion Routines, Main scheduling code
2621 //@subsection Blocking Queue Routines
2622
2623 /* ---------------------------------------------------------------------------
2624    Wake up a queue that was blocked on some resource.
2625    ------------------------------------------------------------------------ */
2626
2627 #if defined(GRAN)
2628 static inline void
2629 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
2630 {
2631 }
2632 #elif defined(PAR)
2633 static inline void
2634 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
2635 {
2636   /* write RESUME events to log file and
2637      update blocked and fetch time (depending on type of the orig closure) */
2638   if (RtsFlags.ParFlags.ParStats.Full) {
2639     DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
2640                      GR_RESUMEQ, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
2641                      0, 0 /* spark_queue_len(ADVISORY_POOL) */);
2642     if (EMPTY_RUN_QUEUE())
2643       emitSchedule = rtsTrue;
2644
2645     switch (get_itbl(node)->type) {
2646         case FETCH_ME_BQ:
2647           ((StgTSO *)bqe)->par.fetchtime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
2648           break;
2649         case RBH:
2650         case FETCH_ME:
2651         case BLACKHOLE_BQ:
2652           ((StgTSO *)bqe)->par.blocktime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
2653           break;
2654 #ifdef DIST
2655         case MVAR:
2656           break;
2657 #endif
2658         default:
2659           barf("{unblockOneLocked}Daq Qagh: unexpected closure in blocking queue");
2660         }
2661       }
2662 }
2663 #endif
2664
2665 #if defined(GRAN)
2666 static StgBlockingQueueElement *
2667 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
2668 {
2669     StgTSO *tso;
2670     PEs node_loc, tso_loc;
2671
2672     node_loc = where_is(node); // should be lifted out of loop
2673     tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
2674     tso_loc = where_is((StgClosure *)tso);
2675     if (IS_LOCAL_TO(PROCS(node),tso_loc)) { // TSO is local
2676       /* !fake_fetch => TSO is on CurrentProc is same as IS_LOCAL_TO */
2677       ASSERT(CurrentProc!=node_loc || tso_loc==CurrentProc);
2678       CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.lunblocktime;
2679       // insertThread(tso, node_loc);
2680       new_event(tso_loc, tso_loc, CurrentTime[CurrentProc],
2681                 ResumeThread,
2682                 tso, node, (rtsSpark*)NULL);
2683       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
2684       // len_local++;
2685       // len++;
2686     } else { // TSO is remote (actually should be FMBQ)
2687       CurrentTime[CurrentProc] += RtsFlags.GranFlags.Costs.mpacktime +
2688                                   RtsFlags.GranFlags.Costs.gunblocktime +
2689                                   RtsFlags.GranFlags.Costs.latency;
2690       new_event(tso_loc, CurrentProc, CurrentTime[CurrentProc],
2691                 UnblockThread,
2692                 tso, node, (rtsSpark*)NULL);
2693       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
2694       // len++;
2695     }
2696     /* the thread-queue-overhead is accounted for in either Resume or UnblockThread */
2697     IF_GRAN_DEBUG(bq,
2698                   fprintf(stderr," %s TSO %d (%p) [PE %d] (block_info.closure=%p) (next=%p) ,",
2699                           (node_loc==tso_loc ? "Local" : "Global"),
2700                           tso->id, tso, CurrentProc, tso->block_info.closure, tso->link));
2701     tso->block_info.closure = NULL;
2702     IF_DEBUG(scheduler,belch("-- Waking up thread %ld (%p)",
2703                              tso->id, tso));
2704 }
2705 #elif defined(PAR)
2706 static StgBlockingQueueElement *
2707 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
2708 {
2709     StgBlockingQueueElement *next;
2710
2711     switch (get_itbl(bqe)->type) {
2712     case TSO:
2713       ASSERT(((StgTSO *)bqe)->why_blocked != NotBlocked);
2714       /* if it's a TSO just push it onto the run_queue */
2715       next = bqe->link;
2716       // ((StgTSO *)bqe)->link = END_TSO_QUEUE; // debugging?
2717       PUSH_ON_RUN_QUEUE((StgTSO *)bqe);
2718       THREAD_RUNNABLE();
2719       unblockCount(bqe, node);
2720       /* reset blocking status after dumping event */
2721       ((StgTSO *)bqe)->why_blocked = NotBlocked;
2722       break;
2723
2724     case BLOCKED_FETCH:
2725       /* if it's a BLOCKED_FETCH put it on the PendingFetches list */
2726       next = bqe->link;
2727       bqe->link = (StgBlockingQueueElement *)PendingFetches;
2728       PendingFetches = (StgBlockedFetch *)bqe;
2729       break;
2730
2731 # if defined(DEBUG)
2732       /* can ignore this case in a non-debugging setup;
2733          see comments on RBHSave closures above */
2734     case CONSTR:
2735       /* check that the closure is an RBHSave closure */
2736       ASSERT(get_itbl((StgClosure *)bqe) == &stg_RBH_Save_0_info ||
2737              get_itbl((StgClosure *)bqe) == &stg_RBH_Save_1_info ||
2738              get_itbl((StgClosure *)bqe) == &stg_RBH_Save_2_info);
2739       break;
2740
2741     default:
2742       barf("{unblockOneLocked}Daq Qagh: Unexpected IP (%#lx; %s) in blocking queue at %#lx\n",
2743            get_itbl((StgClosure *)bqe), info_type((StgClosure *)bqe),
2744            (StgClosure *)bqe);
2745 # endif
2746     }
2747   IF_PAR_DEBUG(bq, fprintf(stderr, ", %p (%s)", bqe, info_type((StgClosure*)bqe)));
2748   return next;
2749 }
2750
2751 #else /* !GRAN && !PAR */
2752 static StgTSO *
2753 unblockOneLocked(StgTSO *tso)
2754 {
2755   StgTSO *next;
2756
2757   ASSERT(get_itbl(tso)->type == TSO);
2758   ASSERT(tso->why_blocked != NotBlocked);
2759   tso->why_blocked = NotBlocked;
2760   next = tso->link;
2761   PUSH_ON_RUN_QUEUE(tso);
2762   THREAD_RUNNABLE();
2763   IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
2764   return next;
2765 }
2766 #endif
2767
2768 #if defined(GRAN) || defined(PAR)
2769 inline StgBlockingQueueElement *
2770 unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
2771 {
2772   ACQUIRE_LOCK(&sched_mutex);
2773   bqe = unblockOneLocked(bqe, node);
2774   RELEASE_LOCK(&sched_mutex);
2775   return bqe;
2776 }
2777 #else
2778 inline StgTSO *
2779 unblockOne(StgTSO *tso)
2780 {
2781   ACQUIRE_LOCK(&sched_mutex);
2782   tso = unblockOneLocked(tso);
2783   RELEASE_LOCK(&sched_mutex);
2784   return tso;
2785 }
2786 #endif
2787
2788 #if defined(GRAN)
2789 void
2790 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
2791 {
2792   StgBlockingQueueElement *bqe;
2793   PEs node_loc;
2794   nat len = 0;
2795
2796   IF_GRAN_DEBUG(bq,
2797                 belch("##-_ AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
2798                       node, CurrentProc, CurrentTime[CurrentProc],
2799                       CurrentTSO->id, CurrentTSO));
2800
2801   node_loc = where_is(node);
2802
2803   ASSERT(q == END_BQ_QUEUE ||
2804          get_itbl(q)->type == TSO ||   // q is either a TSO or an RBHSave
2805          get_itbl(q)->type == CONSTR); // closure (type constructor)
2806   ASSERT(is_unique(node));
2807
2808   /* FAKE FETCH: magically copy the node to the tso's proc;
2809      no Fetch necessary because in reality the node should not have been
2810      moved to the other PE in the first place
2811   */
2812   if (CurrentProc!=node_loc) {
2813     IF_GRAN_DEBUG(bq,
2814                   belch("## node %p is on PE %d but CurrentProc is %d (TSO %d); assuming fake fetch and adjusting bitmask (old: %#x)",
2815                         node, node_loc, CurrentProc, CurrentTSO->id,
2816                         // CurrentTSO, where_is(CurrentTSO),
2817                         node->header.gran.procs));
2818     node->header.gran.procs = (node->header.gran.procs) | PE_NUMBER(CurrentProc);
2819     IF_GRAN_DEBUG(bq,
2820                   belch("## new bitmask of node %p is %#x",
2821                         node, node->header.gran.procs));
2822     if (RtsFlags.GranFlags.GranSimStats.Global) {
2823       globalGranStats.tot_fake_fetches++;
2824     }
2825   }
2826
2827   bqe = q;
2828   // ToDo: check: ASSERT(CurrentProc==node_loc);
2829   while (get_itbl(bqe)->type==TSO) { // q != END_TSO_QUEUE) {
2830     //next = bqe->link;
2831     /*
2832        bqe points to the current element in the queue
2833        next points to the next element in the queue
2834     */
2835     //tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
2836     //tso_loc = where_is(tso);
2837     len++;
2838     bqe = unblockOneLocked(bqe, node);
2839   }
2840
2841   /* if this is the BQ of an RBH, we have to put back the info ripped out of
2842      the closure to make room for the anchor of the BQ */
2843   if (bqe!=END_BQ_QUEUE) {
2844     ASSERT(get_itbl(node)->type == RBH && get_itbl(bqe)->type == CONSTR);
2845     /*
2846     ASSERT((info_ptr==&RBH_Save_0_info) ||
2847            (info_ptr==&RBH_Save_1_info) ||
2848            (info_ptr==&RBH_Save_2_info));
2849     */
2850     /* cf. convertToRBH in RBH.c for writing the RBHSave closure */
2851     ((StgRBH *)node)->blocking_queue = (StgBlockingQueueElement *)((StgRBHSave *)bqe)->payload[0];
2852     ((StgRBH *)node)->mut_link       = (StgMutClosure *)((StgRBHSave *)bqe)->payload[1];
2853
2854     IF_GRAN_DEBUG(bq,
2855                   belch("## Filled in RBH_Save for %p (%s) at end of AwBQ",
2856                         node, info_type(node)));
2857   }
2858
2859   /* statistics gathering */
2860   if (RtsFlags.GranFlags.GranSimStats.Global) {
2861     // globalGranStats.tot_bq_processing_time += bq_processing_time;
2862     globalGranStats.tot_bq_len += len;      // total length of all bqs awakened
2863     // globalGranStats.tot_bq_len_local += len_local;  // same for local TSOs only
2864     globalGranStats.tot_awbq++;             // total no. of bqs awakened
2865   }
2866   IF_GRAN_DEBUG(bq,
2867                 fprintf(stderr,"## BQ Stats of %p: [%d entries] %s\n",
2868                         node, len, (bqe!=END_BQ_QUEUE) ? "RBH" : ""));
2869 }
2870 #elif defined(PAR)
2871 void
2872 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
2873 {
2874   StgBlockingQueueElement *bqe;
2875
2876   ACQUIRE_LOCK(&sched_mutex);
2877
2878   IF_PAR_DEBUG(verbose,
2879                belch("##-_ AwBQ for node %p on [%x]: ",
2880                      node, mytid));
2881 #ifdef DIST
2882   //RFP
2883   if(get_itbl(q)->type == CONSTR || q==END_BQ_QUEUE) {
2884     IF_PAR_DEBUG(verbose, belch("## ... nothing to unblock so lets just return. RFP (BUG?)"));
2885     return;
2886   }
2887 #endif
2888
2889   ASSERT(q == END_BQ_QUEUE ||
2890          get_itbl(q)->type == TSO ||
2891          get_itbl(q)->type == BLOCKED_FETCH ||
2892          get_itbl(q)->type == CONSTR);
2893
2894   bqe = q;
2895   while (get_itbl(bqe)->type==TSO ||
2896          get_itbl(bqe)->type==BLOCKED_FETCH) {
2897     bqe = unblockOneLocked(bqe, node);
2898   }
2899   RELEASE_LOCK(&sched_mutex);
2900 }
2901
2902 #else   /* !GRAN && !PAR */
2903 void
2904 awakenBlockedQueue(StgTSO *tso)
2905 {
2906   ACQUIRE_LOCK(&sched_mutex);
2907   while (tso != END_TSO_QUEUE) {
2908     tso = unblockOneLocked(tso);
2909   }
2910   RELEASE_LOCK(&sched_mutex);
2911 }
2912 #endif
2913
2914 //@node Exception Handling Routines, Debugging Routines, Blocking Queue Routines, Main scheduling code
2915 //@subsection Exception Handling Routines
2916
2917 /* ---------------------------------------------------------------------------
2918    Interrupt execution
2919    - usually called inside a signal handler so it mustn't do anything fancy.
2920    ------------------------------------------------------------------------ */
2921
2922 void
2923 interruptStgRts(void)
2924 {
2925     interrupted    = 1;
2926     context_switch = 1;
2927 }
2928
2929 /* -----------------------------------------------------------------------------
2930    Unblock a thread
2931
2932    This is for use when we raise an exception in another thread, which
2933    may be blocked.
2934    This has nothing to do with the UnblockThread event in GranSim. -- HWL
2935    -------------------------------------------------------------------------- */
2936
2937 #if defined(GRAN) || defined(PAR)
2938 /*
2939   NB: only the type of the blocking queue is different in GranSim and GUM
2940       the operations on the queue-elements are the same
2941       long live polymorphism!
2942
2943   Locks: sched_mutex is held upon entry and exit.
2944
2945 */
2946 static void
2947 unblockThread(StgTSO *tso)
2948 {
2949   StgBlockingQueueElement *t, **last;
2950
2951   switch (tso->why_blocked) {
2952
2953   case NotBlocked:
2954     return;  /* not blocked */
2955
2956   case BlockedOnMVar:
2957     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
2958     {
2959       StgBlockingQueueElement *last_tso = END_BQ_QUEUE;
2960       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
2961
2962       last = (StgBlockingQueueElement **)&mvar->head;
2963       for (t = (StgBlockingQueueElement *)mvar->head;
2964            t != END_BQ_QUEUE;
2965            last = &t->link, last_tso = t, t = t->link) {
2966         if (t == (StgBlockingQueueElement *)tso) {
2967           *last = (StgBlockingQueueElement *)tso->link;
2968           if (mvar->tail == tso) {
2969             mvar->tail = (StgTSO *)last_tso;
2970           }
2971           goto done;
2972         }
2973       }
2974       barf("unblockThread (MVAR): TSO not found");
2975     }
2976
2977   case BlockedOnBlackHole:
2978     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
2979     {
2980       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
2981
2982       last = &bq->blocking_queue;
2983       for (t = bq->blocking_queue;
2984            t != END_BQ_QUEUE;
2985            last = &t->link, t = t->link) {
2986         if (t == (StgBlockingQueueElement *)tso) {
2987           *last = (StgBlockingQueueElement *)tso->link;
2988           goto done;
2989         }
2990       }
2991       barf("unblockThread (BLACKHOLE): TSO not found");
2992     }
2993
2994   case BlockedOnException:
2995     {
2996       StgTSO *target  = tso->block_info.tso;
2997
2998       ASSERT(get_itbl(target)->type == TSO);
2999
3000       if (target->what_next == ThreadRelocated) {
3001           target = target->link;
3002           ASSERT(get_itbl(target)->type == TSO);
3003       }
3004
3005       ASSERT(target->blocked_exceptions != NULL);
3006
3007       last = (StgBlockingQueueElement **)&target->blocked_exceptions;
3008       for (t = (StgBlockingQueueElement *)target->blocked_exceptions;
3009            t != END_BQ_QUEUE;
3010            last = &t->link, t = t->link) {
3011         ASSERT(get_itbl(t)->type == TSO);
3012         if (t == (StgBlockingQueueElement *)tso) {
3013           *last = (StgBlockingQueueElement *)tso->link;
3014           goto done;
3015         }
3016       }
3017       barf("unblockThread (Exception): TSO not found");
3018     }
3019
3020   case BlockedOnRead:
3021   case BlockedOnWrite:
3022     {
3023       /* take TSO off blocked_queue */
3024       StgBlockingQueueElement *prev = NULL;
3025       for (t = (StgBlockingQueueElement *)blocked_queue_hd; t != END_BQ_QUEUE;
3026            prev = t, t = t->link) {
3027         if (t == (StgBlockingQueueElement *)tso) {
3028           if (prev == NULL) {
3029             blocked_queue_hd = (StgTSO *)t->link;
3030             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
3031               blocked_queue_tl = END_TSO_QUEUE;
3032             }
3033           } else {
3034             prev->link = t->link;
3035             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
3036               blocked_queue_tl = (StgTSO *)prev;
3037             }
3038           }
3039           goto done;
3040         }
3041       }
3042       barf("unblockThread (I/O): TSO not found");
3043     }
3044
3045   case BlockedOnDelay:
3046     {
3047       /* take TSO off sleeping_queue */
3048       StgBlockingQueueElement *prev = NULL;
3049       for (t = (StgBlockingQueueElement *)sleeping_queue; t != END_BQ_QUEUE;
3050            prev = t, t = t->link) {
3051         if (t == (StgBlockingQueueElement *)tso) {
3052           if (prev == NULL) {
3053             sleeping_queue = (StgTSO *)t->link;
3054           } else {
3055             prev->link = t->link;
3056           }
3057           goto done;
3058         }
3059       }
3060       barf("unblockThread (I/O): TSO not found");
3061     }
3062
3063   default:
3064     barf("unblockThread");
3065   }
3066
3067  done:
3068   tso->link = END_TSO_QUEUE;
3069   tso->why_blocked = NotBlocked;
3070   tso->block_info.closure = NULL;
3071   PUSH_ON_RUN_QUEUE(tso);
3072 }
3073 #else
3074 static void
3075 unblockThread(StgTSO *tso)
3076 {
3077   StgTSO *t, **last;
3078
3079   /* To avoid locking unnecessarily. */
3080   if (tso->why_blocked == NotBlocked) {
3081     return;
3082   }
3083
3084   switch (tso->why_blocked) {
3085
3086   case BlockedOnMVar:
3087     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
3088     {
3089       StgTSO *last_tso = END_TSO_QUEUE;
3090       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
3091
3092       last = &mvar->head;
3093       for (t = mvar->head; t != END_TSO_QUEUE;
3094            last = &t->link, last_tso = t, t = t->link) {
3095         if (t == tso) {
3096           *last = tso->link;
3097           if (mvar->tail == tso) {
3098             mvar->tail = last_tso;
3099           }
3100           goto done;
3101         }
3102       }
3103       barf("unblockThread (MVAR): TSO not found");
3104     }
3105
3106   case BlockedOnBlackHole:
3107     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
3108     {
3109       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
3110
3111       last = &bq->blocking_queue;
3112       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
3113            last = &t->link, t = t->link) {
3114         if (t == tso) {
3115           *last = tso->link;
3116           goto done;
3117         }
3118       }
3119       barf("unblockThread (BLACKHOLE): TSO not found");
3120     }
3121
3122   case BlockedOnException:
3123     {
3124       StgTSO *target  = tso->block_info.tso;
3125
3126       ASSERT(get_itbl(target)->type == TSO);
3127
3128       while (target->what_next == ThreadRelocated) {
3129           target = target->link;
3130           ASSERT(get_itbl(target)->type == TSO);
3131       }
3132
3133       ASSERT(target->blocked_exceptions != NULL);
3134
3135       last = &target->blocked_exceptions;
3136       for (t = target->blocked_exceptions; t != END_TSO_QUEUE;
3137            last = &t->link, t = t->link) {
3138         ASSERT(get_itbl(t)->type == TSO);
3139         if (t == tso) {
3140           *last = tso->link;
3141           goto done;
3142         }
3143       }
3144       barf("unblockThread (Exception): TSO not found");
3145     }
3146
3147   case BlockedOnRead:
3148   case BlockedOnWrite:
3149     {
3150       StgTSO *prev = NULL;
3151       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
3152            prev = t, t = t->link) {
3153         if (t == tso) {
3154           if (prev == NULL) {
3155             blocked_queue_hd = t->link;
3156             if (blocked_queue_tl == t) {
3157               blocked_queue_tl = END_TSO_QUEUE;
3158             }
3159           } else {
3160             prev->link = t->link;
3161             if (blocked_queue_tl == t) {
3162               blocked_queue_tl = prev;
3163             }
3164           }
3165           goto done;
3166         }
3167       }
3168       barf("unblockThread (I/O): TSO not found");
3169     }
3170
3171   case BlockedOnDelay:
3172     {
3173       StgTSO *prev = NULL;
3174       for (t = sleeping_queue; t != END_TSO_QUEUE;
3175            prev = t, t = t->link) {
3176         if (t == tso) {
3177           if (prev == NULL) {
3178             sleeping_queue = t->link;
3179           } else {
3180             prev->link = t->link;
3181           }
3182           goto done;
3183         }
3184       }
3185       barf("unblockThread (I/O): TSO not found");
3186     }
3187
3188   default:
3189     barf("unblockThread");
3190   }
3191
3192  done:
3193   tso->link = END_TSO_QUEUE;
3194   tso->why_blocked = NotBlocked;
3195   tso->block_info.closure = NULL;
3196   PUSH_ON_RUN_QUEUE(tso);
3197 }
3198 #endif
3199
3200 /* -----------------------------------------------------------------------------
3201  * raiseAsync()
3202  *
3203  * The following function implements the magic for raising an
3204  * asynchronous exception in an existing thread.
3205  *
3206  * We first remove the thread from any queue on which it might be
3207  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
3208  *
3209  * We strip the stack down to the innermost CATCH_FRAME, building
3210  * thunks in the heap for all the active computations, so they can
3211  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
3212  * an application of the handler to the exception, and push it on
3213  * the top of the stack.
3214  *
3215  * How exactly do we save all the active computations?  We create an
3216  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
3217  * AP_UPDs pushes everything from the corresponding update frame
3218  * upwards onto the stack.  (Actually, it pushes everything up to the
3219  * next update frame plus a pointer to the next AP_UPD object.
3220  * Entering the next AP_UPD object pushes more onto the stack until we
3221  * reach the last AP_UPD object - at which point the stack should look
3222  * exactly as it did when we killed the TSO and we can continue
3223  * execution by entering the closure on top of the stack.
3224  *
3225  * We can also kill a thread entirely - this happens if either (a) the
3226  * exception passed to raiseAsync is NULL, or (b) there's no
3227  * CATCH_FRAME on the stack.  In either case, we strip the entire
3228  * stack and replace the thread with a zombie.
3229  *
3230  * Locks: sched_mutex held upon entry nor exit.
3231  *
3232  * -------------------------------------------------------------------------- */
3233
3234 void
3235 deleteThread(StgTSO *tso)
3236 {
3237   raiseAsync(tso,NULL);
3238 }
3239
3240 void
3241 raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
3242 {
3243   /* When raising async exs from contexts where sched_mutex isn't held;
3244      use raiseAsyncWithLock(). */
3245   ACQUIRE_LOCK(&sched_mutex);
3246   raiseAsync(tso,exception);
3247   RELEASE_LOCK(&sched_mutex);
3248 }
3249
3250 void
3251 raiseAsync(StgTSO *tso, StgClosure *exception)
3252 {
3253   StgUpdateFrame* su = tso->su;
3254   StgPtr          sp = tso->sp;
3255
3256   /* Thread already dead? */
3257   if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
3258     return;
3259   }
3260
3261   IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
3262
3263   /* Remove it from any blocking queues */
3264   unblockThread(tso);
3265
3266   IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
3267   /* The stack freezing code assumes there's a closure pointer on
3268    * the top of the stack.  This isn't always the case with compiled
3269    * code, so we have to push a dummy closure on the top which just
3270    * returns to the next return address on the stack.
3271    */
3272   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
3273     *(--sp) = (W_)&stg_dummy_ret_closure;
3274   }
3275
3276   while (1) {
3277     nat words = ((P_)su - (P_)sp) - 1;
3278     nat i;
3279     StgAP_UPD * ap;
3280
3281     /* If we find a CATCH_FRAME, and we've got an exception to raise,
3282      * then build the THUNK raise(exception), and leave it on
3283      * top of the CATCH_FRAME ready to enter.
3284      */
3285     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
3286 #ifdef PROFILING
3287       StgCatchFrame *cf = (StgCatchFrame *)su;
3288 #endif
3289       StgClosure *raise;
3290
3291       /* we've got an exception to raise, so let's pass it to the
3292        * handler in this frame.
3293        */
3294       raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
3295       TICK_ALLOC_SE_THK(1,0);
3296       SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
3297       raise->payload[0] = exception;
3298
3299       /* throw away the stack from Sp up to the CATCH_FRAME.
3300        */
3301       sp = (P_)su - 1;
3302
3303       /* Ensure that async excpetions are blocked now, so we don't get
3304        * a surprise exception before we get around to executing the
3305        * handler.
3306        */
3307       if (tso->blocked_exceptions == NULL) {
3308           tso->blocked_exceptions = END_TSO_QUEUE;
3309       }
3310
3311       /* Put the newly-built THUNK on top of the stack, ready to execute
3312        * when the thread restarts.
3313        */
3314       sp[0] = (W_)raise;
3315       tso->sp = sp;
3316       tso->su = su;
3317       tso->what_next = ThreadEnterGHC;
3318       IF_DEBUG(sanity, checkTSO(tso));
3319       return;
3320     }
3321
3322     /* First build an AP_UPD consisting of the stack chunk above the
3323      * current update frame, with the top word on the stack as the
3324      * fun field.
3325      */
3326     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
3327
3328     ASSERT(words >= 0);
3329
3330     ap->n_args = words;
3331     ap->fun    = (StgClosure *)sp[0];
3332     sp++;
3333     for(i=0; i < (nat)words; ++i) {
3334       ap->payload[i] = (StgClosure *)*sp++;
3335     }
3336
3337     switch (get_itbl(su)->type) {
3338
3339     case UPDATE_FRAME:
3340       {
3341         SET_HDR(ap,&stg_AP_UPD_info,su->header.prof.ccs /* ToDo */);
3342         TICK_ALLOC_UP_THK(words+1,0);
3343
3344         IF_DEBUG(scheduler,
3345                  fprintf(stderr,  "scheduler: Updating ");
3346                  printPtr((P_)su->updatee);
3347                  fprintf(stderr,  " with ");
3348                  printObj((StgClosure *)ap);
3349                  );
3350
3351         /* Replace the updatee with an indirection - happily
3352          * this will also wake up any threads currently
3353          * waiting on the result.
3354          *
3355          * Warning: if we're in a loop, more than one update frame on
3356          * the stack may point to the same object.  Be careful not to
3357          * overwrite an IND_OLDGEN in this case, because we'll screw
3358          * up the mutable lists.  To be on the safe side, don't
3359          * overwrite any kind of indirection at all.  See also
3360          * threadSqueezeStack in GC.c, where we have to make a similar
3361          * check.
3362          */
3363         if (!closure_IND(su->updatee)) {
3364             UPD_IND_NOLOCK(su->updatee,ap);  /* revert the black hole */
3365         }
3366         su = su->link;
3367         sp += sizeofW(StgUpdateFrame) -1;
3368         sp[0] = (W_)ap; /* push onto stack */
3369         break;
3370       }
3371
3372     case CATCH_FRAME:
3373       {
3374         StgCatchFrame *cf = (StgCatchFrame *)su;
3375         StgClosure* o;
3376
3377         /* We want a PAP, not an AP_UPD.  Fortunately, the
3378          * layout's the same.
3379          */
3380         SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
3381         TICK_ALLOC_UPD_PAP(words+1,0);
3382
3383         /* now build o = FUN(catch,ap,handler) */
3384         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
3385         TICK_ALLOC_FUN(2,0);
3386         SET_HDR(o,&stg_catch_info,su->header.prof.ccs /* ToDo */);
3387         o->payload[0] = (StgClosure *)ap;
3388         o->payload[1] = cf->handler;
3389
3390         IF_DEBUG(scheduler,
3391                  fprintf(stderr,  "scheduler: Built ");
3392                  printObj((StgClosure *)o);
3393                  );
3394
3395         /* pop the old handler and put o on the stack */
3396         su = cf->link;
3397         sp += sizeofW(StgCatchFrame) - 1;
3398         sp[0] = (W_)o;
3399         break;
3400       }
3401
3402     case SEQ_FRAME:
3403       {
3404         StgSeqFrame *sf = (StgSeqFrame *)su;
3405         StgClosure* o;
3406
3407         SET_HDR(ap,&stg_PAP_info,su->header.prof.ccs /* ToDo */);
3408         TICK_ALLOC_UPD_PAP(words+1,0);
3409
3410         /* now build o = FUN(seq,ap) */
3411         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
3412         TICK_ALLOC_SE_THK(1,0);
3413         SET_HDR(o,&stg_seq_info,su->header.prof.ccs /* ToDo */);
3414         o->payload[0] = (StgClosure *)ap;
3415
3416         IF_DEBUG(scheduler,
3417                  fprintf(stderr,  "scheduler: Built ");
3418                  printObj((StgClosure *)o);
3419                  );
3420
3421         /* pop the old handler and put o on the stack */
3422         su = sf->link;
3423         sp += sizeofW(StgSeqFrame) - 1;
3424         sp[0] = (W_)o;
3425         break;
3426       }
3427
3428     case STOP_FRAME:
3429       /* We've stripped the entire stack, the thread is now dead. */
3430       sp += sizeofW(StgStopFrame) - 1;
3431       sp[0] = (W_)exception;    /* save the exception */
3432       tso->what_next = ThreadKilled;
3433       tso->su = (StgUpdateFrame *)(sp+1);
3434       tso->sp = sp;
3435       return;
3436
3437     default:
3438       barf("raiseAsync");
3439     }
3440   }
3441   barf("raiseAsync");
3442 }
3443
3444 /* -----------------------------------------------------------------------------
3445    resurrectThreads is called after garbage collection on the list of
3446    threads found to be garbage.  Each of these threads will be woken
3447    up and sent a signal: BlockedOnDeadMVar if the thread was blocked
3448    on an MVar, or NonTermination if the thread was blocked on a Black
3449    Hole.
3450
3451    Locks: sched_mutex isn't held upon entry nor exit.
3452    -------------------------------------------------------------------------- */
3453
3454 void
3455 resurrectThreads( StgTSO *threads )
3456 {
3457   StgTSO *tso, *next;
3458
3459   for (tso = threads; tso != END_TSO_QUEUE; tso = next) {
3460     next = tso->global_link;
3461     tso->global_link = all_threads;
3462     all_threads = tso;
3463     IF_DEBUG(scheduler, sched_belch("resurrecting thread %d", tso->id));
3464
3465     switch (tso->why_blocked) {
3466     case BlockedOnMVar:
3467     case BlockedOnException:
3468       /* Called by GC - sched_mutex lock is currently held. */
3469       raiseAsync(tso,(StgClosure *)BlockedOnDeadMVar_closure);
3470       break;
3471     case BlockedOnBlackHole:
3472       raiseAsync(tso,(StgClosure *)NonTermination_closure);
3473       break;
3474     case NotBlocked:
3475       /* This might happen if the thread was blocked on a black hole
3476        * belonging to a thread that we've just woken up (raiseAsync
3477        * can wake up threads, remember...).
3478        */
3479       continue;
3480     default:
3481       barf("resurrectThreads: thread blocked in a strange way");
3482     }
3483   }
3484 }
3485
3486 /* -----------------------------------------------------------------------------
3487  * Blackhole detection: if we reach a deadlock, test whether any
3488  * threads are blocked on themselves.  Any threads which are found to
3489  * be self-blocked get sent a NonTermination exception.
3490  *
3491  * This is only done in a deadlock situation in order to avoid
3492  * performance overhead in the normal case.
3493  *
3494  * Locks: sched_mutex is held upon entry and exit.
3495  * -------------------------------------------------------------------------- */
3496
3497 static void
3498 detectBlackHoles( void )
3499 {
3500     StgTSO *t = all_threads;
3501     StgUpdateFrame *frame;
3502     StgClosure *blocked_on;
3503
3504     for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3505
3506         while (t->what_next == ThreadRelocated) {
3507             t = t->link;
3508             ASSERT(get_itbl(t)->type == TSO);
3509         }
3510
3511         if (t->why_blocked != BlockedOnBlackHole) {
3512             continue;
3513         }
3514
3515         blocked_on = t->block_info.closure;
3516
3517         for (frame = t->su; ; frame = frame->link) {
3518             switch (get_itbl(frame)->type) {
3519
3520             case UPDATE_FRAME:
3521                 if (frame->updatee == blocked_on) {
3522                     /* We are blocking on one of our own computations, so
3523                      * send this thread the NonTermination exception.
3524                      */
3525                     IF_DEBUG(scheduler,
3526                              sched_belch("thread %d is blocked on itself", t->id));
3527                     raiseAsync(t, (StgClosure *)NonTermination_closure);
3528                     goto done;
3529                 }
3530                 else {
3531                     continue;
3532                 }
3533
3534             case CATCH_FRAME:
3535             case SEQ_FRAME:
3536                 continue;
3537
3538             case STOP_FRAME:
3539                 break;
3540             }
3541             break;
3542         }
3543
3544     done: ;
3545     }
3546 }
3547
3548 //@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
3549 //@subsection Debugging Routines
3550
3551 /* -----------------------------------------------------------------------------
3552    Debugging: why is a thread blocked
3553    -------------------------------------------------------------------------- */
3554
3555 #ifdef DEBUG
3556
3557 void
3558 printThreadBlockage(StgTSO *tso)
3559 {
3560   switch (tso->why_blocked) {
3561   case BlockedOnRead:
3562     fprintf(stderr,"is blocked on read from fd %d", tso->block_info.fd);
3563     break;
3564   case BlockedOnWrite:
3565     fprintf(stderr,"is blocked on write to fd %d", tso->block_info.fd);
3566     break;
3567   case BlockedOnDelay:
3568     fprintf(stderr,"is blocked until %d", tso->block_info.target);
3569     break;
3570   case BlockedOnMVar:
3571     fprintf(stderr,"is blocked on an MVar");
3572     break;
3573   case BlockedOnException:
3574     fprintf(stderr,"is blocked on delivering an exception to thread %d",
3575             tso->block_info.tso->id);
3576     break;
3577   case BlockedOnBlackHole:
3578     fprintf(stderr,"is blocked on a black hole");
3579     break;
3580   case NotBlocked:
3581     fprintf(stderr,"is not blocked");
3582     break;
3583 #if defined(PAR)
3584   case BlockedOnGA:
3585     fprintf(stderr,"is blocked on global address; local FM_BQ is %p (%s)",
3586             tso->block_info.closure, info_type(tso->block_info.closure));
3587     break;
3588   case BlockedOnGA_NoSend:
3589     fprintf(stderr,"is blocked on global address (no send); local FM_BQ is %p (%s)",
3590             tso->block_info.closure, info_type(tso->block_info.closure));
3591     break;
3592 #endif
3593 #if defined(RTS_SUPPORTS_THREADS)
3594   case BlockedOnCCall:
3595     fprintf(stderr,"is blocked on an external call");
3596     break;
3597 #endif
3598   default:
3599     barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
3600          tso->why_blocked, tso->id, tso);
3601   }
3602 }
3603
3604 void
3605 printThreadStatus(StgTSO *tso)
3606 {
3607   switch (tso->what_next) {
3608   case ThreadKilled:
3609     fprintf(stderr,"has been killed");
3610     break;
3611   case ThreadComplete:
3612     fprintf(stderr,"has completed");
3613     break;
3614   default:
3615     printThreadBlockage(tso);
3616   }
3617 }
3618
3619 void
3620 printAllThreads(void)
3621 {
3622   StgTSO *t;
3623   void *label;
3624
3625 # if defined(GRAN)
3626   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
3627   ullong_format_string(TIME_ON_PROC(CurrentProc),
3628                        time_string, rtsFalse/*no commas!*/);
3629
3630   sched_belch("all threads at [%s]:", time_string);
3631 # elif defined(PAR)
3632   char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
3633   ullong_format_string(CURRENT_TIME,
3634                        time_string, rtsFalse/*no commas!*/);
3635
3636   sched_belch("all threads at [%s]:", time_string);
3637 # else
3638   sched_belch("all threads:");
3639 # endif
3640
3641   for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3642     fprintf(stderr, "\tthread %d @ %p ", t->id, (void *)t);
3643     label = lookupThreadLabel((StgWord)t);
3644     if (label) fprintf(stderr,"[\"%s\"] ",(char *)label);
3645     printThreadStatus(t);
3646     fprintf(stderr,"\n");
3647   }
3648 }
3649
3650 /*
3651    Print a whole blocking queue attached to node (debugging only).
3652 */
3653 //@cindex print_bq
3654 # if defined(PAR)
3655 void
3656 print_bq (StgClosure *node)
3657 {
3658   StgBlockingQueueElement *bqe;
3659   StgTSO *tso;
3660   rtsBool end;
3661
3662   fprintf(stderr,"## BQ of closure %p (%s): ",
3663           node, info_type(node));
3664
3665   /* should cover all closures that may have a blocking queue */
3666   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
3667          get_itbl(node)->type == FETCH_ME_BQ ||
3668          get_itbl(node)->type == RBH ||
3669          get_itbl(node)->type == MVAR);
3670
3671   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3672
3673   print_bqe(((StgBlockingQueue*)node)->blocking_queue);
3674 }
3675
3676 /*
3677    Print a whole blocking queue starting with the element bqe.
3678 */
3679 void
3680 print_bqe (StgBlockingQueueElement *bqe)
3681 {
3682   rtsBool end;
3683
3684   /*
3685      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
3686   */
3687   for (end = (bqe==END_BQ_QUEUE);
3688        !end; // iterate until bqe points to a CONSTR
3689        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE),
3690        bqe = end ? END_BQ_QUEUE : bqe->link) {
3691     ASSERT(bqe != END_BQ_QUEUE);                               // sanity check
3692     ASSERT(bqe != (StgBlockingQueueElement *)NULL);            // sanity check
3693     /* types of closures that may appear in a blocking queue */
3694     ASSERT(get_itbl(bqe)->type == TSO ||
3695            get_itbl(bqe)->type == BLOCKED_FETCH ||
3696            get_itbl(bqe)->type == CONSTR);
3697     /* only BQs of an RBH end with an RBH_Save closure */
3698     //ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
3699
3700     switch (get_itbl(bqe)->type) {
3701     case TSO:
3702       fprintf(stderr," TSO %u (%x),",
3703               ((StgTSO *)bqe)->id, ((StgTSO *)bqe));
3704       break;
3705     case BLOCKED_FETCH:
3706       fprintf(stderr," BF (node=%p, ga=((%x, %d, %x)),",
3707               ((StgBlockedFetch *)bqe)->node,
3708               ((StgBlockedFetch *)bqe)->ga.payload.gc.gtid,
3709               ((StgBlockedFetch *)bqe)->ga.payload.gc.slot,
3710               ((StgBlockedFetch *)bqe)->ga.weight);
3711       break;
3712     case CONSTR:
3713       fprintf(stderr," %s (IP %p),",
3714               (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
3715                get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
3716                get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
3717                "RBH_Save_?"), get_itbl(bqe));
3718       break;
3719     default:
3720       barf("Unexpected closure type %s in blocking queue", // of %p (%s)",
3721            info_type((StgClosure *)bqe)); // , node, info_type(node));
3722       break;
3723     }
3724   } /* for */
3725   fputc('\n', stderr);
3726 }
3727 # elif defined(GRAN)
3728 void
3729 print_bq (StgClosure *node)
3730 {
3731   StgBlockingQueueElement *bqe;
3732   PEs node_loc, tso_loc;
3733   rtsBool end;
3734
3735   /* should cover all closures that may have a blocking queue */
3736   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
3737          get_itbl(node)->type == FETCH_ME_BQ ||
3738          get_itbl(node)->type == RBH);
3739
3740   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3741   node_loc = where_is(node);
3742
3743   fprintf(stderr,"## BQ of closure %p (%s) on [PE %d]: ",
3744           node, info_type(node), node_loc);
3745
3746   /*
3747      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
3748   */
3749   for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
3750        !end; // iterate until bqe points to a CONSTR
3751        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
3752     ASSERT(bqe != END_BQ_QUEUE);             // sanity check
3753     ASSERT(bqe != (StgBlockingQueueElement *)NULL);  // sanity check
3754     /* types of closures that may appear in a blocking queue */
3755     ASSERT(get_itbl(bqe)->type == TSO ||
3756            get_itbl(bqe)->type == CONSTR);
3757     /* only BQs of an RBH end with an RBH_Save closure */
3758     ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
3759
3760     tso_loc = where_is((StgClosure *)bqe);
3761     switch (get_itbl(bqe)->type) {
3762     case TSO:
3763       fprintf(stderr," TSO %d (%p) on [PE %d],",
3764               ((StgTSO *)bqe)->id, (StgTSO *)bqe, tso_loc);
3765       break;
3766     case CONSTR:
3767       fprintf(stderr," %s (IP %p),",
3768               (get_itbl(bqe) == &stg_RBH_Save_0_info ? "RBH_Save_0" :
3769                get_itbl(bqe) == &stg_RBH_Save_1_info ? "RBH_Save_1" :
3770                get_itbl(bqe) == &stg_RBH_Save_2_info ? "RBH_Save_2" :
3771                "RBH_Save_?"), get_itbl(bqe));
3772       break;
3773     default:
3774       barf("Unexpected closure type %s in blocking queue of %p (%s)",
3775            info_type((StgClosure *)bqe), node, info_type(node));
3776       break;
3777     }
3778   } /* for */
3779   fputc('\n', stderr);
3780 }
3781 #else
3782 /*
3783    Nice and easy: only TSOs on the blocking queue
3784 */
3785 void
3786 print_bq (StgClosure *node)
3787 {
3788   StgTSO *tso;
3789
3790   ASSERT(node!=(StgClosure*)NULL);         // sanity check
3791   for (tso = ((StgBlockingQueue*)node)->blocking_queue;
3792        tso != END_TSO_QUEUE;
3793        tso=tso->link) {
3794     ASSERT(tso!=NULL && tso!=END_TSO_QUEUE);   // sanity check
3795     ASSERT(get_itbl(tso)->type == TSO);  // guess what, sanity check
3796     fprintf(stderr," TSO %d (%p),", tso->id, tso);
3797   }
3798   fputc('\n', stderr);
3799 }
3800 # endif
3801
3802 #if defined(PAR)
3803 static nat
3804 run_queue_len(void)
3805 {
3806   nat i;
3807   StgTSO *tso;
3808
3809   for (i=0, tso=run_queue_hd;
3810        tso != END_TSO_QUEUE;
3811        i++, tso=tso->link)
3812     /* nothing */
3813
3814   return i;
3815 }
3816 #endif
3817
3818 static void
3819 sched_belch(char *s, ...)
3820 {
3821   va_list ap;
3822   va_start(ap,s);
3823 #ifdef SMP
3824   fprintf(stderr, "scheduler (task %ld): ", osThreadId());
3825 #elif defined(PAR)
3826   fprintf(stderr, "== ");
3827 #else
3828   fprintf(stderr, "scheduler: ");
3829 #endif
3830   vfprintf(stderr, s, ap);
3831   fprintf(stderr, "\n");
3832   va_end(ap);
3833 }
3834
3835 #endif /* DEBUG */
3836
3837
3838 //@node Index,  , Debugging Routines, Main scheduling code
3839 //@subsection Index
3840
3841 //@index
3842 //* StgMainThread::  @cindex\s-+StgMainThread
3843 //* awaken_blocked_queue::  @cindex\s-+awaken_blocked_queue
3844 //* blocked_queue_hd::  @cindex\s-+blocked_queue_hd
3845 //* blocked_queue_tl::  @cindex\s-+blocked_queue_tl
3846 //* context_switch::  @cindex\s-+context_switch
3847 //* createThread::  @cindex\s-+createThread
3848 //* gc_pending_cond::  @cindex\s-+gc_pending_cond
3849 //* initScheduler::  @cindex\s-+initScheduler
3850 //* interrupted::  @cindex\s-+interrupted
3851 //* next_thread_id::  @cindex\s-+next_thread_id
3852 //* print_bq::  @cindex\s-+print_bq
3853 //* run_queue_hd::  @cindex\s-+run_queue_hd
3854 //* run_queue_tl::  @cindex\s-+run_queue_tl
3855 //* sched_mutex::  @cindex\s-+sched_mutex
3856 //* schedule::  @cindex\s-+schedule
3857 //* take_off_run_queue::  @cindex\s-+take_off_run_queue
3858 //* term_mutex::  @cindex\s-+term_mutex
3859 //@end index