ghc/rts/Schedule.c

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