ghc/rts/Schedule.c

   1 /* ---------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.48 2000/03/07 11:58:49 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 //* Prototypes::
  41 //* Main scheduling loop::
  42 //* Suspend and Resume::
  43 //* Run queue code::
  44 //* Garbage Collextion Routines::
  45 //* Blocking Queue Routines::
  46 //* Exception Handling Routines::
  47 //* Debugging Routines::
  48 //* Index::
  49 //@end menu
  50
  51 //@node Includes, Variables and Data structures, Main scheduling code, Main scheduling code
  52 //@subsection Includes
  53
  54 #include "Rts.h"
  55 #include "SchedAPI.h"
  56 #include "RtsUtils.h"
  57 #include "RtsFlags.h"
  58 #include "Storage.h"
  59 #include "StgRun.h"
  60 #include "StgStartup.h"
  61 #include "GC.h"
  62 #include "Hooks.h"
  63 #include "Schedule.h"
  64 #include "StgMiscClosures.h"
  65 #include "Storage.h"
  66 #include "Evaluator.h"
  67 #include "Exception.h"
  68 #include "Printer.h"
  69 #include "Main.h"
  70 #include "Signals.h"
  71 #include "Profiling.h"
  72 #include "Sanity.h"
  73 #include "Stats.h"
  74 #include "Sparks.h"
  75 #if defined(GRAN) || defined(PAR)
  76 # include "GranSimRts.h"
  77 # include "GranSim.h"
  78 # include "ParallelRts.h"
  79 # include "Parallel.h"
  80 # include "ParallelDebug.h"
  81 # include "FetchMe.h"
  82 # include "HLC.h"
  83 #endif
  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
 124 #if defined(GRAN)
 125
 126 StgTSO* ActiveTSO = NULL; /* for assigning system costs; GranSim-Light only */
 127 /* rtsTime TimeOfNextEvent, EndOfTimeSlice;            now in GranSim.c */
 128
 129 /*
 130    In GranSim we have a runable and a blocked queue for each processor.
 131    In order to minimise code changes new arrays run_queue_hds/tls
 132    are created. run_queue_hd is then a short cut (macro) for
 133    run_queue_hds[CurrentProc] (see GranSim.h).
 134    -- HWL
 135 */
 136 StgTSO *run_queue_hds[MAX_PROC], *run_queue_tls[MAX_PROC];
 137 StgTSO *blocked_queue_hds[MAX_PROC], *blocked_queue_tls[MAX_PROC];
 138 StgTSO *ccalling_threadss[MAX_PROC];
 139
 140 #else /* !GRAN */
 141
 142 //@cindex run_queue_hd
 143 //@cindex run_queue_tl
 144 //@cindex blocked_queue_hd
 145 //@cindex blocked_queue_tl
 146 StgTSO *run_queue_hd, *run_queue_tl;
 147 StgTSO *blocked_queue_hd, *blocked_queue_tl;
 148
 149 /* Threads suspended in _ccall_GC.
 150  * Locks required: sched_mutex.
 151  */
 152 static StgTSO *suspended_ccalling_threads;
 153
 154 static void GetRoots(void);
 155 static StgTSO *threadStackOverflow(StgTSO *tso);
 156 #endif
 157
 158 /* KH: The following two flags are shared memory locations.  There is no need
 159        to lock them, since they are only unset at the end of a scheduler
 160        operation.
 161 */
 162
 163 /* flag set by signal handler to precipitate a context switch */
 164 //@cindex context_switch
 165 nat context_switch;
 166
 167 /* if this flag is set as well, give up execution */
 168 //@cindex interrupted
 169 rtsBool interrupted;
 170
 171 /* Next thread ID to allocate.
 172  * Locks required: sched_mutex
 173  */
 174 //@cindex next_thread_id
 175 StgThreadID next_thread_id = 1;
 176
 177 /*
 178  * Pointers to the state of the current thread.
 179  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
 180  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
 181  */
 182
 183 /* The smallest stack size that makes any sense is:
 184  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
 185  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
 186  *  + 1                       (the realworld token for an IO thread)
 187  *  + 1                       (the closure to enter)
 188  *
 189  * A thread with this stack will bomb immediately with a stack
 190  * overflow, which will increase its stack size.
 191  */
 192
 193 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
 194
 195 /* Free capability list.
 196  * Locks required: sched_mutex.
 197  */
 198 #ifdef SMP
 199 //@cindex free_capabilities
 200 //@cindex n_free_capabilities
 201 Capability *free_capabilities; /* Available capabilities for running threads */
 202 nat n_free_capabilities;       /* total number of available capabilities */
 203 #else
 204 //@cindex MainRegTable
 205 Capability MainRegTable;       /* for non-SMP, we have one global capability */
 206 #endif
 207
 208 #if defined(GRAN)
 209 StgTSO      *CurrentTSOs[MAX_PROC];
 210 #else
 211 StgTSO      *CurrentTSO;
 212 #endif
 213
 214 rtsBool ready_to_gc;
 215
 216 /* All our current task ids, saved in case we need to kill them later.
 217  */
 218 #ifdef SMP
 219 //@cindex task_ids
 220 task_info *task_ids;
 221 #endif
 222
 223 void            addToBlockedQueue ( StgTSO *tso );
 224
 225 static void     schedule          ( void );
 226        void     interruptStgRts   ( void );
 227 static StgTSO * createThread_     ( nat size, rtsBool have_lock );
 228
 229 #ifdef DEBUG
 230 static void sched_belch(char *s, ...);
 231 #endif
 232
 233 #ifdef SMP
 234 //@cindex sched_mutex
 235 //@cindex term_mutex
 236 //@cindex thread_ready_cond
 237 //@cindex gc_pending_cond
 238 pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
 239 pthread_mutex_t term_mutex        = PTHREAD_MUTEX_INITIALIZER;
 240 pthread_cond_t  thread_ready_cond = PTHREAD_COND_INITIALIZER;
 241 pthread_cond_t  gc_pending_cond   = PTHREAD_COND_INITIALIZER;
 242
 243 nat await_death;
 244 #endif
 245
 246 #if defined(PAR)
 247 StgTSO *LastTSO;
 248 rtsTime TimeOfLastYield;
 249 #endif
 250
 251 /*
 252  * The thread state for the main thread.
 253 // ToDo: check whether not needed any more
 254 StgTSO   *MainTSO;
 255  */
 256
 257
 258 //@node Prototypes, Main scheduling loop, Variables and Data structures, Main scheduling code
 259 //@subsection Prototypes
 260
 261 //@node Main scheduling loop, Suspend and Resume, Prototypes, Main scheduling code
 262 //@subsection Main scheduling loop
 263
 264 /* ---------------------------------------------------------------------------
 265    Main scheduling loop.
 266
 267    We use round-robin scheduling, each thread returning to the
 268    scheduler loop when one of these conditions is detected:
 269
 270       * out of heap space
 271       * timer expires (thread yields)
 272       * thread blocks
 273       * thread ends
 274       * stack overflow
 275
 276    Locking notes:  we acquire the scheduler lock once at the beginning
 277    of the scheduler loop, and release it when
 278
 279       * running a thread, or
 280       * waiting for work, or
 281       * waiting for a GC to complete.
 282
 283    ------------------------------------------------------------------------ */
 284 //@cindex schedule
 285 static void
 286 schedule( void )
 287 {
 288   StgTSO *t;
 289   Capability *cap;
 290   StgThreadReturnCode ret;
 291 #if defined(GRAN)
 292   rtsEvent *event;
 293 #elif defined(PAR)
 294   rtsSpark spark;
 295   StgTSO *tso;
 296   GlobalTaskId pe;
 297 #endif
 298
 299   ACQUIRE_LOCK(&sched_mutex);
 300
 301 #if defined(GRAN)
 302 # error ToDo: implement GranSim scheduler
 303 #elif defined(PAR)
 304   while (!GlobalStopPending) {          /* GlobalStopPending set in par_exit */
 305
 306     if (PendingFetches != END_BF_QUEUE) {
 307         processFetches();
 308     }
 309 #else
 310   while (1) {
 311 #endif
 312
 313     /* If we're interrupted (the user pressed ^C, or some other
 314      * termination condition occurred), kill all the currently running
 315      * threads.
 316      */
 317     if (interrupted) {
 318       IF_DEBUG(scheduler, sched_belch("interrupted"));
 319       for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 320         deleteThread(t);
 321       }
 322       for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 323         deleteThread(t);
 324       }
 325       run_queue_hd = run_queue_tl = END_TSO_QUEUE;
 326       blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
 327     }
 328
 329     /* Go through the list of main threads and wake up any
 330      * clients whose computations have finished.  ToDo: this
 331      * should be done more efficiently without a linear scan
 332      * of the main threads list, somehow...
 333      */
 334 #ifdef SMP
 335     {
 336       StgMainThread *m, **prev;
 337       prev = &main_threads;
 338       for (m = main_threads; m != NULL; m = m->link) {
 339         switch (m->tso->whatNext) {
 340         case ThreadComplete:
 341           if (m->ret) {
 342             *(m->ret) = (StgClosure *)m->tso->sp[0];
 343           }
 344           *prev = m->link;
 345           m->stat = Success;
 346           pthread_cond_broadcast(&m->wakeup);
 347           break;
 348         case ThreadKilled:
 349           *prev = m->link;
 350           if (interrupted) {
 351             m->stat = Interrupted;
 352           } else {
 353             m->stat = Killed;
 354           }
 355           pthread_cond_broadcast(&m->wakeup);
 356           break;
 357         default:
 358           break;
 359         }
 360       }
 361     }
 362 #else
 363     /* If our main thread has finished or been killed, return.
 364      */
 365     {
 366       StgMainThread *m = main_threads;
 367       if (m->tso->whatNext == ThreadComplete
 368           || m->tso->whatNext == ThreadKilled) {
 369         main_threads = main_threads->link;
 370         if (m->tso->whatNext == ThreadComplete) {
 371           /* we finished successfully, fill in the return value */
 372           if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
 373           m->stat = Success;
 374           return;
 375         } else {
 376           if (interrupted) {
 377             m->stat = Interrupted;
 378           } else {
 379             m->stat = Killed;
 380           }
 381           return;
 382         }
 383       }
 384     }
 385 #endif
 386
 387     /* Top up the run queue from our spark pool.  We try to make the
 388      * number of threads in the run queue equal to the number of
 389      * free capabilities.
 390      */
 391 #if defined(SMP)
 392     {
 393       nat n = n_free_capabilities;
 394       StgTSO *tso = run_queue_hd;
 395
 396       /* Count the run queue */
 397       while (n > 0 && tso != END_TSO_QUEUE) {
 398         tso = tso->link;
 399         n--;
 400       }
 401
 402       for (; n > 0; n--) {
 403         StgClosure *spark;
 404         spark = findSpark();
 405         if (spark == NULL) {
 406           break; /* no more sparks in the pool */
 407         } else {
 408           /* I'd prefer this to be done in activateSpark -- HWL */
 409           /* tricky - it needs to hold the scheduler lock and
 410            * not try to re-acquire it -- SDM */
 411           StgTSO *tso;
 412           tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
 413           pushClosure(tso,spark);
 414           PUSH_ON_RUN_QUEUE(tso);
 415 #ifdef PAR
 416           advisory_thread_count++;
 417 #endif
 418
 419           IF_DEBUG(scheduler,
 420                    sched_belch("turning spark of closure %p into a thread",
 421                                (StgClosure *)spark));
 422         }
 423       }
 424       /* We need to wake up the other tasks if we just created some
 425        * work for them.
 426        */
 427       if (n_free_capabilities - n > 1) {
 428           pthread_cond_signal(&thread_ready_cond);
 429       }
 430     }
 431 #endif /* SMP */
 432
 433     /* Check whether any waiting threads need to be woken up.  If the
 434      * run queue is empty, and there are no other tasks running, we
 435      * can wait indefinitely for something to happen.
 436      * ToDo: what if another client comes along & requests another
 437      * main thread?
 438      */
 439     if (blocked_queue_hd != END_TSO_QUEUE) {
 440       awaitEvent(
 441            (run_queue_hd == END_TSO_QUEUE)
 442 #ifdef SMP
 443         && (n_free_capabilities == RtsFlags.ParFlags.nNodes)
 444 #endif
 445         );
 446     }
 447
 448     /* check for signals each time around the scheduler */
 449 #ifndef __MINGW32__
 450     if (signals_pending()) {
 451       start_signal_handlers();
 452     }
 453 #endif
 454
 455     /* Detect deadlock: when we have no threads to run, there are
 456      * no threads waiting on I/O or sleeping, and all the other
 457      * tasks are waiting for work, we must have a deadlock.  Inform
 458      * all the main threads.
 459      */
 460 #ifdef SMP
 461     if (blocked_queue_hd == END_TSO_QUEUE
 462         && run_queue_hd == END_TSO_QUEUE
 463         && (n_free_capabilities == RtsFlags.ParFlags.nNodes)
 464         ) {
 465       StgMainThread *m;
 466       for (m = main_threads; m != NULL; m = m->link) {
 467           m->ret = NULL;
 468           m->stat = Deadlock;
 469           pthread_cond_broadcast(&m->wakeup);
 470       }
 471       main_threads = NULL;
 472     }
 473 #else /* ! SMP */
 474     if (blocked_queue_hd == END_TSO_QUEUE
 475         && run_queue_hd == END_TSO_QUEUE) {
 476       StgMainThread *m = main_threads;
 477       m->ret = NULL;
 478       m->stat = Deadlock;
 479       main_threads = m->link;
 480       return;
 481     }
 482 #endif
 483
 484 #ifdef SMP
 485     /* If there's a GC pending, don't do anything until it has
 486      * completed.
 487      */
 488     if (ready_to_gc) {
 489       IF_DEBUG(scheduler,sched_belch("waiting for GC"));
 490       pthread_cond_wait(&gc_pending_cond, &sched_mutex);
 491     }
 492
 493     /* block until we've got a thread on the run queue and a free
 494      * capability.
 495      */
 496     while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
 497       IF_DEBUG(scheduler, sched_belch("waiting for work"));
 498       pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 499       IF_DEBUG(scheduler, sched_belch("work now available"));
 500     }
 501 #endif
 502
 503 #if defined(GRAN)
 504 # error ToDo: implement GranSim scheduler
 505 #elif defined(PAR)
 506     /* ToDo: phps merge with spark activation above */
 507     /* check whether we have local work and send requests if we have none */
 508     if (run_queue_hd == END_TSO_QUEUE) {  /* no runnable threads */
 509       /* :-[  no local threads => look out for local sparks */
 510       if (advisory_thread_count < RtsFlags.ParFlags.maxThreads &&
 511           (pending_sparks_hd[REQUIRED_POOL] < pending_sparks_tl[REQUIRED_POOL] ||
 512            pending_sparks_hd[ADVISORY_POOL] < pending_sparks_tl[ADVISORY_POOL])) {
 513         /*
 514          * ToDo: add GC code check that we really have enough heap afterwards!!
 515          * Old comment:
 516          * If we're here (no runnable threads) and we have pending
 517          * sparks, we must have a space problem.  Get enough space
 518          * to turn one of those pending sparks into a
 519          * thread...
 520          */
 521
 522         spark = findSpark();                /* get a spark */
 523         if (spark != (rtsSpark) NULL) {
 524           tso = activateSpark(spark);       /* turn the spark into a thread */
 525           IF_PAR_DEBUG(verbose,
 526                        belch("== [%x] schedule: Created TSO %p (%d); %d threads active",
 527                              mytid, tso, tso->id, advisory_thread_count));
 528
 529           if (tso==END_TSO_QUEUE) { /* failed to activate spark->back to loop */
 530             belch("^^ failed to activate spark");
 531             goto next_thread;
 532           }               /* otherwise fall through & pick-up new tso */
 533         } else {
 534           IF_PAR_DEBUG(verbose,
 535                        belch("^^ no local sparks (spark pool contains only NFs: %d)",
 536                              spark_queue_len(ADVISORY_POOL)));
 537           goto next_thread;
 538         }
 539       } else
 540       /* =8-[  no local sparks => look for work on other PEs */
 541       {
 542         /*
 543          * We really have absolutely no work.  Send out a fish
 544          * (there may be some out there already), and wait for
 545          * something to arrive.  We clearly can't run any threads
 546          * until a SCHEDULE or RESUME arrives, and so that's what
 547          * we're hoping to see.  (Of course, we still have to
 548          * respond to other types of messages.)
 549          */
 550         if (//!fishing &&
 551             outstandingFishes < RtsFlags.ParFlags.maxFishes ) { // &&
 552           // (last_fish_arrived_at+FISH_DELAY < CURRENT_TIME)) {
 553           /* fishing set in sendFish, processFish;
 554              avoid flooding system with fishes via delay */
 555           pe = choosePE();
 556           sendFish(pe, mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
 557                    NEW_FISH_HUNGER);
 558         }
 559
 560         processMessages();
 561         goto next_thread;
 562         // ReSchedule(0);
 563       }
 564     } else if (PacketsWaiting()) {  /* Look for incoming messages */
 565       processMessages();
 566     }
 567
 568     /* Now we are sure that we have some work available */
 569     ASSERT(run_queue_hd != END_TSO_QUEUE);
 570     /* Take a thread from the run queue, if we have work */
 571     t = take_off_run_queue(END_TSO_QUEUE);
 572
 573     /* ToDo: write something to the log-file
 574     if (RTSflags.ParFlags.granSimStats && !sameThread)
 575         DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
 576     */
 577
 578     CurrentTSO = t;
 579
 580     IF_DEBUG(scheduler, belch("--^^ %d sparks on [%#x] (hd=%x; tl=%x; lim=%x)",
 581                               spark_queue_len(ADVISORY_POOL), CURRENT_PROC,
 582                               pending_sparks_hd[ADVISORY_POOL],
 583                               pending_sparks_tl[ADVISORY_POOL],
 584                               pending_sparks_lim[ADVISORY_POOL]));
 585
 586     IF_DEBUG(scheduler, belch("--== %d threads on [%#x] (hd=%x; tl=%x)",
 587                               run_queue_len(), CURRENT_PROC,
 588                               run_queue_hd, run_queue_tl));
 589
 590     if (t != LastTSO) {
 591       /*
 592          we are running a different TSO, so write a schedule event to log file
 593          NB: If we use fair scheduling we also have to write  a deschedule
 594              event for LastTSO; with unfair scheduling we know that the
 595              previous tso has blocked whenever we switch to another tso, so
 596              we don't need it in GUM for now
 597       */
 598       DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
 599                        GR_SCHEDULE, t, (StgClosure *)NULL, 0, 0);
 600
 601     }
 602
 603 #else /* !GRAN && !PAR */
 604
 605     /* grab a thread from the run queue
 606      */
 607     t = POP_RUN_QUEUE();
 608     IF_DEBUG(sanity,checkTSO(t));
 609
 610 #endif
 611
 612     /* grab a capability
 613      */
 614 #ifdef SMP
 615     cap = free_capabilities;
 616     free_capabilities = cap->link;
 617     n_free_capabilities--;
 618 #else
 619     cap = &MainRegTable;
 620 #endif
 621
 622     cap->rCurrentTSO = t;
 623
 624     /* set the context_switch flag
 625      */
 626     if (run_queue_hd == END_TSO_QUEUE)
 627       context_switch = 0;
 628     else
 629       context_switch = 1;
 630
 631     RELEASE_LOCK(&sched_mutex);
 632
 633     IF_DEBUG(scheduler,sched_belch("running thread %d", t->id));
 634
 635     /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
 636     /* Run the current thread
 637      */
 638     switch (cap->rCurrentTSO->whatNext) {
 639     case ThreadKilled:
 640     case ThreadComplete:
 641       /* Thread already finished, return to scheduler. */
 642       ret = ThreadFinished;
 643       break;
 644     case ThreadEnterGHC:
 645       ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
 646       break;
 647     case ThreadRunGHC:
 648       ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
 649       break;
 650     case ThreadEnterHugs:
 651 #ifdef INTERPRETER
 652       {
 653          StgClosure* c;
 654          IF_DEBUG(scheduler,sched_belch("entering Hugs"));
 655          c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
 656          cap->rCurrentTSO->sp += 1;
 657          ret = enter(cap,c);
 658          break;
 659       }
 660 #else
 661       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 662 #endif
 663     default:
 664       barf("schedule: invalid whatNext field");
 665     }
 666     /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
 667
 668     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 669 #ifdef PROFILING
 670     CCCS = CCS_SYSTEM;
 671 #endif
 672
 673     ACQUIRE_LOCK(&sched_mutex);
 674
 675 #ifdef SMP
 676     IF_DEBUG(scheduler,fprintf(stderr,"scheduler (task %ld): ", pthread_self()););
 677 #else
 678     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: "););
 679 #endif
 680     t = cap->rCurrentTSO;
 681
 682     switch (ret) {
 683     case HeapOverflow:
 684       /* make all the running tasks block on a condition variable,
 685        * maybe set context_switch and wait till they all pile in,
 686        * then have them wait on a GC condition variable.
 687        */
 688       IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
 689       threadPaused(t);
 690
 691       ready_to_gc = rtsTrue;
 692       context_switch = 1;               /* stop other threads ASAP */
 693       PUSH_ON_RUN_QUEUE(t);
 694       break;
 695
 696     case StackOverflow:
 697       /* just adjust the stack for this thread, then pop it back
 698        * on the run queue.
 699        */
 700       IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
 701       threadPaused(t);
 702       {
 703         StgMainThread *m;
 704         /* enlarge the stack */
 705         StgTSO *new_t = threadStackOverflow(t);
 706
 707         /* This TSO has moved, so update any pointers to it from the
 708          * main thread stack.  It better not be on any other queues...
 709          * (it shouldn't be).
 710          */
 711         for (m = main_threads; m != NULL; m = m->link) {
 712           if (m->tso == t) {
 713             m->tso = new_t;
 714           }
 715         }
 716         threadPaused(new_t);
 717         PUSH_ON_RUN_QUEUE(new_t);
 718       }
 719       break;
 720
 721     case ThreadYielding:
 722 #if defined(GRAN)
 723       IF_DEBUG(gran,
 724                DumpGranEvent(GR_DESCHEDULE, t));
 725       globalGranStats.tot_yields++;
 726 #elif defined(PAR)
 727       IF_DEBUG(par,
 728                DumpGranEvent(GR_DESCHEDULE, t));
 729 #endif
 730       /* put the thread back on the run queue.  Then, if we're ready to
 731        * GC, check whether this is the last task to stop.  If so, wake
 732        * up the GC thread.  getThread will block during a GC until the
 733        * GC is finished.
 734        */
 735       IF_DEBUG(scheduler,
 736                if (t->whatNext == ThreadEnterHugs) {
 737                  /* ToDo: or maybe a timer expired when we were in Hugs?
 738                   * or maybe someone hit ctrl-C
 739                   */
 740                  belch("thread %ld stopped to switch to Hugs", t->id);
 741                } else {
 742                  belch("thread %ld stopped, yielding", t->id);
 743                }
 744                );
 745       threadPaused(t);
 746       APPEND_TO_RUN_QUEUE(t);
 747       break;
 748
 749     case ThreadBlocked:
 750 #if defined(GRAN)
 751 # error ToDo: implement GranSim scheduler
 752 #elif defined(PAR)
 753       IF_DEBUG(par,
 754                DumpGranEvent(GR_DESCHEDULE, t));
 755 #else
 756 #endif
 757       /* don't need to do anything.  Either the thread is blocked on
 758        * I/O, in which case we'll have called addToBlockedQueue
 759        * previously, or it's blocked on an MVar or Blackhole, in which
 760        * case it'll be on the relevant queue already.
 761        */
 762       IF_DEBUG(scheduler,
 763                fprintf(stderr, "thread %d stopped, ", t->id);
 764                printThreadBlockage(t);
 765                fprintf(stderr, "\n"));
 766       threadPaused(t);
 767       break;
 768
 769     case ThreadFinished:
 770       /* Need to check whether this was a main thread, and if so, signal
 771        * the task that started it with the return value.  If we have no
 772        * more main threads, we probably need to stop all the tasks until
 773        * we get a new one.
 774        */
 775       IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
 776       t->whatNext = ThreadComplete;
 777 #if defined(GRAN)
 778       // ToDo: endThread(t, CurrentProc); // clean-up the thread
 779 #elif defined(PAR)
 780       advisory_thread_count--;
 781       if (RtsFlags.ParFlags.ParStats.Full)
 782         DumpEndEvent(CURRENT_PROC, t, rtsFalse /* not mandatory */);
 783 #endif
 784       break;
 785
 786     default:
 787       barf("doneThread: invalid thread return code");
 788     }
 789
 790 #ifdef SMP
 791     cap->link = free_capabilities;
 792     free_capabilities = cap;
 793     n_free_capabilities++;
 794 #endif
 795
 796 #ifdef SMP
 797     if (ready_to_gc && n_free_capabilities == RtsFlags.ParFlags.nNodes)
 798 #else
 799     if (ready_to_gc)
 800 #endif
 801       {
 802       /* everybody back, start the GC.
 803        * Could do it in this thread, or signal a condition var
 804        * to do it in another thread.  Either way, we need to
 805        * broadcast on gc_pending_cond afterward.
 806        */
 807 #ifdef SMP
 808       IF_DEBUG(scheduler,sched_belch("doing GC"));
 809 #endif
 810       GarbageCollect(GetRoots);
 811       ready_to_gc = rtsFalse;
 812 #ifdef SMP
 813       pthread_cond_broadcast(&gc_pending_cond);
 814 #endif
 815     }
 816 #if defined(GRAN)
 817   next_thread:
 818     IF_GRAN_DEBUG(unused,
 819                   print_eventq(EventHd));
 820
 821     event = get_next_event();
 822
 823 #elif defined(PAR)
 824   next_thread:
 825     /* ToDo: wait for next message to arrive rather than busy wait */
 826
 827 #else /* GRAN */
 828   /* not any more
 829   next_thread:
 830     t = take_off_run_queue(END_TSO_QUEUE);
 831   */
 832 #endif /* GRAN */
 833   } /* end of while(1) */
 834 }
 835
 836 /* A hack for Hugs concurrency support.  Needs sanitisation (?) */
 837 void deleteAllThreads ( void )
 838 {
 839   StgTSO* t;
 840   IF_DEBUG(scheduler,sched_belch("deleteAllThreads()"));
 841   for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 842     deleteThread(t);
 843   }
 844   for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 845     deleteThread(t);
 846   }
 847   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
 848   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
 849 }
 850
 851 /* startThread and  insertThread are now in GranSim.c -- HWL */
 852
 853 //@node Suspend and Resume, Run queue code, Main scheduling loop, Main scheduling code
 854 //@subsection Suspend and Resume
 855
 856 /* ---------------------------------------------------------------------------
 857  * Suspending & resuming Haskell threads.
 858  *
 859  * When making a "safe" call to C (aka _ccall_GC), the task gives back
 860  * its capability before calling the C function.  This allows another
 861  * task to pick up the capability and carry on running Haskell
 862  * threads.  It also means that if the C call blocks, it won't lock
 863  * the whole system.
 864  *
 865  * The Haskell thread making the C call is put to sleep for the
 866  * duration of the call, on the susepended_ccalling_threads queue.  We
 867  * give out a token to the task, which it can use to resume the thread
 868  * on return from the C function.
 869  * ------------------------------------------------------------------------- */
 870
 871 StgInt
 872 suspendThread( Capability *cap )
 873 {
 874   nat tok;
 875
 876   ACQUIRE_LOCK(&sched_mutex);
 877
 878   IF_DEBUG(scheduler,
 879            sched_belch("thread %d did a _ccall_gc\n", cap->rCurrentTSO->id));
 880
 881   threadPaused(cap->rCurrentTSO);
 882   cap->rCurrentTSO->link = suspended_ccalling_threads;
 883   suspended_ccalling_threads = cap->rCurrentTSO;
 884
 885   /* Use the thread ID as the token; it should be unique */
 886   tok = cap->rCurrentTSO->id;
 887
 888 #ifdef SMP
 889   cap->link = free_capabilities;
 890   free_capabilities = cap;
 891   n_free_capabilities++;
 892 #endif
 893
 894   RELEASE_LOCK(&sched_mutex);
 895   return tok;
 896 }
 897
 898 Capability *
 899 resumeThread( StgInt tok )
 900 {
 901   StgTSO *tso, **prev;
 902   Capability *cap;
 903
 904   ACQUIRE_LOCK(&sched_mutex);
 905
 906   prev = &suspended_ccalling_threads;
 907   for (tso = suspended_ccalling_threads;
 908        tso != END_TSO_QUEUE;
 909        prev = &tso->link, tso = tso->link) {
 910     if (tso->id == (StgThreadID)tok) {
 911       *prev = tso->link;
 912       break;
 913     }
 914   }
 915   if (tso == END_TSO_QUEUE) {
 916     barf("resumeThread: thread not found");
 917   }
 918
 919 #ifdef SMP
 920   while (free_capabilities == NULL) {
 921     IF_DEBUG(scheduler, sched_belch("waiting to resume"));
 922     pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 923     IF_DEBUG(scheduler, sched_belch("resuming thread %d", tso->id));
 924   }
 925   cap = free_capabilities;
 926   free_capabilities = cap->link;
 927   n_free_capabilities--;
 928 #else
 929   cap = &MainRegTable;
 930 #endif
 931
 932   cap->rCurrentTSO = tso;
 933
 934   RELEASE_LOCK(&sched_mutex);
 935   return cap;
 936 }
 937
 938
 939 /* ---------------------------------------------------------------------------
 940  * Static functions
 941  * ------------------------------------------------------------------------ */
 942 static void unblockThread(StgTSO *tso);
 943
 944 /* ---------------------------------------------------------------------------
 945  * Comparing Thread ids.
 946  *
 947  * This is used from STG land in the implementation of the
 948  * instances of Eq/Ord for ThreadIds.
 949  * ------------------------------------------------------------------------ */
 950
 951 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
 952 {
 953   StgThreadID id1 = tso1->id;
 954   StgThreadID id2 = tso2->id;
 955
 956   if (id1 < id2) return (-1);
 957   if (id1 > id2) return 1;
 958   return 0;
 959 }
 960
 961 /* ---------------------------------------------------------------------------
 962    Create a new thread.
 963
 964    The new thread starts with the given stack size.  Before the
 965    scheduler can run, however, this thread needs to have a closure
 966    (and possibly some arguments) pushed on its stack.  See
 967    pushClosure() in Schedule.h.
 968
 969    createGenThread() and createIOThread() (in SchedAPI.h) are
 970    convenient packaged versions of this function.
 971    ------------------------------------------------------------------------ */
 972 //@cindex createThread
 973 #if defined(GRAN)
 974 /* currently pri (priority) is only used in a GRAN setup -- HWL */
 975 StgTSO *
 976 createThread(nat stack_size, StgInt pri)
 977 {
 978   return createThread_(stack_size, rtsFalse, pri);
 979 }
 980
 981 static StgTSO *
 982 createThread_(nat size, rtsBool have_lock, StgInt pri)
 983 {
 984 #else
 985 StgTSO *
 986 createThread(nat stack_size)
 987 {
 988   return createThread_(stack_size, rtsFalse);
 989 }
 990
 991 static StgTSO *
 992 createThread_(nat size, rtsBool have_lock)
 993 {
 994 #endif
 995     StgTSO *tso;
 996     nat stack_size;
 997
 998     /* First check whether we should create a thread at all */
 999 #if defined(PAR)
1000   /* check that no more than RtsFlags.ParFlags.maxThreads threads are created */
1001   if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads) {
1002     threadsIgnored++;
1003     belch("{createThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
1004           RtsFlags.ParFlags.maxThreads, advisory_thread_count);
1005     return END_TSO_QUEUE;
1006   }
1007   threadsCreated++;
1008 #endif
1009
1010 #if defined(GRAN)
1011   ASSERT(!RtsFlags.GranFlags.Light || CurrentProc==0);
1012 #endif
1013
1014   // ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW
1015
1016   /* catch ridiculously small stack sizes */
1017   if (size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
1018     size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
1019   }
1020
1021   tso = (StgTSO *)allocate(size);
1022   TICK_ALLOC_TSO(size-sizeofW(StgTSO),0);
1023
1024   stack_size = size - TSO_STRUCT_SIZEW;
1025
1026   // Hmm, this CCS_MAIN is not protected by a PROFILING cpp var;
1027   SET_HDR(tso, &TSO_info, CCS_MAIN);
1028 #if defined(GRAN)
1029   SET_GRAN_HDR(tso, ThisPE);
1030 #endif
1031   tso->whatNext     = ThreadEnterGHC;
1032
1033   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
1034          protect the increment operation on next_thread_id.
1035          In future, we could use an atomic increment instead.
1036   */
1037
1038   if (!have_lock) { ACQUIRE_LOCK(&sched_mutex); }
1039   tso->id = next_thread_id++;
1040   if (!have_lock) { RELEASE_LOCK(&sched_mutex); }
1041
1042   tso->why_blocked  = NotBlocked;
1043   tso->blocked_exceptions = NULL;
1044
1045   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
1046   tso->stack_size   = stack_size;
1047   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
1048                               - TSO_STRUCT_SIZEW;
1049   tso->sp           = (P_)&(tso->stack) + stack_size;
1050
1051 #ifdef PROFILING
1052   tso->prof.CCCS = CCS_MAIN;
1053 #endif
1054
1055   /* put a stop frame on the stack */
1056   tso->sp -= sizeofW(StgStopFrame);
1057   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
1058   tso->su = (StgUpdateFrame*)tso->sp;
1059
1060   IF_DEBUG(scheduler,belch("---- Initialised TSO %ld (%p), stack size = %lx words",
1061                            tso->id, tso, tso->stack_size));
1062
1063   // ToDo: check this
1064 #if defined(GRAN)
1065   tso->link = END_TSO_QUEUE;
1066   /* uses more flexible routine in GranSim */
1067   insertThread(tso, CurrentProc);
1068 #else
1069   /* In a non-GranSim setup the pushing of a TSO onto the runq is separated
1070      from its creation
1071   */
1072 #endif
1073
1074 #if defined(GRAN)
1075   tso->gran.pri = pri;
1076   tso->gran.magic = TSO_MAGIC; // debugging only
1077   tso->gran.sparkname   = 0;
1078   tso->gran.startedat   = CURRENT_TIME;
1079   tso->gran.exported    = 0;
1080   tso->gran.basicblocks = 0;
1081   tso->gran.allocs      = 0;
1082   tso->gran.exectime    = 0;
1083   tso->gran.fetchtime   = 0;
1084   tso->gran.fetchcount  = 0;
1085   tso->gran.blocktime   = 0;
1086   tso->gran.blockcount  = 0;
1087   tso->gran.blockedat   = 0;
1088   tso->gran.globalsparks = 0;
1089   tso->gran.localsparks  = 0;
1090   if (RtsFlags.GranFlags.Light)
1091     tso->gran.clock  = Now; /* local clock */
1092   else
1093     tso->gran.clock  = 0;
1094
1095   IF_DEBUG(gran,printTSO(tso));
1096 #elif defined(PAR)
1097   tso->par.sparkname   = 0;
1098   tso->par.startedat   = CURRENT_TIME;
1099   tso->par.exported    = 0;
1100   tso->par.basicblocks = 0;
1101   tso->par.allocs      = 0;
1102   tso->par.exectime    = 0;
1103   tso->par.fetchtime   = 0;
1104   tso->par.fetchcount  = 0;
1105   tso->par.blocktime   = 0;
1106   tso->par.blockcount  = 0;
1107   tso->par.blockedat   = 0;
1108   tso->par.globalsparks = 0;
1109   tso->par.localsparks  = 0;
1110 #endif
1111
1112 #if defined(GRAN)
1113   globalGranStats.tot_threads_created++;
1114   globalGranStats.threads_created_on_PE[CurrentProc]++;
1115   globalGranStats.tot_sq_len += spark_queue_len(CurrentProc);
1116   globalGranStats.tot_sq_probes++;
1117 #endif
1118
1119   IF_DEBUG(scheduler,sched_belch("created thread %ld, stack size = %lx words",
1120                                  tso->id, tso->stack_size));
1121   return tso;
1122 }
1123
1124 /* ---------------------------------------------------------------------------
1125  * scheduleThread()
1126  *
1127  * scheduleThread puts a thread on the head of the runnable queue.
1128  * This will usually be done immediately after a thread is created.
1129  * The caller of scheduleThread must create the thread using e.g.
1130  * createThread and push an appropriate closure
1131  * on this thread's stack before the scheduler is invoked.
1132  * ------------------------------------------------------------------------ */
1133
1134 void
1135 scheduleThread(StgTSO *tso)
1136 {
1137   ACQUIRE_LOCK(&sched_mutex);
1138
1139   /* Put the new thread on the head of the runnable queue.  The caller
1140    * better push an appropriate closure on this thread's stack
1141    * beforehand.  In the SMP case, the thread may start running as
1142    * soon as we release the scheduler lock below.
1143    */
1144   PUSH_ON_RUN_QUEUE(tso);
1145   THREAD_RUNNABLE();
1146
1147   IF_DEBUG(scheduler,printTSO(tso));
1148   RELEASE_LOCK(&sched_mutex);
1149 }
1150
1151 /* ---------------------------------------------------------------------------
1152  * startTasks()
1153  *
1154  * Start up Posix threads to run each of the scheduler tasks.
1155  * I believe the task ids are not needed in the system as defined.
1156  *  KH @ 25/10/99
1157  * ------------------------------------------------------------------------ */
1158
1159 #ifdef SMP
1160 static void *
1161 taskStart( void *arg STG_UNUSED )
1162 {
1163   schedule();
1164   return NULL;
1165 }
1166 #endif
1167
1168 /* ---------------------------------------------------------------------------
1169  * initScheduler()
1170  *
1171  * Initialise the scheduler.  This resets all the queues - if the
1172  * queues contained any threads, they'll be garbage collected at the
1173  * next pass.
1174  *
1175  * This now calls startTasks(), so should only be called once!  KH @ 25/10/99
1176  * ------------------------------------------------------------------------ */
1177
1178 #ifdef SMP
1179 static void
1180 term_handler(int sig STG_UNUSED)
1181 {
1182   stat_workerStop();
1183   ACQUIRE_LOCK(&term_mutex);
1184   await_death--;
1185   RELEASE_LOCK(&term_mutex);
1186   pthread_exit(NULL);
1187 }
1188 #endif
1189
1190 //@cindex initScheduler
1191 void
1192 initScheduler(void)
1193 {
1194 #if defined(GRAN)
1195   nat i;
1196
1197   for (i=0; i<=MAX_PROC; i++) {
1198     run_queue_hds[i]      = END_TSO_QUEUE;
1199     run_queue_tls[i]      = END_TSO_QUEUE;
1200     blocked_queue_hds[i]  = END_TSO_QUEUE;
1201     blocked_queue_tls[i]  = END_TSO_QUEUE;
1202     ccalling_threadss[i]  = END_TSO_QUEUE;
1203   }
1204 #else
1205   run_queue_hd      = END_TSO_QUEUE;
1206   run_queue_tl      = END_TSO_QUEUE;
1207   blocked_queue_hd  = END_TSO_QUEUE;
1208   blocked_queue_tl  = END_TSO_QUEUE;
1209 #endif
1210
1211   suspended_ccalling_threads  = END_TSO_QUEUE;
1212
1213   main_threads = NULL;
1214
1215   context_switch = 0;
1216   interrupted    = 0;
1217
1218   enteredCAFs = END_CAF_LIST;
1219
1220   /* Install the SIGHUP handler */
1221 #ifdef SMP
1222   {
1223     struct sigaction action,oact;
1224
1225     action.sa_handler = term_handler;
1226     sigemptyset(&action.sa_mask);
1227     action.sa_flags = 0;
1228     if (sigaction(SIGTERM, &action, &oact) != 0) {
1229       barf("can't install TERM handler");
1230     }
1231   }
1232 #endif
1233
1234 #ifdef SMP
1235   /* Allocate N Capabilities */
1236   {
1237     nat i;
1238     Capability *cap, *prev;
1239     cap  = NULL;
1240     prev = NULL;
1241     for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
1242       cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
1243       cap->link = prev;
1244       prev = cap;
1245     }
1246     free_capabilities = cap;
1247     n_free_capabilities = RtsFlags.ParFlags.nNodes;
1248   }
1249   IF_DEBUG(scheduler,fprintf(stderr,"scheduler: Allocated %d capabilities\n",
1250                              n_free_capabilities););
1251 #endif
1252
1253 #if defined(SMP) || defined(PAR)
1254   initSparkPools();
1255 #endif
1256 }
1257
1258 #ifdef SMP
1259 void
1260 startTasks( void )
1261 {
1262   nat i;
1263   int r;
1264   pthread_t tid;
1265
1266   /* make some space for saving all the thread ids */
1267   task_ids = stgMallocBytes(RtsFlags.ParFlags.nNodes * sizeof(task_info),
1268                             "initScheduler:task_ids");
1269
1270   /* and create all the threads */
1271   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
1272     r = pthread_create(&tid,NULL,taskStart,NULL);
1273     if (r != 0) {
1274       barf("startTasks: Can't create new Posix thread");
1275     }
1276     task_ids[i].id = tid;
1277     task_ids[i].mut_time = 0.0;
1278     task_ids[i].mut_etime = 0.0;
1279     task_ids[i].gc_time = 0.0;
1280     task_ids[i].gc_etime = 0.0;
1281     task_ids[i].elapsedtimestart = elapsedtime();
1282     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: Started task: %ld\n",tid););
1283   }
1284 }
1285 #endif
1286
1287 void
1288 exitScheduler( void )
1289 {
1290 #ifdef SMP
1291   nat i;
1292
1293   /* Don't want to use pthread_cancel, since we'd have to install
1294    * these silly exception handlers (pthread_cleanup_{push,pop}) around
1295    * all our locks.
1296    */
1297 #if 0
1298   /* Cancel all our tasks */
1299   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
1300     pthread_cancel(task_ids[i].id);
1301   }
1302
1303   /* Wait for all the tasks to terminate */
1304   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
1305     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: waiting for task %ld\n",
1306                                task_ids[i].id));
1307     pthread_join(task_ids[i].id, NULL);
1308   }
1309 #endif
1310
1311   /* Send 'em all a SIGHUP.  That should shut 'em up.
1312    */
1313   await_death = RtsFlags.ParFlags.nNodes;
1314   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
1315     pthread_kill(task_ids[i].id,SIGTERM);
1316   }
1317   while (await_death > 0) {
1318     sched_yield();
1319   }
1320 #endif
1321 }
1322
1323 /* -----------------------------------------------------------------------------
1324    Managing the per-task allocation areas.
1325
1326    Each capability comes with an allocation area.  These are
1327    fixed-length block lists into which allocation can be done.
1328
1329    ToDo: no support for two-space collection at the moment???
1330    -------------------------------------------------------------------------- */
1331
1332 /* -----------------------------------------------------------------------------
1333  * waitThread is the external interface for running a new computataion
1334  * and waiting for the result.
1335  *
1336  * In the non-SMP case, we create a new main thread, push it on the
1337  * main-thread stack, and invoke the scheduler to run it.  The
1338  * scheduler will return when the top main thread on the stack has
1339  * completed or died, and fill in the necessary fields of the
1340  * main_thread structure.
1341  *
1342  * In the SMP case, we create a main thread as before, but we then
1343  * create a new condition variable and sleep on it.  When our new
1344  * main thread has completed, we'll be woken up and the status/result
1345  * will be in the main_thread struct.
1346  * -------------------------------------------------------------------------- */
1347
1348 SchedulerStatus
1349 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
1350 {
1351   StgMainThread *m;
1352   SchedulerStatus stat;
1353
1354   ACQUIRE_LOCK(&sched_mutex);
1355
1356   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
1357
1358   m->tso = tso;
1359   m->ret = ret;
1360   m->stat = NoStatus;
1361 #ifdef SMP
1362   pthread_cond_init(&m->wakeup, NULL);
1363 #endif
1364
1365   m->link = main_threads;
1366   main_threads = m;
1367
1368   IF_DEBUG(scheduler, fprintf(stderr, "scheduler: new main thread (%d)\n",
1369                               m->tso->id));
1370
1371 #ifdef SMP
1372   do {
1373     pthread_cond_wait(&m->wakeup, &sched_mutex);
1374   } while (m->stat == NoStatus);
1375 #else
1376   schedule();
1377   ASSERT(m->stat != NoStatus);
1378 #endif
1379
1380   stat = m->stat;
1381
1382 #ifdef SMP
1383   pthread_cond_destroy(&m->wakeup);
1384 #endif
1385
1386   IF_DEBUG(scheduler, fprintf(stderr, "scheduler: main thread (%d) finished\n",
1387                               m->tso->id));
1388   free(m);
1389
1390   RELEASE_LOCK(&sched_mutex);
1391
1392   return stat;
1393 }
1394
1395 //@node Run queue code, Garbage Collextion Routines, Suspend and Resume, Main scheduling code
1396 //@subsection Run queue code
1397
1398 #if 0
1399 /*
1400    NB: In GranSim we have many run queues; run_queue_hd is actually a macro
1401        unfolding to run_queue_hds[CurrentProc], thus CurrentProc is an
1402        implicit global variable that has to be correct when calling these
1403        fcts -- HWL
1404 */
1405
1406 /* Put the new thread on the head of the runnable queue.
1407  * The caller of createThread better push an appropriate closure
1408  * on this thread's stack before the scheduler is invoked.
1409  */
1410 static /* inline */ void
1411 add_to_run_queue(tso)
1412 StgTSO* tso;
1413 {
1414   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
1415   tso->link = run_queue_hd;
1416   run_queue_hd = tso;
1417   if (run_queue_tl == END_TSO_QUEUE) {
1418     run_queue_tl = tso;
1419   }
1420 }
1421
1422 /* Put the new thread at the end of the runnable queue. */
1423 static /* inline */ void
1424 push_on_run_queue(tso)
1425 StgTSO* tso;
1426 {
1427   ASSERT(get_itbl((StgClosure *)tso)->type == TSO);
1428   ASSERT(run_queue_hd!=NULL && run_queue_tl!=NULL);
1429   ASSERT(tso!=run_queue_hd && tso!=run_queue_tl);
1430   if (run_queue_hd == END_TSO_QUEUE) {
1431     run_queue_hd = tso;
1432   } else {
1433     run_queue_tl->link = tso;
1434   }
1435   run_queue_tl = tso;
1436 }
1437
1438 /*
1439    Should be inlined because it's used very often in schedule.  The tso
1440    argument is actually only needed in GranSim, where we want to have the
1441    possibility to schedule *any* TSO on the run queue, irrespective of the
1442    actual ordering. Therefore, if tso is not the nil TSO then we traverse
1443    the run queue and dequeue the tso, adjusting the links in the queue.
1444 */
1445 //@cindex take_off_run_queue
1446 static /* inline */ StgTSO*
1447 take_off_run_queue(StgTSO *tso) {
1448   StgTSO *t, *prev;
1449
1450   /*
1451      qetlaHbogh Qu' ngaSbogh ghomDaQ {tso} yIteq!
1452
1453      if tso is specified, unlink that tso from the run_queue (doesn't have
1454      to be at the beginning of the queue); GranSim only
1455   */
1456   if (tso!=END_TSO_QUEUE) {
1457     /* find tso in queue */
1458     for (t=run_queue_hd, prev=END_TSO_QUEUE;
1459          t!=END_TSO_QUEUE && t!=tso;
1460          prev=t, t=t->link)
1461       /* nothing */ ;
1462     ASSERT(t==tso);
1463     /* now actually dequeue the tso */
1464     if (prev!=END_TSO_QUEUE) {
1465       ASSERT(run_queue_hd!=t);
1466       prev->link = t->link;
1467     } else {
1468       /* t is at beginning of thread queue */
1469       ASSERT(run_queue_hd==t);
1470       run_queue_hd = t->link;
1471     }
1472     /* t is at end of thread queue */
1473     if (t->link==END_TSO_QUEUE) {
1474       ASSERT(t==run_queue_tl);
1475       run_queue_tl = prev;
1476     } else {
1477       ASSERT(run_queue_tl!=t);
1478     }
1479     t->link = END_TSO_QUEUE;
1480   } else {
1481     /* take tso from the beginning of the queue; std concurrent code */
1482     t = run_queue_hd;
1483     if (t != END_TSO_QUEUE) {
1484       run_queue_hd = t->link;
1485       t->link = END_TSO_QUEUE;
1486       if (run_queue_hd == END_TSO_QUEUE) {
1487         run_queue_tl = END_TSO_QUEUE;
1488       }
1489     }
1490   }
1491   return t;
1492 }
1493
1494 #endif /* 0 */
1495
1496 //@node Garbage Collextion Routines, Blocking Queue Routines, Run queue code, Main scheduling code
1497 //@subsection Garbage Collextion Routines
1498
1499 /* ---------------------------------------------------------------------------
1500    Where are the roots that we know about?
1501
1502         - all the threads on the runnable queue
1503         - all the threads on the blocked queue
1504         - all the thread currently executing a _ccall_GC
1505         - all the "main threads"
1506
1507    ------------------------------------------------------------------------ */
1508
1509 /* This has to be protected either by the scheduler monitor, or by the
1510         garbage collection monitor (probably the latter).
1511         KH @ 25/10/99
1512 */
1513
1514 static void GetRoots(void)
1515 {
1516   StgMainThread *m;
1517
1518 #if defined(GRAN)
1519   {
1520     nat i;
1521     for (i=0; i<=RtsFlags.GranFlags.proc; i++) {
1522       if ((run_queue_hds[i] != END_TSO_QUEUE) && ((run_queue_hds[i] != NULL)))
1523         run_queue_hds[i]    = (StgTSO *)MarkRoot((StgClosure *)run_queue_hds[i]);
1524       if ((run_queue_tls[i] != END_TSO_QUEUE) && ((run_queue_tls[i] != NULL)))
1525         run_queue_tls[i]    = (StgTSO *)MarkRoot((StgClosure *)run_queue_tls[i]);
1526
1527       if ((blocked_queue_hds[i] != END_TSO_QUEUE) && ((blocked_queue_hds[i] != NULL)))
1528         blocked_queue_hds[i] = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hds[i]);
1529       if ((blocked_queue_tls[i] != END_TSO_QUEUE) && ((blocked_queue_tls[i] != NULL)))
1530         blocked_queue_tls[i] = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tls[i]);
1531       if ((ccalling_threadss[i] != END_TSO_QUEUE) && ((ccalling_threadss[i] != NULL)))
1532         ccalling_threadss[i] = (StgTSO *)MarkRoot((StgClosure *)ccalling_threadss[i]);
1533     }
1534   }
1535
1536   markEventQueue();
1537
1538 #else /* !GRAN */
1539   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1540   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1541
1542   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1543   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1544 #endif
1545
1546   for (m = main_threads; m != NULL; m = m->link) {
1547     m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1548   }
1549   suspended_ccalling_threads =
1550     (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1551
1552 #if defined(SMP) || defined(PAR) || defined(GRAN)
1553   markSparkQueue();
1554 #endif
1555 }
1556
1557 /* -----------------------------------------------------------------------------
1558    performGC
1559
1560    This is the interface to the garbage collector from Haskell land.
1561    We provide this so that external C code can allocate and garbage
1562    collect when called from Haskell via _ccall_GC.
1563
1564    It might be useful to provide an interface whereby the programmer
1565    can specify more roots (ToDo).
1566
1567    This needs to be protected by the GC condition variable above.  KH.
1568    -------------------------------------------------------------------------- */
1569
1570 void (*extra_roots)(void);
1571
1572 void
1573 performGC(void)
1574 {
1575   GarbageCollect(GetRoots);
1576 }
1577
1578 static void
1579 AllRoots(void)
1580 {
1581   GetRoots();                   /* the scheduler's roots */
1582   extra_roots();                /* the user's roots */
1583 }
1584
1585 void
1586 performGCWithRoots(void (*get_roots)(void))
1587 {
1588   extra_roots = get_roots;
1589
1590   GarbageCollect(AllRoots);
1591 }
1592
1593 /* -----------------------------------------------------------------------------
1594    Stack overflow
1595
1596    If the thread has reached its maximum stack size, then raise the
1597    StackOverflow exception in the offending thread.  Otherwise
1598    relocate the TSO into a larger chunk of memory and adjust its stack
1599    size appropriately.
1600    -------------------------------------------------------------------------- */
1601
1602 static StgTSO *
1603 threadStackOverflow(StgTSO *tso)
1604 {
1605   nat new_stack_size, new_tso_size, diff, stack_words;
1606   StgPtr new_sp;
1607   StgTSO *dest;
1608
1609   IF_DEBUG(sanity,checkTSO(tso));
1610   if (tso->stack_size >= tso->max_stack_size) {
1611 #if 0
1612     /* If we're debugging, just print out the top of the stack */
1613     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1614                                      tso->sp+64));
1615 #endif
1616 #ifdef INTERPRETER
1617     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1618     exit(1);
1619 #else
1620     /* Send this thread the StackOverflow exception */
1621     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1622 #endif
1623     return tso;
1624   }
1625
1626   /* Try to double the current stack size.  If that takes us over the
1627    * maximum stack size for this thread, then use the maximum instead.
1628    * Finally round up so the TSO ends up as a whole number of blocks.
1629    */
1630   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1631   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1632                                        TSO_STRUCT_SIZE)/sizeof(W_);
1633   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
1634   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1635
1636   IF_DEBUG(scheduler, fprintf(stderr,"scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1637
1638   dest = (StgTSO *)allocate(new_tso_size);
1639   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1640
1641   /* copy the TSO block and the old stack into the new area */
1642   memcpy(dest,tso,TSO_STRUCT_SIZE);
1643   stack_words = tso->stack + tso->stack_size - tso->sp;
1644   new_sp = (P_)dest + new_tso_size - stack_words;
1645   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1646
1647   /* relocate the stack pointers... */
1648   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1649   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
1650   dest->sp    = new_sp;
1651   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1652   dest->stack_size = new_stack_size;
1653
1654   /* and relocate the update frame list */
1655   relocate_TSO(tso, dest);
1656
1657   /* Mark the old TSO as relocated.  We have to check for relocated
1658    * TSOs in the garbage collector and any primops that deal with TSOs.
1659    *
1660    * It's important to set the sp and su values to just beyond the end
1661    * of the stack, so we don't attempt to scavenge any part of the
1662    * dead TSO's stack.
1663    */
1664   tso->whatNext = ThreadRelocated;
1665   tso->link = dest;
1666   tso->sp = (P_)&(tso->stack[tso->stack_size]);
1667   tso->su = (StgUpdateFrame *)tso->sp;
1668   tso->why_blocked = NotBlocked;
1669   dest->mut_link = NULL;
1670
1671   IF_DEBUG(sanity,checkTSO(tso));
1672 #if 0
1673   IF_DEBUG(scheduler,printTSO(dest));
1674 #endif
1675
1676   return dest;
1677 }
1678
1679 //@node Blocking Queue Routines, Exception Handling Routines, Garbage Collextion Routines, Main scheduling code
1680 //@subsection Blocking Queue Routines
1681
1682 /* ---------------------------------------------------------------------------
1683    Wake up a queue that was blocked on some resource.
1684    ------------------------------------------------------------------------ */
1685
1686 /* ToDo: check push_on_run_queue vs. PUSH_ON_RUN_QUEUE */
1687
1688 #if defined(GRAN)
1689 static inline void
1690 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
1691 {
1692 }
1693 #elif defined(PAR)
1694 static inline void
1695 unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
1696 {
1697   /* write RESUME events to log file and
1698      update blocked and fetch time (depending on type of the orig closure) */
1699   if (RtsFlags.ParFlags.ParStats.Full) {
1700     DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
1701                      GR_RESUMEQ, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
1702                      0, 0 /* spark_queue_len(ADVISORY_POOL) */);
1703
1704     switch (get_itbl(node)->type) {
1705         case FETCH_ME_BQ:
1706           ((StgTSO *)bqe)->par.fetchtime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
1707           break;
1708         case RBH:
1709         case FETCH_ME:
1710         case BLACKHOLE_BQ:
1711           ((StgTSO *)bqe)->par.blocktime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
1712           break;
1713         default:
1714           barf("{unblockOneLocked}Daq Qagh: unexpected closure in blocking queue");
1715         }
1716       }
1717 }
1718 #endif
1719
1720 #if defined(GRAN)
1721 static StgBlockingQueueElement *
1722 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
1723 {
1724     StgBlockingQueueElement *next;
1725     PEs node_loc, tso_loc;
1726
1727     node_loc = where_is(node); // should be lifted out of loop
1728     tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
1729     tso_loc = where_is(tso);
1730     if (IS_LOCAL_TO(PROCS(node),tso_loc)) { // TSO is local
1731       /* !fake_fetch => TSO is on CurrentProc is same as IS_LOCAL_TO */
1732       ASSERT(CurrentProc!=node_loc || tso_loc==CurrentProc);
1733       bq_processing_time += RtsFlags.GranFlags.Costs.lunblocktime;
1734       // insertThread(tso, node_loc);
1735       new_event(tso_loc, tso_loc,
1736                 CurrentTime[CurrentProc]+bq_processing_time,
1737                 ResumeThread,
1738                 tso, node, (rtsSpark*)NULL);
1739       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
1740       // len_local++;
1741       // len++;
1742     } else { // TSO is remote (actually should be FMBQ)
1743       bq_processing_time += RtsFlags.GranFlags.Costs.mpacktime;
1744       bq_processing_time += RtsFlags.GranFlags.Costs.gunblocktime;
1745       new_event(tso_loc, CurrentProc,
1746                 CurrentTime[CurrentProc]+bq_processing_time+
1747                 RtsFlags.GranFlags.Costs.latency,
1748                 UnblockThread,
1749                 tso, node, (rtsSpark*)NULL);
1750       tso->link = END_TSO_QUEUE; // overwrite link just to be sure
1751       bq_processing_time += RtsFlags.GranFlags.Costs.mtidytime;
1752       // len++;
1753     }
1754     /* the thread-queue-overhead is accounted for in either Resume or UnblockThread */
1755     IF_GRAN_DEBUG(bq,
1756                   fprintf(stderr," %s TSO %d (%p) [PE %d] (blocked_on=%p) (next=%p) ,",
1757                           (node_loc==tso_loc ? "Local" : "Global"),
1758                           tso->id, tso, CurrentProc, tso->blocked_on, tso->link))
1759     tso->blocked_on = NULL;
1760     IF_DEBUG(scheduler,belch("-- Waking up thread %ld (%p)",
1761                              tso->id, tso));
1762   }
1763
1764   /* if this is the BQ of an RBH, we have to put back the info ripped out of
1765      the closure to make room for the anchor of the BQ */
1766   if (next!=END_BQ_QUEUE) {
1767     ASSERT(get_itbl(node)->type == RBH && get_itbl(next)->type == CONSTR);
1768     /*
1769     ASSERT((info_ptr==&RBH_Save_0_info) ||
1770            (info_ptr==&RBH_Save_1_info) ||
1771            (info_ptr==&RBH_Save_2_info));
1772     */
1773     /* cf. convertToRBH in RBH.c for writing the RBHSave closure */
1774     ((StgRBH *)node)->blocking_queue = ((StgRBHSave *)next)->payload[0];
1775     ((StgRBH *)node)->mut_link       = ((StgRBHSave *)next)->payload[1];
1776
1777     IF_GRAN_DEBUG(bq,
1778                   belch("## Filled in RBH_Save for %p (%s) at end of AwBQ",
1779                         node, info_type(node)));
1780   }
1781 }
1782 #elif defined(PAR)
1783 static StgBlockingQueueElement *
1784 unblockOneLocked(StgBlockingQueueElement *bqe, StgClosure *node)
1785 {
1786     StgBlockingQueueElement *next;
1787
1788     switch (get_itbl(bqe)->type) {
1789     case TSO:
1790       ASSERT(((StgTSO *)bqe)->why_blocked != NotBlocked);
1791       /* if it's a TSO just push it onto the run_queue */
1792       next = bqe->link;
1793       // ((StgTSO *)bqe)->link = END_TSO_QUEUE; // debugging?
1794       PUSH_ON_RUN_QUEUE((StgTSO *)bqe);
1795       THREAD_RUNNABLE();
1796       unblockCount(bqe, node);
1797       /* reset blocking status after dumping event */
1798       ((StgTSO *)bqe)->why_blocked = NotBlocked;
1799       break;
1800
1801     case BLOCKED_FETCH:
1802       /* if it's a BLOCKED_FETCH put it on the PendingFetches list */
1803       next = bqe->link;
1804       bqe->link = PendingFetches;
1805       PendingFetches = bqe;
1806       break;
1807
1808 # if defined(DEBUG)
1809       /* can ignore this case in a non-debugging setup;
1810          see comments on RBHSave closures above */
1811     case CONSTR:
1812       /* check that the closure is an RBHSave closure */
1813       ASSERT(get_itbl((StgClosure *)bqe) == &RBH_Save_0_info ||
1814              get_itbl((StgClosure *)bqe) == &RBH_Save_1_info ||
1815              get_itbl((StgClosure *)bqe) == &RBH_Save_2_info);
1816       break;
1817
1818     default:
1819       barf("{unblockOneLocked}Daq Qagh: Unexpected IP (%#lx; %s) in blocking queue at %#lx\n",
1820            get_itbl((StgClosure *)bqe), info_type((StgClosure *)bqe),
1821            (StgClosure *)bqe);
1822 # endif
1823     }
1824   // IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
1825   return next;
1826 }
1827
1828 #else /* !GRAN && !PAR */
1829 static StgTSO *
1830 unblockOneLocked(StgTSO *tso)
1831 {
1832   StgTSO *next;
1833
1834   ASSERT(get_itbl(tso)->type == TSO);
1835   ASSERT(tso->why_blocked != NotBlocked);
1836   tso->why_blocked = NotBlocked;
1837   next = tso->link;
1838   PUSH_ON_RUN_QUEUE(tso);
1839   THREAD_RUNNABLE();
1840   IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
1841   return next;
1842 }
1843 #endif
1844
1845 #if defined(GRAN)
1846 inline StgTSO *
1847 unblockOne(StgTSO *tso, StgClosure *node)
1848 {
1849   ACQUIRE_LOCK(&sched_mutex);
1850   tso = unblockOneLocked(tso, node);
1851   RELEASE_LOCK(&sched_mutex);
1852   return tso;
1853 }
1854 #elif defined(PAR)
1855 inline StgTSO *
1856 unblockOne(StgTSO *tso, StgClosure *node)
1857 {
1858   ACQUIRE_LOCK(&sched_mutex);
1859   tso = unblockOneLocked(tso, node);
1860   RELEASE_LOCK(&sched_mutex);
1861   return tso;
1862 }
1863 #else
1864 inline StgTSO *
1865 unblockOne(StgTSO *tso)
1866 {
1867   ACQUIRE_LOCK(&sched_mutex);
1868   tso = unblockOneLocked(tso);
1869   RELEASE_LOCK(&sched_mutex);
1870   return tso;
1871 }
1872 #endif
1873
1874 #if defined(GRAN)
1875 void
1876 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
1877 {
1878   StgBlockingQueueElement *bqe, *next;
1879   StgTSO *tso;
1880   PEs node_loc, tso_loc;
1881   rtsTime bq_processing_time = 0;
1882   nat len = 0, len_local = 0;
1883
1884   IF_GRAN_DEBUG(bq,
1885                 belch("## AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
1886                       node, CurrentProc, CurrentTime[CurrentProc],
1887                       CurrentTSO->id, CurrentTSO));
1888
1889   node_loc = where_is(node);
1890
1891   ASSERT(get_itbl(q)->type == TSO ||   // q is either a TSO or an RBHSave
1892          get_itbl(q)->type == CONSTR); // closure (type constructor)
1893   ASSERT(is_unique(node));
1894
1895   /* FAKE FETCH: magically copy the node to the tso's proc;
1896      no Fetch necessary because in reality the node should not have been
1897      moved to the other PE in the first place
1898   */
1899   if (CurrentProc!=node_loc) {
1900     IF_GRAN_DEBUG(bq,
1901                   belch("## node %p is on PE %d but CurrentProc is %d (TSO %d); assuming fake fetch and adjusting bitmask (old: %#x)",
1902                         node, node_loc, CurrentProc, CurrentTSO->id,
1903                         // CurrentTSO, where_is(CurrentTSO),
1904                         node->header.gran.procs));
1905     node->header.gran.procs = (node->header.gran.procs) | PE_NUMBER(CurrentProc);
1906     IF_GRAN_DEBUG(bq,
1907                   belch("## new bitmask of node %p is %#x",
1908                         node, node->header.gran.procs));
1909     if (RtsFlags.GranFlags.GranSimStats.Global) {
1910       globalGranStats.tot_fake_fetches++;
1911     }
1912   }
1913
1914   bqe = q;
1915   // ToDo: check: ASSERT(CurrentProc==node_loc);
1916   while (get_itbl(bqe)->type==TSO) { // q != END_TSO_QUEUE) {
1917     //next = bqe->link;
1918     /*
1919        bqe points to the current element in the queue
1920        next points to the next element in the queue
1921     */
1922     //tso = (StgTSO *)bqe;  // wastes an assignment to get the type right
1923     //tso_loc = where_is(tso);
1924     bqe = unblockOneLocked(bqe, node);
1925   }
1926
1927   /* statistics gathering */
1928   /* ToDo: fix counters
1929   if (RtsFlags.GranFlags.GranSimStats.Global) {
1930     globalGranStats.tot_bq_processing_time += bq_processing_time;
1931     globalGranStats.tot_bq_len += len;      // total length of all bqs awakened
1932     globalGranStats.tot_bq_len_local += len_local;  // same for local TSOs only
1933     globalGranStats.tot_awbq++;             // total no. of bqs awakened
1934   }
1935   IF_GRAN_DEBUG(bq,
1936                 fprintf(stderr,"## BQ Stats of %p: [%d entries, %d local] %s\n",
1937                         node, len, len_local, (next!=END_TSO_QUEUE) ? "RBH" : ""));
1938   */
1939 }
1940 #elif defined(PAR)
1941 void
1942 awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
1943 {
1944   StgBlockingQueueElement *bqe, *next;
1945
1946   ACQUIRE_LOCK(&sched_mutex);
1947
1948   IF_PAR_DEBUG(verbose,
1949                belch("## AwBQ for node %p on [%x]: ",
1950                      node, mytid));
1951
1952   ASSERT(get_itbl(q)->type == TSO ||
1953          get_itbl(q)->type == BLOCKED_FETCH ||
1954          get_itbl(q)->type == CONSTR);
1955
1956   bqe = q;
1957   while (get_itbl(bqe)->type==TSO ||
1958          get_itbl(bqe)->type==BLOCKED_FETCH) {
1959     bqe = unblockOneLocked(bqe, node);
1960   }
1961   RELEASE_LOCK(&sched_mutex);
1962 }
1963
1964 #else   /* !GRAN && !PAR */
1965 void
1966 awakenBlockedQueue(StgTSO *tso)
1967 {
1968   ACQUIRE_LOCK(&sched_mutex);
1969   while (tso != END_TSO_QUEUE) {
1970     tso = unblockOneLocked(tso);
1971   }
1972   RELEASE_LOCK(&sched_mutex);
1973 }
1974 #endif
1975
1976 //@node Exception Handling Routines, Debugging Routines, Blocking Queue Routines, Main scheduling code
1977 //@subsection Exception Handling Routines
1978
1979 /* ---------------------------------------------------------------------------
1980    Interrupt execution
1981    - usually called inside a signal handler so it mustn't do anything fancy.
1982    ------------------------------------------------------------------------ */
1983
1984 void
1985 interruptStgRts(void)
1986 {
1987     interrupted    = 1;
1988     context_switch = 1;
1989 }
1990
1991 /* -----------------------------------------------------------------------------
1992    Unblock a thread
1993
1994    This is for use when we raise an exception in another thread, which
1995    may be blocked.
1996    This has nothing to do with the UnblockThread event in GranSim. -- HWL
1997    -------------------------------------------------------------------------- */
1998
1999 static void
2000 unblockThread(StgTSO *tso)
2001 {
2002   StgTSO *t, **last;
2003
2004   ACQUIRE_LOCK(&sched_mutex);
2005   switch (tso->why_blocked) {
2006
2007   case NotBlocked:
2008     return;  /* not blocked */
2009
2010   case BlockedOnMVar:
2011     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
2012     {
2013       StgTSO *last_tso = END_TSO_QUEUE;
2014       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
2015
2016       last = &mvar->head;
2017       for (t = mvar->head; t != END_TSO_QUEUE;
2018            last = &t->link, last_tso = t, t = t->link) {
2019         if (t == tso) {
2020           *last = tso->link;
2021           if (mvar->tail == tso) {
2022             mvar->tail = last_tso;
2023           }
2024           goto done;
2025         }
2026       }
2027       barf("unblockThread (MVAR): TSO not found");
2028     }
2029
2030   case BlockedOnBlackHole:
2031     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
2032     {
2033       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
2034
2035       last = &bq->blocking_queue;
2036       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
2037            last = &t->link, t = t->link) {
2038         if (t == tso) {
2039           *last = tso->link;
2040           goto done;
2041         }
2042       }
2043       barf("unblockThread (BLACKHOLE): TSO not found");
2044     }
2045
2046   case BlockedOnException:
2047     {
2048       StgTSO *target  = tso->block_info.tso;
2049
2050       ASSERT(get_itbl(target)->type == TSO);
2051       ASSERT(target->blocked_exceptions != NULL);
2052
2053       last = &target->blocked_exceptions;
2054       for (t = target->blocked_exceptions; t != END_TSO_QUEUE;
2055            last = &t->link, t = t->link) {
2056         ASSERT(get_itbl(t)->type == TSO);
2057         if (t == tso) {
2058           *last = tso->link;
2059           goto done;
2060         }
2061       }
2062       barf("unblockThread (Exception): TSO not found");
2063     }
2064
2065   case BlockedOnDelay:
2066   case BlockedOnRead:
2067   case BlockedOnWrite:
2068     {
2069       StgTSO *prev = NULL;
2070       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
2071            prev = t, t = t->link) {
2072         if (t == tso) {
2073           if (prev == NULL) {
2074             blocked_queue_hd = t->link;
2075             if (blocked_queue_tl == t) {
2076               blocked_queue_tl = END_TSO_QUEUE;
2077             }
2078           } else {
2079             prev->link = t->link;
2080             if (blocked_queue_tl == t) {
2081               blocked_queue_tl = prev;
2082             }
2083           }
2084           goto done;
2085         }
2086       }
2087       barf("unblockThread (I/O): TSO not found");
2088     }
2089
2090   default:
2091     barf("unblockThread");
2092   }
2093
2094  done:
2095   tso->link = END_TSO_QUEUE;
2096   tso->why_blocked = NotBlocked;
2097   tso->block_info.closure = NULL;
2098   PUSH_ON_RUN_QUEUE(tso);
2099   RELEASE_LOCK(&sched_mutex);
2100 }
2101
2102 /* -----------------------------------------------------------------------------
2103  * raiseAsync()
2104  *
2105  * The following function implements the magic for raising an
2106  * asynchronous exception in an existing thread.
2107  *
2108  * We first remove the thread from any queue on which it might be
2109  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
2110  *
2111  * We strip the stack down to the innermost CATCH_FRAME, building
2112  * thunks in the heap for all the active computations, so they can
2113  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
2114  * an application of the handler to the exception, and push it on
2115  * the top of the stack.
2116  *
2117  * How exactly do we save all the active computations?  We create an
2118  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
2119  * AP_UPDs pushes everything from the corresponding update frame
2120  * upwards onto the stack.  (Actually, it pushes everything up to the
2121  * next update frame plus a pointer to the next AP_UPD object.
2122  * Entering the next AP_UPD object pushes more onto the stack until we
2123  * reach the last AP_UPD object - at which point the stack should look
2124  * exactly as it did when we killed the TSO and we can continue
2125  * execution by entering the closure on top of the stack.
2126  *
2127  * We can also kill a thread entirely - this happens if either (a) the
2128  * exception passed to raiseAsync is NULL, or (b) there's no
2129  * CATCH_FRAME on the stack.  In either case, we strip the entire
2130  * stack and replace the thread with a zombie.
2131  *
2132  * -------------------------------------------------------------------------- */
2133
2134 void
2135 deleteThread(StgTSO *tso)
2136 {
2137   raiseAsync(tso,NULL);
2138 }
2139
2140 void
2141 raiseAsync(StgTSO *tso, StgClosure *exception)
2142 {
2143   StgUpdateFrame* su = tso->su;
2144   StgPtr          sp = tso->sp;
2145
2146   /* Thread already dead? */
2147   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
2148     return;
2149   }
2150
2151   IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
2152
2153   /* Remove it from any blocking queues */
2154   unblockThread(tso);
2155
2156   /* The stack freezing code assumes there's a closure pointer on
2157    * the top of the stack.  This isn't always the case with compiled
2158    * code, so we have to push a dummy closure on the top which just
2159    * returns to the next return address on the stack.
2160    */
2161   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
2162     *(--sp) = (W_)&dummy_ret_closure;
2163   }
2164
2165   while (1) {
2166     int words = ((P_)su - (P_)sp) - 1;
2167     nat i;
2168     StgAP_UPD * ap;
2169
2170     /* If we find a CATCH_FRAME, and we've got an exception to raise,
2171      * then build PAP(handler,exception,realworld#), and leave it on
2172      * top of the stack ready to enter.
2173      */
2174     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
2175       StgCatchFrame *cf = (StgCatchFrame *)su;
2176       /* we've got an exception to raise, so let's pass it to the
2177        * handler in this frame.
2178        */
2179       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 2);
2180       TICK_ALLOC_UPD_PAP(3,0);
2181       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
2182
2183       ap->n_args = 2;
2184       ap->fun = cf->handler;    /* :: Exception -> IO a */
2185       ap->payload[0] = (P_)exception;
2186       ap->payload[1] = ARG_TAG(0); /* realworld token */
2187
2188       /* throw away the stack from Sp up to and including the
2189        * CATCH_FRAME.
2190        */
2191       sp = (P_)su + sizeofW(StgCatchFrame) - 1;
2192       tso->su = cf->link;
2193
2194       /* Restore the blocked/unblocked state for asynchronous exceptions
2195        * at the CATCH_FRAME.
2196        *
2197        * If exceptions were unblocked at the catch, arrange that they
2198        * are unblocked again after executing the handler by pushing an
2199        * unblockAsyncExceptions_ret stack frame.
2200        */
2201       if (!cf->exceptions_blocked) {
2202         *(sp--) = (W_)&unblockAsyncExceptionszh_ret_info;
2203       }
2204
2205       /* Ensure that async exceptions are blocked when running the handler.
2206        */
2207       if (tso->blocked_exceptions == NULL) {
2208         tso->blocked_exceptions = END_TSO_QUEUE;
2209       }
2210
2211       /* Put the newly-built PAP on top of the stack, ready to execute
2212        * when the thread restarts.
2213        */
2214       sp[0] = (W_)ap;
2215       tso->sp = sp;
2216       tso->whatNext = ThreadEnterGHC;
2217       return;
2218     }
2219
2220     /* First build an AP_UPD consisting of the stack chunk above the
2221      * current update frame, with the top word on the stack as the
2222      * fun field.
2223      */
2224     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
2225
2226     ASSERT(words >= 0);
2227
2228     ap->n_args = words;
2229     ap->fun    = (StgClosure *)sp[0];
2230     sp++;
2231     for(i=0; i < (nat)words; ++i) {
2232       ap->payload[i] = (P_)*sp++;
2233     }
2234
2235     switch (get_itbl(su)->type) {
2236
2237     case UPDATE_FRAME:
2238       {
2239         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
2240         TICK_ALLOC_UP_THK(words+1,0);
2241
2242         IF_DEBUG(scheduler,
2243                  fprintf(stderr,  "scheduler: Updating ");
2244                  printPtr((P_)su->updatee);
2245                  fprintf(stderr,  " with ");
2246                  printObj((StgClosure *)ap);
2247                  );
2248
2249         /* Replace the updatee with an indirection - happily
2250          * this will also wake up any threads currently
2251          * waiting on the result.
2252          */
2253         UPD_IND_NOLOCK(su->updatee,ap);  /* revert the black hole */
2254         su = su->link;
2255         sp += sizeofW(StgUpdateFrame) -1;
2256         sp[0] = (W_)ap; /* push onto stack */
2257         break;
2258       }
2259
2260     case CATCH_FRAME:
2261       {
2262         StgCatchFrame *cf = (StgCatchFrame *)su;
2263         StgClosure* o;
2264
2265         /* We want a PAP, not an AP_UPD.  Fortunately, the
2266          * layout's the same.
2267          */
2268         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
2269         TICK_ALLOC_UPD_PAP(words+1,0);
2270
2271         /* now build o = FUN(catch,ap,handler) */
2272         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
2273         TICK_ALLOC_FUN(2,0);
2274         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
2275         o->payload[0] = (StgClosure *)ap;
2276         o->payload[1] = cf->handler;
2277
2278         IF_DEBUG(scheduler,
2279                  fprintf(stderr,  "scheduler: Built ");
2280                  printObj((StgClosure *)o);
2281                  );
2282
2283         /* pop the old handler and put o on the stack */
2284         su = cf->link;
2285         sp += sizeofW(StgCatchFrame) - 1;
2286         sp[0] = (W_)o;
2287         break;
2288       }
2289
2290     case SEQ_FRAME:
2291       {
2292         StgSeqFrame *sf = (StgSeqFrame *)su;
2293         StgClosure* o;
2294
2295         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
2296         TICK_ALLOC_UPD_PAP(words+1,0);
2297
2298         /* now build o = FUN(seq,ap) */
2299         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
2300         TICK_ALLOC_SE_THK(1,0);
2301         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
2302         payloadCPtr(o,0) = (StgClosure *)ap;
2303
2304         IF_DEBUG(scheduler,
2305                  fprintf(stderr,  "scheduler: Built ");
2306                  printObj((StgClosure *)o);
2307                  );
2308
2309         /* pop the old handler and put o on the stack */
2310         su = sf->link;
2311         sp += sizeofW(StgSeqFrame) - 1;
2312         sp[0] = (W_)o;
2313         break;
2314       }
2315
2316     case STOP_FRAME:
2317       /* We've stripped the entire stack, the thread is now dead. */
2318       sp += sizeofW(StgStopFrame) - 1;
2319       sp[0] = (W_)exception;    /* save the exception */
2320       tso->whatNext = ThreadKilled;
2321       tso->su = (StgUpdateFrame *)(sp+1);
2322       tso->sp = sp;
2323       return;
2324
2325     default:
2326       barf("raiseAsync");
2327     }
2328   }
2329   barf("raiseAsync");
2330 }
2331
2332 //@node Debugging Routines, Index, Exception Handling Routines, Main scheduling code
2333 //@subsection Debugging Routines
2334
2335 /* -----------------------------------------------------------------------------
2336    Debugging: why is a thread blocked
2337    -------------------------------------------------------------------------- */
2338
2339 #ifdef DEBUG
2340
2341 void printThreadBlockage(StgTSO *tso)
2342 {
2343   switch (tso->why_blocked) {
2344   case BlockedOnRead:
2345     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
2346     break;
2347   case BlockedOnWrite:
2348     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
2349     break;
2350   case BlockedOnDelay:
2351     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
2352     break;
2353   case BlockedOnMVar:
2354     fprintf(stderr,"blocked on an MVar");
2355     break;
2356   case BlockedOnException:
2357     fprintf(stderr,"blocked on delivering an exception to thread %d",
2358             tso->block_info.tso->id);
2359     break;
2360   case BlockedOnBlackHole:
2361     fprintf(stderr,"blocked on a black hole");
2362     break;
2363   case NotBlocked:
2364     fprintf(stderr,"not blocked");
2365     break;
2366 #if defined(PAR)
2367   case BlockedOnGA:
2368     fprintf(stderr,"blocked on global address");
2369     break;
2370 #endif
2371   }
2372 }
2373
2374 /*
2375    Print a whole blocking queue attached to node (debugging only).
2376 */
2377 //@cindex print_bq
2378 # if defined(PAR)
2379 void
2380 print_bq (StgClosure *node)
2381 {
2382   StgBlockingQueueElement *bqe;
2383   StgTSO *tso;
2384   rtsBool end;
2385
2386   fprintf(stderr,"## BQ of closure %p (%s): ",
2387           node, info_type(node));
2388
2389   /* should cover all closures that may have a blocking queue */
2390   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
2391          get_itbl(node)->type == FETCH_ME_BQ ||
2392          get_itbl(node)->type == RBH);
2393
2394   ASSERT(node!=(StgClosure*)NULL);         // sanity check
2395   /*
2396      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
2397   */
2398   for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
2399        !end; // iterate until bqe points to a CONSTR
2400        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
2401     ASSERT(bqe != END_BQ_QUEUE);             // sanity check
2402     ASSERT(bqe != (StgTSO*)NULL);            // sanity check
2403     /* types of closures that may appear in a blocking queue */
2404     ASSERT(get_itbl(bqe)->type == TSO ||
2405            get_itbl(bqe)->type == BLOCKED_FETCH ||
2406            get_itbl(bqe)->type == CONSTR);
2407     /* only BQs of an RBH end with an RBH_Save closure */
2408     ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
2409
2410     switch (get_itbl(bqe)->type) {
2411     case TSO:
2412       fprintf(stderr," TSO %d (%x),",
2413               ((StgTSO *)bqe)->id, ((StgTSO *)bqe));
2414       break;
2415     case BLOCKED_FETCH:
2416       fprintf(stderr," BF (node=%p, ga=((%x, %d, %x)),",
2417               ((StgBlockedFetch *)bqe)->node,
2418               ((StgBlockedFetch *)bqe)->ga.payload.gc.gtid,
2419               ((StgBlockedFetch *)bqe)->ga.payload.gc.slot,
2420               ((StgBlockedFetch *)bqe)->ga.weight);
2421       break;
2422     case CONSTR:
2423       fprintf(stderr," %s (IP %p),",
2424               (get_itbl(bqe) == &RBH_Save_0_info ? "RBH_Save_0" :
2425                get_itbl(bqe) == &RBH_Save_1_info ? "RBH_Save_1" :
2426                get_itbl(bqe) == &RBH_Save_2_info ? "RBH_Save_2" :
2427                "RBH_Save_?"), get_itbl(bqe));
2428       break;
2429     default:
2430       barf("Unexpected closure type %s in blocking queue of %p (%s)",
2431            info_type(bqe), node, info_type(node));
2432       break;
2433     }
2434   } /* for */
2435   fputc('\n', stderr);
2436 }
2437 # elif defined(GRAN)
2438 void
2439 print_bq (StgClosure *node)
2440 {
2441   StgBlockingQueueElement *bqe;
2442   StgTSO *tso;
2443   PEs node_loc, tso_loc;
2444   rtsBool end;
2445
2446   /* should cover all closures that may have a blocking queue */
2447   ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
2448          get_itbl(node)->type == FETCH_ME_BQ ||
2449          get_itbl(node)->type == RBH);
2450
2451   ASSERT(node!=(StgClosure*)NULL);         // sanity check
2452   node_loc = where_is(node);
2453
2454   fprintf(stderr,"## BQ of closure %p (%s) on [PE %d]: ",
2455           node, info_type(node), node_loc);
2456
2457   /*
2458      NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
2459   */
2460   for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
2461        !end; // iterate until bqe points to a CONSTR
2462        end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
2463     ASSERT(bqe != END_BQ_QUEUE);             // sanity check
2464     ASSERT(bqe != (StgTSO*)NULL);            // sanity check
2465     /* types of closures that may appear in a blocking queue */
2466     ASSERT(get_itbl(bqe)->type == TSO ||
2467            get_itbl(bqe)->type == CONSTR);
2468     /* only BQs of an RBH end with an RBH_Save closure */
2469     ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
2470
2471     tso_loc = where_is((StgClosure *)bqe);
2472     switch (get_itbl(bqe)->type) {
2473     case TSO:
2474       fprintf(stderr," TSO %d (%x) on [PE %d],",
2475               ((StgTSO *)bqe)->id, ((StgTSO *)bqe), tso_loc);
2476       break;
2477     case CONSTR:
2478       fprintf(stderr," %s (IP %p),",
2479               (get_itbl(bqe) == &RBH_Save_0_info ? "RBH_Save_0" :
2480                get_itbl(bqe) == &RBH_Save_1_info ? "RBH_Save_1" :
2481                get_itbl(bqe) == &RBH_Save_2_info ? "RBH_Save_2" :
2482                "RBH_Save_?"), get_itbl(bqe));
2483       break;
2484     default:
2485       barf("Unexpected closure type %s in blocking queue of %p (%s)",
2486            info_type(bqe), node, info_type(node));
2487       break;
2488     }
2489   } /* for */
2490   fputc('\n', stderr);
2491 }
2492 #else
2493 /*
2494    Nice and easy: only TSOs on the blocking queue
2495 */
2496 void
2497 print_bq (StgClosure *node)
2498 {
2499   StgTSO *tso;
2500
2501   ASSERT(node!=(StgClosure*)NULL);         // sanity check
2502   for (tso = ((StgBlockingQueue*)node)->blocking_queue;
2503        tso != END_TSO_QUEUE;
2504        tso=tso->link) {
2505     ASSERT(tso!=NULL && tso!=END_TSO_QUEUE);   // sanity check
2506     ASSERT(get_itbl(tso)->type == TSO);  // guess what, sanity check
2507     fprintf(stderr," TSO %d (%p),", tso->id, tso);
2508   }
2509   fputc('\n', stderr);
2510 }
2511 # endif
2512
2513 #if defined(PAR)
2514 static nat
2515 run_queue_len(void)
2516 {
2517   nat i;
2518   StgTSO *tso;
2519
2520   for (i=0, tso=run_queue_hd;
2521        tso != END_TSO_QUEUE;
2522        i++, tso=tso->link)
2523     /* nothing */
2524
2525   return i;
2526 }
2527 #endif
2528
2529 static void
2530 sched_belch(char *s, ...)
2531 {
2532   va_list ap;
2533   va_start(ap,s);
2534 #ifdef SMP
2535   fprintf(stderr, "scheduler (task %ld): ", pthread_self());
2536 #else
2537   fprintf(stderr, "scheduler: ");
2538 #endif
2539   vfprintf(stderr, s, ap);
2540   fprintf(stderr, "\n");
2541 }
2542
2543 #endif /* DEBUG */
2544
2545 //@node Index,  , Debugging Routines, Main scheduling code
2546 //@subsection Index
2547
2548 //@index
2549 //* MainRegTable::  @cindex\s-+MainRegTable
2550 //* StgMainThread::  @cindex\s-+StgMainThread
2551 //* awaken_blocked_queue::  @cindex\s-+awaken_blocked_queue
2552 //* blocked_queue_hd::  @cindex\s-+blocked_queue_hd
2553 //* blocked_queue_tl::  @cindex\s-+blocked_queue_tl
2554 //* context_switch::  @cindex\s-+context_switch
2555 //* createThread::  @cindex\s-+createThread
2556 //* free_capabilities::  @cindex\s-+free_capabilities
2557 //* gc_pending_cond::  @cindex\s-+gc_pending_cond
2558 //* initScheduler::  @cindex\s-+initScheduler
2559 //* interrupted::  @cindex\s-+interrupted
2560 //* n_free_capabilities::  @cindex\s-+n_free_capabilities
2561 //* next_thread_id::  @cindex\s-+next_thread_id
2562 //* print_bq::  @cindex\s-+print_bq
2563 //* run_queue_hd::  @cindex\s-+run_queue_hd
2564 //* run_queue_tl::  @cindex\s-+run_queue_tl
2565 //* sched_mutex::  @cindex\s-+sched_mutex
2566 //* schedule::  @cindex\s-+schedule
2567 //* take_off_run_queue::  @cindex\s-+take_off_run_queue
2568 //* task_ids::  @cindex\s-+task_ids
2569 //* term_mutex::  @cindex\s-+term_mutex
2570 //* thread_ready_cond::  @cindex\s-+thread_ready_cond
2571 //@end index