ghc/rts/Schedule.c

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