ghc/rts/Schedule.c

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