ghc/rts/Schedule.c

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