rts/Schedule.c

   1 /* ---------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2006
   4  *
   5  * The scheduler and thread-related functionality
   6  *
   7  * --------------------------------------------------------------------------*/
   8
   9 #include "PosixSource.h"
  10 #define KEEP_LOCKCLOSURE
  11 #include "Rts.h"
  12 #include "SchedAPI.h"
  13 #include "RtsUtils.h"
  14 #include "RtsFlags.h"
  15 #include "OSThreads.h"
  16 #include "Storage.h"
  17 #include "StgRun.h"
  18 #include "Hooks.h"
  19 #include "Schedule.h"
  20 #include "StgMiscClosures.h"
  21 #include "Interpreter.h"
  22 #include "Printer.h"
  23 #include "RtsSignals.h"
  24 #include "Sanity.h"
  25 #include "Stats.h"
  26 #include "STM.h"
  27 #include "Timer.h"
  28 #include "Prelude.h"
  29 #include "ThreadLabels.h"
  30 #include "LdvProfile.h"
  31 #include "Updates.h"
  32 #include "Proftimer.h"
  33 #include "ProfHeap.h"
  34 #include "GC.h"
  35
  36 /* PARALLEL_HASKELL includes go here */
  37
  38 #include "Sparks.h"
  39 #include "Capability.h"
  40 #include "Task.h"
  41 #include "AwaitEvent.h"
  42 #if defined(mingw32_HOST_OS)
  43 #include "win32/IOManager.h"
  44 #endif
  45 #include "Trace.h"
  46 #include "RaiseAsync.h"
  47 #include "Threads.h"
  48 #include "ThrIOManager.h"
  49
  50 #ifdef HAVE_SYS_TYPES_H
  51 #include <sys/types.h>
  52 #endif
  53 #ifdef HAVE_UNISTD_H
  54 #include <unistd.h>
  55 #endif
  56
  57 #include <string.h>
  58 #include <stdlib.h>
  59 #include <stdarg.h>
  60
  61 #ifdef HAVE_ERRNO_H
  62 #include <errno.h>
  63 #endif
  64
  65 // Turn off inlining when debugging - it obfuscates things
  66 #ifdef DEBUG
  67 # undef  STATIC_INLINE
  68 # define STATIC_INLINE static
  69 #endif
  70
  71 /* -----------------------------------------------------------------------------
  72  * Global variables
  73  * -------------------------------------------------------------------------- */
  74
  75 #if !defined(THREADED_RTS)
  76 // Blocked/sleeping thrads
  77 StgTSO *blocked_queue_hd = NULL;
  78 StgTSO *blocked_queue_tl = NULL;
  79 StgTSO *sleeping_queue = NULL;    // perhaps replace with a hash table?
  80 #endif
  81
  82 /* Threads blocked on blackholes.
  83  * LOCK: sched_mutex+capability, or all capabilities
  84  */
  85 StgTSO *blackhole_queue = NULL;
  86
  87 /* The blackhole_queue should be checked for threads to wake up.  See
  88  * Schedule.h for more thorough comment.
  89  * LOCK: none (doesn't matter if we miss an update)
  90  */
  91 rtsBool blackholes_need_checking = rtsFalse;
  92
  93 /* flag that tracks whether we have done any execution in this time slice.
  94  * LOCK: currently none, perhaps we should lock (but needs to be
  95  * updated in the fast path of the scheduler).
  96  *
  97  * NB. must be StgWord, we do xchg() on it.
  98  */
  99 volatile StgWord recent_activity = ACTIVITY_YES;
 100
 101 /* if this flag is set as well, give up execution
 102  * LOCK: none (changes monotonically)
 103  */
 104 volatile StgWord sched_state = SCHED_RUNNING;
 105
 106 /*  This is used in `TSO.h' and gcc 2.96 insists that this variable actually
 107  *  exists - earlier gccs apparently didn't.
 108  *  -= chak
 109  */
 110 StgTSO dummy_tso;
 111
 112 /*
 113  * Set to TRUE when entering a shutdown state (via shutdownHaskellAndExit()) --
 114  * in an MT setting, needed to signal that a worker thread shouldn't hang around
 115  * in the scheduler when it is out of work.
 116  */
 117 rtsBool shutting_down_scheduler = rtsFalse;
 118
 119 /*
 120  * This mutex protects most of the global scheduler data in
 121  * the THREADED_RTS runtime.
 122  */
 123 #if defined(THREADED_RTS)
 124 Mutex sched_mutex;
 125 #endif
 126
 127 #if !defined(mingw32_HOST_OS)
 128 #define FORKPROCESS_PRIMOP_SUPPORTED
 129 #endif
 130
 131 /* -----------------------------------------------------------------------------
 132  * static function prototypes
 133  * -------------------------------------------------------------------------- */
 134
 135 static Capability *schedule (Capability *initialCapability, Task *task);
 136
 137 //
 138 // These function all encapsulate parts of the scheduler loop, and are
 139 // abstracted only to make the structure and control flow of the
 140 // scheduler clearer.
 141 //
 142 static void schedulePreLoop (void);
 143 static void scheduleFindWork (Capability *cap);
 144 #if defined(THREADED_RTS)
 145 static void scheduleYield (Capability **pcap, Task *task);
 146 #endif
 147 static void scheduleStartSignalHandlers (Capability *cap);
 148 static void scheduleCheckBlockedThreads (Capability *cap);
 149 static void scheduleCheckWakeupThreads(Capability *cap USED_IF_NOT_THREADS);
 150 static void scheduleCheckBlackHoles (Capability *cap);
 151 static void scheduleDetectDeadlock (Capability *cap, Task *task);
 152 static void schedulePushWork(Capability *cap, Task *task);
 153 #if defined(PARALLEL_HASKELL)
 154 static rtsBool scheduleGetRemoteWork(Capability *cap);
 155 static void scheduleSendPendingMessages(void);
 156 #endif
 157 #if defined(PARALLEL_HASKELL) || defined(THREADED_RTS)
 158 static void scheduleActivateSpark(Capability *cap);
 159 #endif
 160 static void schedulePostRunThread(Capability *cap, StgTSO *t);
 161 static rtsBool scheduleHandleHeapOverflow( Capability *cap, StgTSO *t );
 162 static void scheduleHandleStackOverflow( Capability *cap, Task *task,
 163                                          StgTSO *t);
 164 static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t,
 165                                     nat prev_what_next );
 166 static void scheduleHandleThreadBlocked( StgTSO *t );
 167 static rtsBool scheduleHandleThreadFinished( Capability *cap, Task *task,
 168                                              StgTSO *t );
 169 static rtsBool scheduleNeedHeapProfile(rtsBool ready_to_gc);
 170 static Capability *scheduleDoGC(Capability *cap, Task *task,
 171                                 rtsBool force_major);
 172
 173 static rtsBool checkBlackHoles(Capability *cap);
 174
 175 static StgTSO *threadStackOverflow(Capability *cap, StgTSO *tso);
 176 static StgTSO *threadStackUnderflow(Task *task, StgTSO *tso);
 177
 178 static void deleteThread (Capability *cap, StgTSO *tso);
 179 static void deleteAllThreads (Capability *cap);
 180
 181 #ifdef FORKPROCESS_PRIMOP_SUPPORTED
 182 static void deleteThread_(Capability *cap, StgTSO *tso);
 183 #endif
 184
 185 #ifdef DEBUG
 186 static char *whatNext_strs[] = {
 187   "(unknown)",
 188   "ThreadRunGHC",
 189   "ThreadInterpret",
 190   "ThreadKilled",
 191   "ThreadRelocated",
 192   "ThreadComplete"
 193 };
 194 #endif
 195
 196 /* -----------------------------------------------------------------------------
 197  * Putting a thread on the run queue: different scheduling policies
 198  * -------------------------------------------------------------------------- */
 199
 200 STATIC_INLINE void
 201 addToRunQueue( Capability *cap, StgTSO *t )
 202 {
 203 #if defined(PARALLEL_HASKELL)
 204     if (RtsFlags.ParFlags.doFairScheduling) {
 205         // this does round-robin scheduling; good for concurrency
 206         appendToRunQueue(cap,t);
 207     } else {
 208         // this does unfair scheduling; good for parallelism
 209         pushOnRunQueue(cap,t);
 210     }
 211 #else
 212     // this does round-robin scheduling; good for concurrency
 213     appendToRunQueue(cap,t);
 214 #endif
 215 }
 216
 217 /* ---------------------------------------------------------------------------
 218    Main scheduling loop.
 219
 220    We use round-robin scheduling, each thread returning to the
 221    scheduler loop when one of these conditions is detected:
 222
 223       * out of heap space
 224       * timer expires (thread yields)
 225       * thread blocks
 226       * thread ends
 227       * stack overflow
 228
 229    GRAN version:
 230      In a GranSim setup this loop iterates over the global event queue.
 231      This revolves around the global event queue, which determines what
 232      to do next. Therefore, it's more complicated than either the
 233      concurrent or the parallel (GUM) setup.
 234   This version has been entirely removed (JB 2008/08).
 235
 236    GUM version:
 237      GUM iterates over incoming messages.
 238      It starts with nothing to do (thus CurrentTSO == END_TSO_QUEUE),
 239      and sends out a fish whenever it has nothing to do; in-between
 240      doing the actual reductions (shared code below) it processes the
 241      incoming messages and deals with delayed operations
 242      (see PendingFetches).
 243      This is not the ugliest code you could imagine, but it's bloody close.
 244
 245   (JB 2008/08) This version was formerly indicated by a PP-Flag PAR,
 246   now by PP-flag PARALLEL_HASKELL. The Eden RTS (in GHC-6.x) uses it,
 247   as well as future GUM versions. This file has been refurbished to
 248   only contain valid code, which is however incomplete, refers to
 249   invalid includes etc.
 250
 251    ------------------------------------------------------------------------ */
 252
 253 static Capability *
 254 schedule (Capability *initialCapability, Task *task)
 255 {
 256   StgTSO *t;
 257   Capability *cap;
 258   StgThreadReturnCode ret;
 259 #if defined(PARALLEL_HASKELL)
 260   rtsBool receivedFinish = rtsFalse;
 261 #endif
 262   nat prev_what_next;
 263   rtsBool ready_to_gc;
 264 #if defined(THREADED_RTS)
 265   rtsBool first = rtsTrue;
 266 #endif
 267
 268   cap = initialCapability;
 269
 270   // Pre-condition: this task owns initialCapability.
 271   // The sched_mutex is *NOT* held
 272   // NB. on return, we still hold a capability.
 273
 274   debugTrace (DEBUG_sched,
 275               "### NEW SCHEDULER LOOP (task: %p, cap: %p)",
 276               task, initialCapability);
 277
 278   schedulePreLoop();
 279
 280   // -----------------------------------------------------------
 281   // Scheduler loop starts here:
 282
 283 #if defined(PARALLEL_HASKELL)
 284 #define TERMINATION_CONDITION        (!receivedFinish)
 285 #else
 286 #define TERMINATION_CONDITION        rtsTrue
 287 #endif
 288
 289   while (TERMINATION_CONDITION) {
 290
 291     // Check whether we have re-entered the RTS from Haskell without
 292     // going via suspendThread()/resumeThread (i.e. a 'safe' foreign
 293     // call).
 294     if (cap->in_haskell) {
 295           errorBelch("schedule: re-entered unsafely.\n"
 296                      "   Perhaps a 'foreign import unsafe' should be 'safe'?");
 297           stg_exit(EXIT_FAILURE);
 298     }
 299
 300     // The interruption / shutdown sequence.
 301     //
 302     // In order to cleanly shut down the runtime, we want to:
 303     //   * make sure that all main threads return to their callers
 304     //     with the state 'Interrupted'.
 305     //   * clean up all OS threads assocated with the runtime
 306     //   * free all memory etc.
 307     //
 308     // So the sequence for ^C goes like this:
 309     //
 310     //   * ^C handler sets sched_state := SCHED_INTERRUPTING and
 311     //     arranges for some Capability to wake up
 312     //
 313     //   * all threads in the system are halted, and the zombies are
 314     //     placed on the run queue for cleaning up.  We acquire all
 315     //     the capabilities in order to delete the threads, this is
 316     //     done by scheduleDoGC() for convenience (because GC already
 317     //     needs to acquire all the capabilities).  We can't kill
 318     //     threads involved in foreign calls.
 319     //
 320     //   * somebody calls shutdownHaskell(), which calls exitScheduler()
 321     //
 322     //   * sched_state := SCHED_SHUTTING_DOWN
 323     //
 324     //   * all workers exit when the run queue on their capability
 325     //     drains.  All main threads will also exit when their TSO
 326     //     reaches the head of the run queue and they can return.
 327     //
 328     //   * eventually all Capabilities will shut down, and the RTS can
 329     //     exit.
 330     //
 331     //   * We might be left with threads blocked in foreign calls,
 332     //     we should really attempt to kill these somehow (TODO);
 333
 334     switch (sched_state) {
 335     case SCHED_RUNNING:
 336         break;
 337     case SCHED_INTERRUPTING:
 338         debugTrace(DEBUG_sched, "SCHED_INTERRUPTING");
 339 #if defined(THREADED_RTS)
 340         discardSparksCap(cap);
 341 #endif
 342         /* scheduleDoGC() deletes all the threads */
 343         cap = scheduleDoGC(cap,task,rtsFalse);
 344
 345         // after scheduleDoGC(), we must be shutting down.  Either some
 346         // other Capability did the final GC, or we did it above,
 347         // either way we can fall through to the SCHED_SHUTTING_DOWN
 348         // case now.
 349         ASSERT(sched_state == SCHED_SHUTTING_DOWN);
 350         // fall through
 351
 352     case SCHED_SHUTTING_DOWN:
 353         debugTrace(DEBUG_sched, "SCHED_SHUTTING_DOWN");
 354         // If we are a worker, just exit.  If we're a bound thread
 355         // then we will exit below when we've removed our TSO from
 356         // the run queue.
 357         if (task->tso == NULL && emptyRunQueue(cap)) {
 358             return cap;
 359         }
 360         break;
 361     default:
 362         barf("sched_state: %d", sched_state);
 363     }
 364
 365     scheduleFindWork(cap);
 366
 367     /* work pushing, currently relevant only for THREADED_RTS:
 368        (pushes threads, wakes up idle capabilities for stealing) */
 369     schedulePushWork(cap,task);
 370
 371 #if defined(PARALLEL_HASKELL)
 372     /* since we perform a blocking receive and continue otherwise,
 373        either we never reach here or we definitely have work! */
 374     // from here: non-empty run queue
 375     ASSERT(!emptyRunQueue(cap));
 376
 377     if (PacketsWaiting()) {  /* now process incoming messages, if any
 378                                 pending...
 379
 380                                 CAUTION: scheduleGetRemoteWork called
 381                                 above, waits for messages as well! */
 382       processMessages(cap, &receivedFinish);
 383     }
 384 #endif // PARALLEL_HASKELL: non-empty run queue!
 385
 386     scheduleDetectDeadlock(cap,task);
 387
 388 #if defined(THREADED_RTS)
 389     cap = task->cap;    // reload cap, it might have changed
 390 #endif
 391
 392     // Normally, the only way we can get here with no threads to
 393     // run is if a keyboard interrupt received during
 394     // scheduleCheckBlockedThreads() or scheduleDetectDeadlock().
 395     // Additionally, it is not fatal for the
 396     // threaded RTS to reach here with no threads to run.
 397     //
 398     // win32: might be here due to awaitEvent() being abandoned
 399     // as a result of a console event having been delivered.
 400
 401 #if defined(THREADED_RTS)
 402     if (first)
 403     {
 404     // XXX: ToDo
 405     //     // don't yield the first time, we want a chance to run this
 406     //     // thread for a bit, even if there are others banging at the
 407     //     // door.
 408     //     first = rtsFalse;
 409     //     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 410     }
 411
 412   yield:
 413     scheduleYield(&cap,task);
 414     if (emptyRunQueue(cap)) continue; // look for work again
 415 #endif
 416
 417 #if !defined(THREADED_RTS) && !defined(mingw32_HOST_OS)
 418     if ( emptyRunQueue(cap) ) {
 419         ASSERT(sched_state >= SCHED_INTERRUPTING);
 420     }
 421 #endif
 422
 423     //
 424     // Get a thread to run
 425     //
 426     t = popRunQueue(cap);
 427
 428     // Sanity check the thread we're about to run.  This can be
 429     // expensive if there is lots of thread switching going on...
 430     IF_DEBUG(sanity,checkTSO(t));
 431
 432 #if defined(THREADED_RTS)
 433     // Check whether we can run this thread in the current task.
 434     // If not, we have to pass our capability to the right task.
 435     {
 436         Task *bound = t->bound;
 437
 438         if (bound) {
 439             if (bound == task) {
 440                 debugTrace(DEBUG_sched,
 441                            "### Running thread %lu in bound thread", (unsigned long)t->id);
 442                 // yes, the Haskell thread is bound to the current native thread
 443             } else {
 444                 debugTrace(DEBUG_sched,
 445                            "### thread %lu bound to another OS thread", (unsigned long)t->id);
 446                 // no, bound to a different Haskell thread: pass to that thread
 447                 pushOnRunQueue(cap,t);
 448                 continue;
 449             }
 450         } else {
 451             // The thread we want to run is unbound.
 452             if (task->tso) {
 453                 debugTrace(DEBUG_sched,
 454                            "### this OS thread cannot run thread %lu", (unsigned long)t->id);
 455                 // no, the current native thread is bound to a different
 456                 // Haskell thread, so pass it to any worker thread
 457                 pushOnRunQueue(cap,t);
 458                 continue;
 459             }
 460         }
 461     }
 462 #endif
 463
 464     // If we're shutting down, and this thread has not yet been
 465     // killed, kill it now.  This sometimes happens when a finalizer
 466     // thread is created by the final GC, or a thread previously
 467     // in a foreign call returns.
 468     if (sched_state >= SCHED_INTERRUPTING &&
 469         !(t->what_next == ThreadComplete || t->what_next == ThreadKilled)) {
 470         deleteThread(cap,t);
 471     }
 472
 473     /* context switches are initiated by the timer signal, unless
 474      * the user specified "context switch as often as possible", with
 475      * +RTS -C0
 476      */
 477     if (RtsFlags.ConcFlags.ctxtSwitchTicks == 0
 478         && !emptyThreadQueues(cap)) {
 479         cap->context_switch = 1;
 480     }
 481
 482 run_thread:
 483
 484     // CurrentTSO is the thread to run.  t might be different if we
 485     // loop back to run_thread, so make sure to set CurrentTSO after
 486     // that.
 487     cap->r.rCurrentTSO = t;
 488
 489     debugTrace(DEBUG_sched, "-->> running thread %ld %s ...",
 490                               (long)t->id, whatNext_strs[t->what_next]);
 491
 492     startHeapProfTimer();
 493
 494     // Check for exceptions blocked on this thread
 495     maybePerformBlockedException (cap, t);
 496
 497     // ----------------------------------------------------------------------
 498     // Run the current thread
 499
 500     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 501     ASSERT(t->cap == cap);
 502     ASSERT(t->bound ? t->bound->cap == cap : 1);
 503
 504     prev_what_next = t->what_next;
 505
 506     errno = t->saved_errno;
 507 #if mingw32_HOST_OS
 508     SetLastError(t->saved_winerror);
 509 #endif
 510
 511     cap->in_haskell = rtsTrue;
 512
 513     dirty_TSO(cap,t);
 514
 515 #if defined(THREADED_RTS)
 516     if (recent_activity == ACTIVITY_DONE_GC) {
 517         // ACTIVITY_DONE_GC means we turned off the timer signal to
 518         // conserve power (see #1623).  Re-enable it here.
 519         nat prev;
 520         prev = xchg((P_)&recent_activity, ACTIVITY_YES);
 521         if (prev == ACTIVITY_DONE_GC) {
 522             startTimer();
 523         }
 524     } else {
 525         recent_activity = ACTIVITY_YES;
 526     }
 527 #endif
 528
 529     switch (prev_what_next) {
 530
 531     case ThreadKilled:
 532     case ThreadComplete:
 533         /* Thread already finished, return to scheduler. */
 534         ret = ThreadFinished;
 535         break;
 536
 537     case ThreadRunGHC:
 538     {
 539         StgRegTable *r;
 540         r = StgRun((StgFunPtr) stg_returnToStackTop, &cap->r);
 541         cap = regTableToCapability(r);
 542         ret = r->rRet;
 543         break;
 544     }
 545
 546     case ThreadInterpret:
 547         cap = interpretBCO(cap);
 548         ret = cap->r.rRet;
 549         break;
 550
 551     default:
 552         barf("schedule: invalid what_next field");
 553     }
 554
 555     cap->in_haskell = rtsFalse;
 556
 557     // The TSO might have moved, eg. if it re-entered the RTS and a GC
 558     // happened.  So find the new location:
 559     t = cap->r.rCurrentTSO;
 560
 561     // We have run some Haskell code: there might be blackhole-blocked
 562     // threads to wake up now.
 563     // Lock-free test here should be ok, we're just setting a flag.
 564     if ( blackhole_queue != END_TSO_QUEUE ) {
 565         blackholes_need_checking = rtsTrue;
 566     }
 567
 568     // And save the current errno in this thread.
 569     // XXX: possibly bogus for SMP because this thread might already
 570     // be running again, see code below.
 571     t->saved_errno = errno;
 572 #if mingw32_HOST_OS
 573     // Similarly for Windows error code
 574     t->saved_winerror = GetLastError();
 575 #endif
 576
 577 #if defined(THREADED_RTS)
 578     // If ret is ThreadBlocked, and this Task is bound to the TSO that
 579     // blocked, we are in limbo - the TSO is now owned by whatever it
 580     // is blocked on, and may in fact already have been woken up,
 581     // perhaps even on a different Capability.  It may be the case
 582     // that task->cap != cap.  We better yield this Capability
 583     // immediately and return to normaility.
 584     if (ret == ThreadBlocked) {
 585         debugTrace(DEBUG_sched,
 586                    "--<< thread %lu (%s) stopped: blocked",
 587                    (unsigned long)t->id, whatNext_strs[t->what_next]);
 588         goto yield;
 589     }
 590 #endif
 591
 592     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 593     ASSERT(t->cap == cap);
 594
 595     // ----------------------------------------------------------------------
 596
 597     // Costs for the scheduler are assigned to CCS_SYSTEM
 598     stopHeapProfTimer();
 599 #if defined(PROFILING)
 600     CCCS = CCS_SYSTEM;
 601 #endif
 602
 603     schedulePostRunThread(cap,t);
 604
 605     t = threadStackUnderflow(task,t);
 606
 607     ready_to_gc = rtsFalse;
 608
 609     switch (ret) {
 610     case HeapOverflow:
 611         ready_to_gc = scheduleHandleHeapOverflow(cap,t);
 612         break;
 613
 614     case StackOverflow:
 615         scheduleHandleStackOverflow(cap,task,t);
 616         break;
 617
 618     case ThreadYielding:
 619         if (scheduleHandleYield(cap, t, prev_what_next)) {
 620             // shortcut for switching between compiler/interpreter:
 621             goto run_thread;
 622         }
 623         break;
 624
 625     case ThreadBlocked:
 626         scheduleHandleThreadBlocked(t);
 627         break;
 628
 629     case ThreadFinished:
 630         if (scheduleHandleThreadFinished(cap, task, t)) return cap;
 631         ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
 632         break;
 633
 634     default:
 635       barf("schedule: invalid thread return code %d", (int)ret);
 636     }
 637
 638     if (ready_to_gc || scheduleNeedHeapProfile(ready_to_gc)) {
 639       cap = scheduleDoGC(cap,task,rtsFalse);
 640     }
 641   } /* end of while() */
 642 }
 643
 644 /* ----------------------------------------------------------------------------
 645  * Setting up the scheduler loop
 646  * ------------------------------------------------------------------------- */
 647
 648 static void
 649 schedulePreLoop(void)
 650 {
 651   // initialisation for scheduler - what cannot go into initScheduler()
 652 }
 653
 654 /* -----------------------------------------------------------------------------
 655  * scheduleFindWork()
 656  *
 657  * Search for work to do, and handle messages from elsewhere.
 658  * -------------------------------------------------------------------------- */
 659
 660 static void
 661 scheduleFindWork (Capability *cap)
 662 {
 663     scheduleStartSignalHandlers(cap);
 664
 665     // Only check the black holes here if we've nothing else to do.
 666     // During normal execution, the black hole list only gets checked
 667     // at GC time, to avoid repeatedly traversing this possibly long
 668     // list each time around the scheduler.
 669     if (emptyRunQueue(cap)) { scheduleCheckBlackHoles(cap); }
 670
 671     scheduleCheckWakeupThreads(cap);
 672
 673     scheduleCheckBlockedThreads(cap);
 674
 675 #if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
 676     if (emptyRunQueue(cap)) { scheduleActivateSpark(cap); }
 677 #endif
 678
 679 #if defined(PARALLEL_HASKELL)
 680     // if messages have been buffered...
 681     scheduleSendPendingMessages();
 682 #endif
 683
 684 #if defined(PARALLEL_HASKELL)
 685     if (emptyRunQueue(cap)) {
 686         receivedFinish = scheduleGetRemoteWork(cap);
 687         continue; //  a new round, (hopefully) with new work
 688         /*
 689            in GUM, this a) sends out a FISH and returns IF no fish is
 690                            out already
 691                         b) (blocking) awaits and receives messages
 692
 693            in Eden, this is only the blocking receive, as b) in GUM.
 694         */
 695     }
 696 #endif
 697 }
 698
 699 #if defined(THREADED_RTS)
 700 STATIC_INLINE rtsBool
 701 shouldYieldCapability (Capability *cap, Task *task)
 702 {
 703     // we need to yield this capability to someone else if..
 704     //   - another thread is initiating a GC
 705     //   - another Task is returning from a foreign call
 706     //   - the thread at the head of the run queue cannot be run
 707     //     by this Task (it is bound to another Task, or it is unbound
 708     //     and this task it bound).
 709     return (waiting_for_gc ||
 710             cap->returning_tasks_hd != NULL ||
 711             (!emptyRunQueue(cap) && (task->tso == NULL
 712                                      ? cap->run_queue_hd->bound != NULL
 713                                      : cap->run_queue_hd->bound != task)));
 714 }
 715
 716 // This is the single place where a Task goes to sleep.  There are
 717 // two reasons it might need to sleep:
 718 //    - there are no threads to run
 719 //    - we need to yield this Capability to someone else
 720 //      (see shouldYieldCapability())
 721 //
 722 // Careful: the scheduler loop is quite delicate.  Make sure you run
 723 // the tests in testsuite/concurrent (all ways) after modifying this,
 724 // and also check the benchmarks in nofib/parallel for regressions.
 725
 726 static void
 727 scheduleYield (Capability **pcap, Task *task)
 728 {
 729     Capability *cap = *pcap;
 730
 731     // if we have work, and we don't need to give up the Capability, continue.
 732     if (!shouldYieldCapability(cap,task) &&
 733         (!emptyRunQueue(cap) ||
 734          blackholes_need_checking ||
 735          sched_state >= SCHED_INTERRUPTING))
 736         return;
 737
 738     // otherwise yield (sleep), and keep yielding if necessary.
 739     do {
 740         yieldCapability(&cap,task);
 741     }
 742     while (shouldYieldCapability(cap,task));
 743
 744     // note there may still be no threads on the run queue at this
 745     // point, the caller has to check.
 746
 747     *pcap = cap;
 748     return;
 749 }
 750 #endif
 751
 752 /* -----------------------------------------------------------------------------
 753  * schedulePushWork()
 754  *
 755  * Push work to other Capabilities if we have some.
 756  * -------------------------------------------------------------------------- */
 757
 758 static void
 759 schedulePushWork(Capability *cap USED_IF_THREADS,
 760                  Task *task      USED_IF_THREADS)
 761 {
 762   /* following code not for PARALLEL_HASKELL. I kept the call general,
 763      future GUM versions might use pushing in a distributed setup */
 764 #if defined(THREADED_RTS)
 765
 766     Capability *free_caps[n_capabilities], *cap0;
 767     nat i, n_free_caps;
 768
 769     // migration can be turned off with +RTS -qg
 770     if (!RtsFlags.ParFlags.migrate) return;
 771
 772     // Check whether we have more threads on our run queue, or sparks
 773     // in our pool, that we could hand to another Capability.
 774     if ((emptyRunQueue(cap) || cap->run_queue_hd->_link == END_TSO_QUEUE)
 775         && sparkPoolSizeCap(cap) < 2) {
 776         return;
 777     }
 778
 779     // First grab as many free Capabilities as we can.
 780     for (i=0, n_free_caps=0; i < n_capabilities; i++) {
 781         cap0 = &capabilities[i];
 782         if (cap != cap0 && tryGrabCapability(cap0,task)) {
 783             if (!emptyRunQueue(cap0) || cap->returning_tasks_hd != NULL) {
 784                 // it already has some work, we just grabbed it at
 785                 // the wrong moment.  Or maybe it's deadlocked!
 786                 releaseCapability(cap0);
 787             } else {
 788                 free_caps[n_free_caps++] = cap0;
 789             }
 790         }
 791     }
 792
 793     // we now have n_free_caps free capabilities stashed in
 794     // free_caps[].  Share our run queue equally with them.  This is
 795     // probably the simplest thing we could do; improvements we might
 796     // want to do include:
 797     //
 798     //   - giving high priority to moving relatively new threads, on
 799     //     the gournds that they haven't had time to build up a
 800     //     working set in the cache on this CPU/Capability.
 801     //
 802     //   - giving low priority to moving long-lived threads
 803
 804     if (n_free_caps > 0) {
 805         StgTSO *prev, *t, *next;
 806         rtsBool pushed_to_all;
 807
 808         debugTrace(DEBUG_sched,
 809                    "cap %d: %s and %d free capabilities, sharing...",
 810                    cap->no,
 811                    (!emptyRunQueue(cap) && cap->run_queue_hd->_link != END_TSO_QUEUE)?
 812                    "excess threads on run queue":"sparks to share (>=2)",
 813                    n_free_caps);
 814
 815         i = 0;
 816         pushed_to_all = rtsFalse;
 817
 818         if (cap->run_queue_hd != END_TSO_QUEUE) {
 819             prev = cap->run_queue_hd;
 820             t = prev->_link;
 821             prev->_link = END_TSO_QUEUE;
 822             for (; t != END_TSO_QUEUE; t = next) {
 823                 next = t->_link;
 824                 t->_link = END_TSO_QUEUE;
 825                 if (t->what_next == ThreadRelocated
 826                     || t->bound == task // don't move my bound thread
 827                     || tsoLocked(t)) {  // don't move a locked thread
 828                     setTSOLink(cap, prev, t);
 829                     prev = t;
 830                 } else if (i == n_free_caps) {
 831                     pushed_to_all = rtsTrue;
 832                     i = 0;
 833                     // keep one for us
 834                     setTSOLink(cap, prev, t);
 835                     prev = t;
 836                 } else {
 837                     debugTrace(DEBUG_sched, "pushing thread %lu to capability %d", (unsigned long)t->id, free_caps[i]->no);
 838                     appendToRunQueue(free_caps[i],t);
 839                     if (t->bound) { t->bound->cap = free_caps[i]; }
 840                     t->cap = free_caps[i];
 841                     i++;
 842                 }
 843             }
 844             cap->run_queue_tl = prev;
 845         }
 846
 847 #ifdef SPARK_PUSHING
 848         /* JB I left this code in place, it would work but is not necessary */
 849
 850         // If there are some free capabilities that we didn't push any
 851         // threads to, then try to push a spark to each one.
 852         if (!pushed_to_all) {
 853             StgClosure *spark;
 854             // i is the next free capability to push to
 855             for (; i < n_free_caps; i++) {
 856                 if (emptySparkPoolCap(free_caps[i])) {
 857                     spark = tryStealSpark(cap->sparks);
 858                     if (spark != NULL) {
 859                         debugTrace(DEBUG_sched, "pushing spark %p to capability %d", spark, free_caps[i]->no);
 860                         newSpark(&(free_caps[i]->r), spark);
 861                     }
 862                 }
 863             }
 864         }
 865 #endif /* SPARK_PUSHING */
 866
 867         // release the capabilities
 868         for (i = 0; i < n_free_caps; i++) {
 869             task->cap = free_caps[i];
 870             releaseAndWakeupCapability(free_caps[i]);
 871         }
 872     }
 873     task->cap = cap; // reset to point to our Capability.
 874
 875 #endif /* THREADED_RTS */
 876
 877 }
 878
 879 /* ----------------------------------------------------------------------------
 880  * Start any pending signal handlers
 881  * ------------------------------------------------------------------------- */
 882
 883 #if defined(RTS_USER_SIGNALS) && !defined(THREADED_RTS)
 884 static void
 885 scheduleStartSignalHandlers(Capability *cap)
 886 {
 887     if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) {
 888         // safe outside the lock
 889         startSignalHandlers(cap);
 890     }
 891 }
 892 #else
 893 static void
 894 scheduleStartSignalHandlers(Capability *cap STG_UNUSED)
 895 {
 896 }
 897 #endif
 898
 899 /* ----------------------------------------------------------------------------
 900  * Check for blocked threads that can be woken up.
 901  * ------------------------------------------------------------------------- */
 902
 903 static void
 904 scheduleCheckBlockedThreads(Capability *cap USED_IF_NOT_THREADS)
 905 {
 906 #if !defined(THREADED_RTS)
 907     //
 908     // Check whether any waiting threads need to be woken up.  If the
 909     // run queue is empty, and there are no other tasks running, we
 910     // can wait indefinitely for something to happen.
 911     //
 912     if ( !emptyQueue(blocked_queue_hd) || !emptyQueue(sleeping_queue) )
 913     {
 914         awaitEvent( emptyRunQueue(cap) && !blackholes_need_checking );
 915     }
 916 #endif
 917 }
 918
 919
 920 /* ----------------------------------------------------------------------------
 921  * Check for threads woken up by other Capabilities
 922  * ------------------------------------------------------------------------- */
 923
 924 static void
 925 scheduleCheckWakeupThreads(Capability *cap USED_IF_THREADS)
 926 {
 927 #if defined(THREADED_RTS)
 928     // Any threads that were woken up by other Capabilities get
 929     // appended to our run queue.
 930     if (!emptyWakeupQueue(cap)) {
 931         ACQUIRE_LOCK(&cap->lock);
 932         if (emptyRunQueue(cap)) {
 933             cap->run_queue_hd = cap->wakeup_queue_hd;
 934             cap->run_queue_tl = cap->wakeup_queue_tl;
 935         } else {
 936             setTSOLink(cap, cap->run_queue_tl, cap->wakeup_queue_hd);
 937             cap->run_queue_tl = cap->wakeup_queue_tl;
 938         }
 939         cap->wakeup_queue_hd = cap->wakeup_queue_tl = END_TSO_QUEUE;
 940         RELEASE_LOCK(&cap->lock);
 941     }
 942 #endif
 943 }
 944
 945 /* ----------------------------------------------------------------------------
 946  * Check for threads blocked on BLACKHOLEs that can be woken up
 947  * ------------------------------------------------------------------------- */
 948 static void
 949 scheduleCheckBlackHoles (Capability *cap)
 950 {
 951     if ( blackholes_need_checking ) // check without the lock first
 952     {
 953         ACQUIRE_LOCK(&sched_mutex);
 954         if ( blackholes_need_checking ) {
 955             blackholes_need_checking = rtsFalse;
 956             // important that we reset the flag *before* checking the
 957             // blackhole queue, otherwise we could get deadlock.  This
 958             // happens as follows: we wake up a thread that
 959             // immediately runs on another Capability, blocks on a
 960             // blackhole, and then we reset the blackholes_need_checking flag.
 961             checkBlackHoles(cap);
 962         }
 963         RELEASE_LOCK(&sched_mutex);
 964     }
 965 }
 966
 967 /* ----------------------------------------------------------------------------
 968  * Detect deadlock conditions and attempt to resolve them.
 969  * ------------------------------------------------------------------------- */
 970
 971 static void
 972 scheduleDetectDeadlock (Capability *cap, Task *task)
 973 {
 974
 975 #if defined(PARALLEL_HASKELL)
 976     // ToDo: add deadlock detection in GUM (similar to THREADED_RTS) -- HWL
 977     return;
 978 #endif
 979
 980     /*
 981      * Detect deadlock: when we have no threads to run, there are no
 982      * threads blocked, waiting for I/O, or sleeping, and all the
 983      * other tasks are waiting for work, we must have a deadlock of
 984      * some description.
 985      */
 986     if ( emptyThreadQueues(cap) )
 987     {
 988 #if defined(THREADED_RTS)
 989         /*
 990          * In the threaded RTS, we only check for deadlock if there
 991          * has been no activity in a complete timeslice.  This means
 992          * we won't eagerly start a full GC just because we don't have
 993          * any threads to run currently.
 994          */
 995         if (recent_activity != ACTIVITY_INACTIVE) return;
 996 #endif
 997
 998         debugTrace(DEBUG_sched, "deadlocked, forcing major GC...");
 999
1000         // Garbage collection can release some new threads due to
1001         // either (a) finalizers or (b) threads resurrected because
1002         // they are unreachable and will therefore be sent an
1003         // exception.  Any threads thus released will be immediately
1004         // runnable.
1005         cap = scheduleDoGC (cap, task, rtsTrue/*force major GC*/);
1006         // when force_major == rtsTrue. scheduleDoGC sets
1007         // recent_activity to ACTIVITY_DONE_GC and turns off the timer
1008         // signal.
1009
1010         if ( !emptyRunQueue(cap) ) return;
1011
1012 #if defined(RTS_USER_SIGNALS) && !defined(THREADED_RTS)
1013         /* If we have user-installed signal handlers, then wait
1014          * for signals to arrive rather then bombing out with a
1015          * deadlock.
1016          */
1017         if ( RtsFlags.MiscFlags.install_signal_handlers && anyUserHandlers() ) {
1018             debugTrace(DEBUG_sched,
1019                        "still deadlocked, waiting for signals...");
1020
1021             awaitUserSignals();
1022
1023             if (signals_pending()) {
1024                 startSignalHandlers(cap);
1025             }
1026
1027             // either we have threads to run, or we were interrupted:
1028             ASSERT(!emptyRunQueue(cap) || sched_state >= SCHED_INTERRUPTING);
1029
1030             return;
1031         }
1032 #endif
1033
1034 #if !defined(THREADED_RTS)
1035         /* Probably a real deadlock.  Send the current main thread the
1036          * Deadlock exception.
1037          */
1038         if (task->tso) {
1039             switch (task->tso->why_blocked) {
1040             case BlockedOnSTM:
1041             case BlockedOnBlackHole:
1042             case BlockedOnException:
1043             case BlockedOnMVar:
1044                 throwToSingleThreaded(cap, task->tso,
1045                                       (StgClosure *)nonTermination_closure);
1046                 return;
1047             default:
1048                 barf("deadlock: main thread blocked in a strange way");
1049             }
1050         }
1051         return;
1052 #endif
1053     }
1054 }
1055
1056
1057 /* ----------------------------------------------------------------------------
1058  * Send pending messages (PARALLEL_HASKELL only)
1059  * ------------------------------------------------------------------------- */
1060
1061 #if defined(PARALLEL_HASKELL)
1062 static void
1063 scheduleSendPendingMessages(void)
1064 {
1065
1066 # if defined(PAR) // global Mem.Mgmt., omit for now
1067     if (PendingFetches != END_BF_QUEUE) {
1068         processFetches();
1069     }
1070 # endif
1071
1072     if (RtsFlags.ParFlags.BufferTime) {
1073         // if we use message buffering, we must send away all message
1074         // packets which have become too old...
1075         sendOldBuffers();
1076     }
1077 }
1078 #endif
1079
1080 /* ----------------------------------------------------------------------------
1081  * Activate spark threads (PARALLEL_HASKELL and THREADED_RTS)
1082  * ------------------------------------------------------------------------- */
1083
1084 #if defined(PARALLEL_HASKELL) || defined(THREADED_RTS)
1085 static void
1086 scheduleActivateSpark(Capability *cap)
1087 {
1088     if (anySparks())
1089     {
1090         createSparkThread(cap);
1091         debugTrace(DEBUG_sched, "creating a spark thread");
1092     }
1093 }
1094 #endif // PARALLEL_HASKELL || THREADED_RTS
1095
1096 /* ----------------------------------------------------------------------------
1097  * Get work from a remote node (PARALLEL_HASKELL only)
1098  * ------------------------------------------------------------------------- */
1099
1100 #if defined(PARALLEL_HASKELL)
1101 static rtsBool /* return value used in PARALLEL_HASKELL only */
1102 scheduleGetRemoteWork (Capability *cap STG_UNUSED)
1103 {
1104 #if defined(PARALLEL_HASKELL)
1105   rtsBool receivedFinish = rtsFalse;
1106
1107   // idle() , i.e. send all buffers, wait for work
1108   if (RtsFlags.ParFlags.BufferTime) {
1109         IF_PAR_DEBUG(verbose,
1110                 debugBelch("...send all pending data,"));
1111         {
1112           nat i;
1113           for (i=1; i<=nPEs; i++)
1114             sendImmediately(i); // send all messages away immediately
1115         }
1116   }
1117
1118   /* this would be the place for fishing in GUM...
1119
1120      if (no-earlier-fish-around)
1121           sendFish(choosePe());
1122    */
1123
1124   // Eden:just look for incoming messages (blocking receive)
1125   IF_PAR_DEBUG(verbose,
1126                debugBelch("...wait for incoming messages...\n"));
1127   processMessages(cap, &receivedFinish); // blocking receive...
1128
1129
1130   return receivedFinish;
1131   // reenter scheduling look after having received something
1132
1133 #else /* !PARALLEL_HASKELL, i.e. THREADED_RTS */
1134
1135   return rtsFalse; /* return value unused in THREADED_RTS */
1136
1137 #endif /* PARALLEL_HASKELL */
1138 }
1139 #endif // PARALLEL_HASKELL || THREADED_RTS
1140
1141 /* ----------------------------------------------------------------------------
1142  * After running a thread...
1143  * ------------------------------------------------------------------------- */
1144
1145 static void
1146 schedulePostRunThread (Capability *cap, StgTSO *t)
1147 {
1148     // We have to be able to catch transactions that are in an
1149     // infinite loop as a result of seeing an inconsistent view of
1150     // memory, e.g.
1151     //
1152     //   atomically $ do
1153     //       [a,b] <- mapM readTVar [ta,tb]
1154     //       when (a == b) loop
1155     //
1156     // and a is never equal to b given a consistent view of memory.
1157     //
1158     if (t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
1159         if (!stmValidateNestOfTransactions (t -> trec)) {
1160             debugTrace(DEBUG_sched | DEBUG_stm,
1161                        "trec %p found wasting its time", t);
1162
1163             // strip the stack back to the
1164             // ATOMICALLY_FRAME, aborting the (nested)
1165             // transaction, and saving the stack of any
1166             // partially-evaluated thunks on the heap.
1167             throwToSingleThreaded_(cap, t, NULL, rtsTrue);
1168
1169             ASSERT(get_itbl((StgClosure *)t->sp)->type == ATOMICALLY_FRAME);
1170         }
1171     }
1172
1173   /* some statistics gathering in the parallel case */
1174 }
1175
1176 /* -----------------------------------------------------------------------------
1177  * Handle a thread that returned to the scheduler with ThreadHeepOverflow
1178  * -------------------------------------------------------------------------- */
1179
1180 static rtsBool
1181 scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
1182 {
1183     // did the task ask for a large block?
1184     if (cap->r.rHpAlloc > BLOCK_SIZE) {
1185         // if so, get one and push it on the front of the nursery.
1186         bdescr *bd;
1187         lnat blocks;
1188
1189         blocks = (lnat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
1190
1191         debugTrace(DEBUG_sched,
1192                    "--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n",
1193                    (long)t->id, whatNext_strs[t->what_next], blocks);
1194
1195         // don't do this if the nursery is (nearly) full, we'll GC first.
1196         if (cap->r.rCurrentNursery->link != NULL ||
1197             cap->r.rNursery->n_blocks == 1) {  // paranoia to prevent infinite loop
1198                                                // if the nursery has only one block.
1199
1200             ACQUIRE_SM_LOCK
1201             bd = allocGroup( blocks );
1202             RELEASE_SM_LOCK
1203             cap->r.rNursery->n_blocks += blocks;
1204
1205             // link the new group into the list
1206             bd->link = cap->r.rCurrentNursery;
1207             bd->u.back = cap->r.rCurrentNursery->u.back;
1208             if (cap->r.rCurrentNursery->u.back != NULL) {
1209                 cap->r.rCurrentNursery->u.back->link = bd;
1210             } else {
1211 #if !defined(THREADED_RTS)
1212                 ASSERT(g0s0->blocks == cap->r.rCurrentNursery &&
1213                        g0s0 == cap->r.rNursery);
1214 #endif
1215                 cap->r.rNursery->blocks = bd;
1216             }
1217             cap->r.rCurrentNursery->u.back = bd;
1218
1219             // initialise it as a nursery block.  We initialise the
1220             // step, gen_no, and flags field of *every* sub-block in
1221             // this large block, because this is easier than making
1222             // sure that we always find the block head of a large
1223             // block whenever we call Bdescr() (eg. evacuate() and
1224             // isAlive() in the GC would both have to do this, at
1225             // least).
1226             {
1227                 bdescr *x;
1228                 for (x = bd; x < bd + blocks; x++) {
1229                     x->step = cap->r.rNursery;
1230                     x->gen_no = 0;
1231                     x->flags = 0;
1232                 }
1233             }
1234
1235             // This assert can be a killer if the app is doing lots
1236             // of large block allocations.
1237             IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
1238
1239             // now update the nursery to point to the new block
1240             cap->r.rCurrentNursery = bd;
1241
1242             // we might be unlucky and have another thread get on the
1243             // run queue before us and steal the large block, but in that
1244             // case the thread will just end up requesting another large
1245             // block.
1246             pushOnRunQueue(cap,t);
1247             return rtsFalse;  /* not actually GC'ing */
1248         }
1249     }
1250
1251     debugTrace(DEBUG_sched,
1252                "--<< thread %ld (%s) stopped: HeapOverflow",
1253                (long)t->id, whatNext_strs[t->what_next]);
1254
1255     if (cap->context_switch) {
1256         // Sometimes we miss a context switch, e.g. when calling
1257         // primitives in a tight loop, MAYBE_GC() doesn't check the
1258         // context switch flag, and we end up waiting for a GC.
1259         // See #1984, and concurrent/should_run/1984
1260         cap->context_switch = 0;
1261         addToRunQueue(cap,t);
1262     } else {
1263         pushOnRunQueue(cap,t);
1264     }
1265     return rtsTrue;
1266     /* actual GC is done at the end of the while loop in schedule() */
1267 }
1268
1269 /* -----------------------------------------------------------------------------
1270  * Handle a thread that returned to the scheduler with ThreadStackOverflow
1271  * -------------------------------------------------------------------------- */
1272
1273 static void
1274 scheduleHandleStackOverflow (Capability *cap, Task *task, StgTSO *t)
1275 {
1276     debugTrace (DEBUG_sched,
1277                 "--<< thread %ld (%s) stopped, StackOverflow",
1278                 (long)t->id, whatNext_strs[t->what_next]);
1279
1280     /* just adjust the stack for this thread, then pop it back
1281      * on the run queue.
1282      */
1283     {
1284         /* enlarge the stack */
1285         StgTSO *new_t = threadStackOverflow(cap, t);
1286
1287         /* The TSO attached to this Task may have moved, so update the
1288          * pointer to it.
1289          */
1290         if (task->tso == t) {
1291             task->tso = new_t;
1292         }
1293         pushOnRunQueue(cap,new_t);
1294     }
1295 }
1296
1297 /* -----------------------------------------------------------------------------
1298  * Handle a thread that returned to the scheduler with ThreadYielding
1299  * -------------------------------------------------------------------------- */
1300
1301 static rtsBool
1302 scheduleHandleYield( Capability *cap, StgTSO *t, nat prev_what_next )
1303 {
1304     // Reset the context switch flag.  We don't do this just before
1305     // running the thread, because that would mean we would lose ticks
1306     // during GC, which can lead to unfair scheduling (a thread hogs
1307     // the CPU because the tick always arrives during GC).  This way
1308     // penalises threads that do a lot of allocation, but that seems
1309     // better than the alternative.
1310     cap->context_switch = 0;
1311
1312     /* put the thread back on the run queue.  Then, if we're ready to
1313      * GC, check whether this is the last task to stop.  If so, wake
1314      * up the GC thread.  getThread will block during a GC until the
1315      * GC is finished.
1316      */
1317 #ifdef DEBUG
1318     if (t->what_next != prev_what_next) {
1319         debugTrace(DEBUG_sched,
1320                    "--<< thread %ld (%s) stopped to switch evaluators",
1321                    (long)t->id, whatNext_strs[t->what_next]);
1322     } else {
1323         debugTrace(DEBUG_sched,
1324                    "--<< thread %ld (%s) stopped, yielding",
1325                    (long)t->id, whatNext_strs[t->what_next]);
1326     }
1327 #endif
1328
1329     IF_DEBUG(sanity,
1330              //debugBelch("&& Doing sanity check on yielding TSO %ld.", t->id);
1331              checkTSO(t));
1332     ASSERT(t->_link == END_TSO_QUEUE);
1333
1334     // Shortcut if we're just switching evaluators: don't bother
1335     // doing stack squeezing (which can be expensive), just run the
1336     // thread.
1337     if (t->what_next != prev_what_next) {
1338         return rtsTrue;
1339     }
1340
1341     addToRunQueue(cap,t);
1342
1343     return rtsFalse;
1344 }
1345
1346 /* -----------------------------------------------------------------------------
1347  * Handle a thread that returned to the scheduler with ThreadBlocked
1348  * -------------------------------------------------------------------------- */
1349
1350 static void
1351 scheduleHandleThreadBlocked( StgTSO *t
1352 #if !defined(GRAN) && !defined(DEBUG)
1353     STG_UNUSED
1354 #endif
1355     )
1356 {
1357
1358       // We don't need to do anything.  The thread is blocked, and it
1359       // has tidied up its stack and placed itself on whatever queue
1360       // it needs to be on.
1361
1362     // ASSERT(t->why_blocked != NotBlocked);
1363     // Not true: for example,
1364     //    - in THREADED_RTS, the thread may already have been woken
1365     //      up by another Capability.  This actually happens: try
1366     //      conc023 +RTS -N2.
1367     //    - the thread may have woken itself up already, because
1368     //      threadPaused() might have raised a blocked throwTo
1369     //      exception, see maybePerformBlockedException().
1370
1371 #ifdef DEBUG
1372     if (traceClass(DEBUG_sched)) {
1373         debugTraceBegin("--<< thread %lu (%s) stopped: ",
1374                         (unsigned long)t->id, whatNext_strs[t->what_next]);
1375         printThreadBlockage(t);
1376         debugTraceEnd();
1377     }
1378 #endif
1379 }
1380
1381 /* -----------------------------------------------------------------------------
1382  * Handle a thread that returned to the scheduler with ThreadFinished
1383  * -------------------------------------------------------------------------- */
1384
1385 static rtsBool
1386 scheduleHandleThreadFinished (Capability *cap STG_UNUSED, Task *task, StgTSO *t)
1387 {
1388     /* Need to check whether this was a main thread, and if so,
1389      * return with the return value.
1390      *
1391      * We also end up here if the thread kills itself with an
1392      * uncaught exception, see Exception.cmm.
1393      */
1394     debugTrace(DEBUG_sched, "--++ thread %lu (%s) finished",
1395                (unsigned long)t->id, whatNext_strs[t->what_next]);
1396
1397       //
1398       // Check whether the thread that just completed was a bound
1399       // thread, and if so return with the result.
1400       //
1401       // There is an assumption here that all thread completion goes
1402       // through this point; we need to make sure that if a thread
1403       // ends up in the ThreadKilled state, that it stays on the run
1404       // queue so it can be dealt with here.
1405       //
1406
1407       if (t->bound) {
1408
1409           if (t->bound != task) {
1410 #if !defined(THREADED_RTS)
1411               // Must be a bound thread that is not the topmost one.  Leave
1412               // it on the run queue until the stack has unwound to the
1413               // point where we can deal with this.  Leaving it on the run
1414               // queue also ensures that the garbage collector knows about
1415               // this thread and its return value (it gets dropped from the
1416               // step->threads list so there's no other way to find it).
1417               appendToRunQueue(cap,t);
1418               return rtsFalse;
1419 #else
1420               // this cannot happen in the threaded RTS, because a
1421               // bound thread can only be run by the appropriate Task.
1422               barf("finished bound thread that isn't mine");
1423 #endif
1424           }
1425
1426           ASSERT(task->tso == t);
1427
1428           if (t->what_next == ThreadComplete) {
1429               if (task->ret) {
1430                   // NOTE: return val is tso->sp[1] (see StgStartup.hc)
1431                   *(task->ret) = (StgClosure *)task->tso->sp[1];
1432               }
1433               task->stat = Success;
1434           } else {
1435               if (task->ret) {
1436                   *(task->ret) = NULL;
1437               }
1438               if (sched_state >= SCHED_INTERRUPTING) {
1439                   task->stat = Interrupted;
1440               } else {
1441                   task->stat = Killed;
1442               }
1443           }
1444 #ifdef DEBUG
1445           removeThreadLabel((StgWord)task->tso->id);
1446 #endif
1447           return rtsTrue; // tells schedule() to return
1448       }
1449
1450       return rtsFalse;
1451 }
1452
1453 /* -----------------------------------------------------------------------------
1454  * Perform a heap census
1455  * -------------------------------------------------------------------------- */
1456
1457 static rtsBool
1458 scheduleNeedHeapProfile( rtsBool ready_to_gc STG_UNUSED )
1459 {
1460     // When we have +RTS -i0 and we're heap profiling, do a census at
1461     // every GC.  This lets us get repeatable runs for debugging.
1462     if (performHeapProfile ||
1463         (RtsFlags.ProfFlags.profileInterval==0 &&
1464          RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) {
1465         return rtsTrue;
1466     } else {
1467         return rtsFalse;
1468     }
1469 }
1470
1471 /* -----------------------------------------------------------------------------
1472  * Perform a garbage collection if necessary
1473  * -------------------------------------------------------------------------- */
1474
1475 static Capability *
1476 scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS, rtsBool force_major)
1477 {
1478     rtsBool heap_census;
1479 #ifdef THREADED_RTS
1480     /* extern static volatile StgWord waiting_for_gc;
1481        lives inside capability.c */
1482     rtsBool gc_type, prev_pending_gc;
1483     nat i;
1484 #endif
1485
1486     if (sched_state == SCHED_SHUTTING_DOWN) {
1487         // The final GC has already been done, and the system is
1488         // shutting down.  We'll probably deadlock if we try to GC
1489         // now.
1490         return cap;
1491     }
1492
1493 #ifdef THREADED_RTS
1494     if (sched_state < SCHED_INTERRUPTING
1495         && RtsFlags.ParFlags.parGcEnabled
1496         && N >= RtsFlags.ParFlags.parGcGen
1497         && ! oldest_gen->steps[0].mark)
1498     {
1499         gc_type = PENDING_GC_PAR;
1500     } else {
1501         gc_type = PENDING_GC_SEQ;
1502     }
1503
1504     // In order to GC, there must be no threads running Haskell code.
1505     // Therefore, the GC thread needs to hold *all* the capabilities,
1506     // and release them after the GC has completed.
1507     //
1508     // This seems to be the simplest way: previous attempts involved
1509     // making all the threads with capabilities give up their
1510     // capabilities and sleep except for the *last* one, which
1511     // actually did the GC.  But it's quite hard to arrange for all
1512     // the other tasks to sleep and stay asleep.
1513     //
1514
1515     /*  Other capabilities are prevented from running yet more Haskell
1516         threads if waiting_for_gc is set. Tested inside
1517         yieldCapability() and releaseCapability() in Capability.c */
1518
1519     prev_pending_gc = cas(&waiting_for_gc, 0, gc_type);
1520     if (prev_pending_gc) {
1521         do {
1522             debugTrace(DEBUG_sched, "someone else is trying to GC (%d)...",
1523                        prev_pending_gc);
1524             ASSERT(cap);
1525             yieldCapability(&cap,task);
1526         } while (waiting_for_gc);
1527         return cap;  // NOTE: task->cap might have changed here
1528     }
1529
1530     setContextSwitches();
1531
1532     // The final shutdown GC is always single-threaded, because it's
1533     // possible that some of the Capabilities have no worker threads.
1534
1535     if (gc_type == PENDING_GC_SEQ)
1536     {
1537         // single-threaded GC: grab all the capabilities
1538         for (i=0; i < n_capabilities; i++) {
1539             debugTrace(DEBUG_sched, "ready_to_gc, grabbing all the capabilies (%d/%d)", i, n_capabilities);
1540             if (cap != &capabilities[i]) {
1541                 Capability *pcap = &capabilities[i];
1542                 // we better hope this task doesn't get migrated to
1543                 // another Capability while we're waiting for this one.
1544                 // It won't, because load balancing happens while we have
1545                 // all the Capabilities, but even so it's a slightly
1546                 // unsavoury invariant.
1547                 task->cap = pcap;
1548                 waitForReturnCapability(&pcap, task);
1549                 if (pcap != &capabilities[i]) {
1550                     barf("scheduleDoGC: got the wrong capability");
1551                 }
1552             }
1553         }
1554     }
1555     else
1556     {
1557         // multi-threaded GC: make sure all the Capabilities donate one
1558         // GC thread each.
1559         debugTrace(DEBUG_sched, "ready_to_gc, grabbing GC threads");
1560
1561         waitForGcThreads(cap);
1562     }
1563 #endif
1564
1565     // so this happens periodically:
1566     if (cap) scheduleCheckBlackHoles(cap);
1567
1568     IF_DEBUG(scheduler, printAllThreads());
1569
1570     /*
1571      * We now have all the capabilities; if we're in an interrupting
1572      * state, then we should take the opportunity to delete all the
1573      * threads in the system.
1574      */
1575     if (sched_state == SCHED_INTERRUPTING) {
1576         deleteAllThreads(cap);
1577         sched_state = SCHED_SHUTTING_DOWN;
1578     }
1579
1580     heap_census = scheduleNeedHeapProfile(rtsTrue);
1581
1582 #if defined(THREADED_RTS)
1583     debugTrace(DEBUG_sched, "doing GC");
1584     // reset waiting_for_gc *before* GC, so that when the GC threads
1585     // emerge they don't immediately re-enter the GC.
1586     waiting_for_gc = 0;
1587     GarbageCollect(force_major || heap_census, gc_type, cap);
1588 #else
1589     GarbageCollect(force_major || heap_census, 0, cap);
1590 #endif
1591
1592     if (heap_census) {
1593         debugTrace(DEBUG_sched, "performing heap census");
1594         heapCensus();
1595         performHeapProfile = rtsFalse;
1596     }
1597
1598 #ifdef SPARKBALANCE
1599     /* JB
1600        Once we are all together... this would be the place to balance all
1601        spark pools. No concurrent stealing or adding of new sparks can
1602        occur. Should be defined in Sparks.c. */
1603     balanceSparkPoolsCaps(n_capabilities, capabilities);
1604 #endif
1605
1606     if (force_major)
1607     {
1608         // We've just done a major GC and we don't need the timer
1609         // signal turned on any more (#1623).
1610         // NB. do this *before* releasing the Capabilities, to avoid
1611         // deadlocks!
1612         recent_activity = ACTIVITY_DONE_GC;
1613         stopTimer();
1614     }
1615
1616 #if defined(THREADED_RTS)
1617     if (gc_type == PENDING_GC_SEQ) {
1618         // release our stash of capabilities.
1619         for (i = 0; i < n_capabilities; i++) {
1620             if (cap != &capabilities[i]) {
1621                 task->cap = &capabilities[i];
1622                 releaseCapability(&capabilities[i]);
1623             }
1624         }
1625     }
1626     if (cap) {
1627         task->cap = cap;
1628     } else {
1629         task->cap = NULL;
1630     }
1631 #endif
1632
1633     return cap;
1634 }
1635
1636 /* ---------------------------------------------------------------------------
1637  * Singleton fork(). Do not copy any running threads.
1638  * ------------------------------------------------------------------------- */
1639
1640 pid_t
1641 forkProcess(HsStablePtr *entry
1642 #ifndef FORKPROCESS_PRIMOP_SUPPORTED
1643             STG_UNUSED
1644 #endif
1645            )
1646 {
1647 #ifdef FORKPROCESS_PRIMOP_SUPPORTED
1648     Task *task;
1649     pid_t pid;
1650     StgTSO* t,*next;
1651     Capability *cap;
1652     nat s;
1653
1654 #if defined(THREADED_RTS)
1655     if (RtsFlags.ParFlags.nNodes > 1) {
1656         errorBelch("forking not supported with +RTS -N<n> greater than 1");
1657         stg_exit(EXIT_FAILURE);
1658     }
1659 #endif
1660
1661     debugTrace(DEBUG_sched, "forking!");
1662
1663     // ToDo: for SMP, we should probably acquire *all* the capabilities
1664     cap = rts_lock();
1665
1666     // no funny business: hold locks while we fork, otherwise if some
1667     // other thread is holding a lock when the fork happens, the data
1668     // structure protected by the lock will forever be in an
1669     // inconsistent state in the child.  See also #1391.
1670     ACQUIRE_LOCK(&sched_mutex);
1671     ACQUIRE_LOCK(&cap->lock);
1672     ACQUIRE_LOCK(&cap->running_task->lock);
1673
1674     pid = fork();
1675
1676     if (pid) { // parent
1677
1678         RELEASE_LOCK(&sched_mutex);
1679         RELEASE_LOCK(&cap->lock);
1680         RELEASE_LOCK(&cap->running_task->lock);
1681
1682         // just return the pid
1683         rts_unlock(cap);
1684         return pid;
1685
1686     } else { // child
1687
1688 #if defined(THREADED_RTS)
1689         initMutex(&sched_mutex);
1690         initMutex(&cap->lock);
1691         initMutex(&cap->running_task->lock);
1692 #endif
1693
1694         // Now, all OS threads except the thread that forked are
1695         // stopped.  We need to stop all Haskell threads, including
1696         // those involved in foreign calls.  Also we need to delete
1697         // all Tasks, because they correspond to OS threads that are
1698         // now gone.
1699
1700         for (s = 0; s < total_steps; s++) {
1701           for (t = all_steps[s].threads; t != END_TSO_QUEUE; t = next) {
1702             if (t->what_next == ThreadRelocated) {
1703                 next = t->_link;
1704             } else {
1705                 next = t->global_link;
1706                 // don't allow threads to catch the ThreadKilled
1707                 // exception, but we do want to raiseAsync() because these
1708                 // threads may be evaluating thunks that we need later.
1709                 deleteThread_(cap,t);
1710             }
1711           }
1712         }
1713
1714         // Empty the run queue.  It seems tempting to let all the
1715         // killed threads stay on the run queue as zombies to be
1716         // cleaned up later, but some of them correspond to bound
1717         // threads for which the corresponding Task does not exist.
1718         cap->run_queue_hd = END_TSO_QUEUE;
1719         cap->run_queue_tl = END_TSO_QUEUE;
1720
1721         // Any suspended C-calling Tasks are no more, their OS threads
1722         // don't exist now:
1723         cap->suspended_ccalling_tasks = NULL;
1724
1725         // Empty the threads lists.  Otherwise, the garbage
1726         // collector may attempt to resurrect some of these threads.
1727         for (s = 0; s < total_steps; s++) {
1728             all_steps[s].threads = END_TSO_QUEUE;
1729         }
1730
1731         // Wipe the task list, except the current Task.
1732         ACQUIRE_LOCK(&sched_mutex);
1733         for (task = all_tasks; task != NULL; task=task->all_link) {
1734             if (task != cap->running_task) {
1735 #if defined(THREADED_RTS)
1736                 initMutex(&task->lock); // see #1391
1737 #endif
1738                 discardTask(task);
1739             }
1740         }
1741         RELEASE_LOCK(&sched_mutex);
1742
1743 #if defined(THREADED_RTS)
1744         // Wipe our spare workers list, they no longer exist.  New
1745         // workers will be created if necessary.
1746         cap->spare_workers = NULL;
1747         cap->returning_tasks_hd = NULL;
1748         cap->returning_tasks_tl = NULL;
1749 #endif
1750
1751         // On Unix, all timers are reset in the child, so we need to start
1752         // the timer again.
1753         initTimer();
1754         startTimer();
1755
1756         cap = rts_evalStableIO(cap, entry, NULL);  // run the action
1757         rts_checkSchedStatus("forkProcess",cap);
1758
1759         rts_unlock(cap);
1760         hs_exit();                      // clean up and exit
1761         stg_exit(EXIT_SUCCESS);
1762     }
1763 #else /* !FORKPROCESS_PRIMOP_SUPPORTED */
1764     barf("forkProcess#: primop not supported on this platform, sorry!\n");
1765     return -1;
1766 #endif
1767 }
1768
1769 /* ---------------------------------------------------------------------------
1770  * Delete all the threads in the system
1771  * ------------------------------------------------------------------------- */
1772
1773 static void
1774 deleteAllThreads ( Capability *cap )
1775 {
1776     // NOTE: only safe to call if we own all capabilities.
1777
1778     StgTSO* t, *next;
1779     nat s;
1780
1781     debugTrace(DEBUG_sched,"deleting all threads");
1782     for (s = 0; s < total_steps; s++) {
1783       for (t = all_steps[s].threads; t != END_TSO_QUEUE; t = next) {
1784         if (t->what_next == ThreadRelocated) {
1785             next = t->_link;
1786         } else {
1787             next = t->global_link;
1788             deleteThread(cap,t);
1789         }
1790       }
1791     }
1792
1793     // The run queue now contains a bunch of ThreadKilled threads.  We
1794     // must not throw these away: the main thread(s) will be in there
1795     // somewhere, and the main scheduler loop has to deal with it.
1796     // Also, the run queue is the only thing keeping these threads from
1797     // being GC'd, and we don't want the "main thread has been GC'd" panic.
1798
1799 #if !defined(THREADED_RTS)
1800     ASSERT(blocked_queue_hd == END_TSO_QUEUE);
1801     ASSERT(sleeping_queue == END_TSO_QUEUE);
1802 #endif
1803 }
1804
1805 /* -----------------------------------------------------------------------------
1806    Managing the suspended_ccalling_tasks list.
1807    Locks required: sched_mutex
1808    -------------------------------------------------------------------------- */
1809
1810 STATIC_INLINE void
1811 suspendTask (Capability *cap, Task *task)
1812 {
1813     ASSERT(task->next == NULL && task->prev == NULL);
1814     task->next = cap->suspended_ccalling_tasks;
1815     task->prev = NULL;
1816     if (cap->suspended_ccalling_tasks) {
1817         cap->suspended_ccalling_tasks->prev = task;
1818     }
1819     cap->suspended_ccalling_tasks = task;
1820 }
1821
1822 STATIC_INLINE void
1823 recoverSuspendedTask (Capability *cap, Task *task)
1824 {
1825     if (task->prev) {
1826         task->prev->next = task->next;
1827     } else {
1828         ASSERT(cap->suspended_ccalling_tasks == task);
1829         cap->suspended_ccalling_tasks = task->next;
1830     }
1831     if (task->next) {
1832         task->next->prev = task->prev;
1833     }
1834     task->next = task->prev = NULL;
1835 }
1836
1837 /* ---------------------------------------------------------------------------
1838  * Suspending & resuming Haskell threads.
1839  *
1840  * When making a "safe" call to C (aka _ccall_GC), the task gives back
1841  * its capability before calling the C function.  This allows another
1842  * task to pick up the capability and carry on running Haskell
1843  * threads.  It also means that if the C call blocks, it won't lock
1844  * the whole system.
1845  *
1846  * The Haskell thread making the C call is put to sleep for the
1847  * duration of the call, on the susepended_ccalling_threads queue.  We
1848  * give out a token to the task, which it can use to resume the thread
1849  * on return from the C function.
1850  * ------------------------------------------------------------------------- */
1851
1852 void *
1853 suspendThread (StgRegTable *reg)
1854 {
1855   Capability *cap;
1856   int saved_errno;
1857   StgTSO *tso;
1858   Task *task;
1859 #if mingw32_HOST_OS
1860   StgWord32 saved_winerror;
1861 #endif
1862
1863   saved_errno = errno;
1864 #if mingw32_HOST_OS
1865   saved_winerror = GetLastError();
1866 #endif
1867
1868   /* assume that *reg is a pointer to the StgRegTable part of a Capability.
1869    */
1870   cap = regTableToCapability(reg);
1871
1872   task = cap->running_task;
1873   tso = cap->r.rCurrentTSO;
1874
1875   debugTrace(DEBUG_sched,
1876              "thread %lu did a safe foreign call",
1877              (unsigned long)cap->r.rCurrentTSO->id);
1878
1879   // XXX this might not be necessary --SDM
1880   tso->what_next = ThreadRunGHC;
1881
1882   threadPaused(cap,tso);
1883
1884   if ((tso->flags & TSO_BLOCKEX) == 0)  {
1885       tso->why_blocked = BlockedOnCCall;
1886       tso->flags |= TSO_BLOCKEX;
1887       tso->flags &= ~TSO_INTERRUPTIBLE;
1888   } else {
1889       tso->why_blocked = BlockedOnCCall_NoUnblockExc;
1890   }
1891
1892   // Hand back capability
1893   task->suspended_tso = tso;
1894
1895   ACQUIRE_LOCK(&cap->lock);
1896
1897   suspendTask(cap,task);
1898   cap->in_haskell = rtsFalse;
1899   releaseCapability_(cap,rtsFalse);
1900
1901   RELEASE_LOCK(&cap->lock);
1902
1903 #if defined(THREADED_RTS)
1904   /* Preparing to leave the RTS, so ensure there's a native thread/task
1905      waiting to take over.
1906   */
1907   debugTrace(DEBUG_sched, "thread %lu: leaving RTS", (unsigned long)tso->id);
1908 #endif
1909
1910   errno = saved_errno;
1911 #if mingw32_HOST_OS
1912   SetLastError(saved_winerror);
1913 #endif
1914   return task;
1915 }
1916
1917 StgRegTable *
1918 resumeThread (void *task_)
1919 {
1920     StgTSO *tso;
1921     Capability *cap;
1922     Task *task = task_;
1923     int saved_errno;
1924 #if mingw32_HOST_OS
1925     StgWord32 saved_winerror;
1926 #endif
1927
1928     saved_errno = errno;
1929 #if mingw32_HOST_OS
1930     saved_winerror = GetLastError();
1931 #endif
1932
1933     cap = task->cap;
1934     // Wait for permission to re-enter the RTS with the result.
1935     waitForReturnCapability(&cap,task);
1936     // we might be on a different capability now... but if so, our
1937     // entry on the suspended_ccalling_tasks list will also have been
1938     // migrated.
1939
1940     // Remove the thread from the suspended list
1941     recoverSuspendedTask(cap,task);
1942
1943     tso = task->suspended_tso;
1944     task->suspended_tso = NULL;
1945     tso->_link = END_TSO_QUEUE; // no write barrier reqd
1946     debugTrace(DEBUG_sched, "thread %lu: re-entering RTS", (unsigned long)tso->id);
1947
1948     if (tso->why_blocked == BlockedOnCCall) {
1949         awakenBlockedExceptionQueue(cap,tso);
1950         tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
1951     }
1952
1953     /* Reset blocking status */
1954     tso->why_blocked  = NotBlocked;
1955
1956     cap->r.rCurrentTSO = tso;
1957     cap->in_haskell = rtsTrue;
1958     errno = saved_errno;
1959 #if mingw32_HOST_OS
1960     SetLastError(saved_winerror);
1961 #endif
1962
1963     /* We might have GC'd, mark the TSO dirty again */
1964     dirty_TSO(cap,tso);
1965
1966     IF_DEBUG(sanity, checkTSO(tso));
1967
1968     return &cap->r;
1969 }
1970
1971 /* ---------------------------------------------------------------------------
1972  * scheduleThread()
1973  *
1974  * scheduleThread puts a thread on the end  of the runnable queue.
1975  * This will usually be done immediately after a thread is created.
1976  * The caller of scheduleThread must create the thread using e.g.
1977  * createThread and push an appropriate closure
1978  * on this thread's stack before the scheduler is invoked.
1979  * ------------------------------------------------------------------------ */
1980
1981 void
1982 scheduleThread(Capability *cap, StgTSO *tso)
1983 {
1984     // The thread goes at the *end* of the run-queue, to avoid possible
1985     // starvation of any threads already on the queue.
1986     appendToRunQueue(cap,tso);
1987 }
1988
1989 void
1990 scheduleThreadOn(Capability *cap, StgWord cpu USED_IF_THREADS, StgTSO *tso)
1991 {
1992 #if defined(THREADED_RTS)
1993     tso->flags |= TSO_LOCKED; // we requested explicit affinity; don't
1994                               // move this thread from now on.
1995     cpu %= RtsFlags.ParFlags.nNodes;
1996     if (cpu == cap->no) {
1997         appendToRunQueue(cap,tso);
1998     } else {
1999         wakeupThreadOnCapability(cap, &capabilities[cpu], tso);
2000     }
2001 #else
2002     appendToRunQueue(cap,tso);
2003 #endif
2004 }
2005
2006 Capability *
2007 scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap)
2008 {
2009     Task *task;
2010
2011     // We already created/initialised the Task
2012     task = cap->running_task;
2013
2014     // This TSO is now a bound thread; make the Task and TSO
2015     // point to each other.
2016     tso->bound = task;
2017     tso->cap = cap;
2018
2019     task->tso = tso;
2020     task->ret = ret;
2021     task->stat = NoStatus;
2022
2023     appendToRunQueue(cap,tso);
2024
2025     debugTrace(DEBUG_sched, "new bound thread (%lu)", (unsigned long)tso->id);
2026
2027     cap = schedule(cap,task);
2028
2029     ASSERT(task->stat != NoStatus);
2030     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
2031
2032     debugTrace(DEBUG_sched, "bound thread (%lu) finished", (unsigned long)task->tso->id);
2033     return cap;
2034 }
2035
2036 /* ----------------------------------------------------------------------------
2037  * Starting Tasks
2038  * ------------------------------------------------------------------------- */
2039
2040 #if defined(THREADED_RTS)
2041 void OSThreadProcAttr
2042 workerStart(Task *task)
2043 {
2044     Capability *cap;
2045
2046     // See startWorkerTask().
2047     ACQUIRE_LOCK(&task->lock);
2048     cap = task->cap;
2049     RELEASE_LOCK(&task->lock);
2050
2051     // set the thread-local pointer to the Task:
2052     taskEnter(task);
2053
2054     // schedule() runs without a lock.
2055     cap = schedule(cap,task);
2056
2057     // On exit from schedule(), we have a Capability, but possibly not
2058     // the same one we started with.
2059
2060     // During shutdown, the requirement is that after all the
2061     // Capabilities are shut down, all workers that are shutting down
2062     // have finished workerTaskStop().  This is why we hold on to
2063     // cap->lock until we've finished workerTaskStop() below.
2064     //
2065     // There may be workers still involved in foreign calls; those
2066     // will just block in waitForReturnCapability() because the
2067     // Capability has been shut down.
2068     //
2069     ACQUIRE_LOCK(&cap->lock);
2070     releaseCapability_(cap,rtsFalse);
2071     workerTaskStop(task);
2072     RELEASE_LOCK(&cap->lock);
2073 }
2074 #endif
2075
2076 /* ---------------------------------------------------------------------------
2077  * initScheduler()
2078  *
2079  * Initialise the scheduler.  This resets all the queues - if the
2080  * queues contained any threads, they'll be garbage collected at the
2081  * next pass.
2082  *
2083  * ------------------------------------------------------------------------ */
2084
2085 void
2086 initScheduler(void)
2087 {
2088 #if !defined(THREADED_RTS)
2089   blocked_queue_hd  = END_TSO_QUEUE;
2090   blocked_queue_tl  = END_TSO_QUEUE;
2091   sleeping_queue    = END_TSO_QUEUE;
2092 #endif
2093
2094   blackhole_queue   = END_TSO_QUEUE;
2095
2096   sched_state    = SCHED_RUNNING;
2097   recent_activity = ACTIVITY_YES;
2098
2099 #if defined(THREADED_RTS)
2100   /* Initialise the mutex and condition variables used by
2101    * the scheduler. */
2102   initMutex(&sched_mutex);
2103 #endif
2104
2105   ACQUIRE_LOCK(&sched_mutex);
2106
2107   /* A capability holds the state a native thread needs in
2108    * order to execute STG code. At least one capability is
2109    * floating around (only THREADED_RTS builds have more than one).
2110    */
2111   initCapabilities();
2112
2113   initTaskManager();
2114
2115 #if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
2116   initSparkPools();
2117 #endif
2118
2119 #if defined(THREADED_RTS)
2120   /*
2121    * Eagerly start one worker to run each Capability, except for
2122    * Capability 0.  The idea is that we're probably going to start a
2123    * bound thread on Capability 0 pretty soon, so we don't want a
2124    * worker task hogging it.
2125    */
2126   {
2127       nat i;
2128       Capability *cap;
2129       for (i = 1; i < n_capabilities; i++) {
2130           cap = &capabilities[i];
2131           ACQUIRE_LOCK(&cap->lock);
2132           startWorkerTask(cap, workerStart);
2133           RELEASE_LOCK(&cap->lock);
2134       }
2135   }
2136 #endif
2137
2138   trace(TRACE_sched, "start: %d capabilities", n_capabilities);
2139
2140   RELEASE_LOCK(&sched_mutex);
2141 }
2142
2143 void
2144 exitScheduler(
2145     rtsBool wait_foreign
2146 #if !defined(THREADED_RTS)
2147                          __attribute__((unused))
2148 #endif
2149 )
2150                /* see Capability.c, shutdownCapability() */
2151 {
2152     Task *task = NULL;
2153
2154 #if defined(THREADED_RTS)
2155     ACQUIRE_LOCK(&sched_mutex);
2156     task = newBoundTask();
2157     RELEASE_LOCK(&sched_mutex);
2158 #endif
2159
2160     // If we haven't killed all the threads yet, do it now.
2161     if (sched_state < SCHED_SHUTTING_DOWN) {
2162         sched_state = SCHED_INTERRUPTING;
2163 #if defined(THREADED_RTS)
2164         waitForReturnCapability(&task->cap,task);
2165         scheduleDoGC(task->cap,task,rtsFalse);
2166         releaseCapability(task->cap);
2167 #else
2168         scheduleDoGC(&MainCapability,task,rtsFalse);
2169 #endif
2170     }
2171     sched_state = SCHED_SHUTTING_DOWN;
2172
2173 #if defined(THREADED_RTS)
2174     {
2175         nat i;
2176
2177         for (i = 0; i < n_capabilities; i++) {
2178             shutdownCapability(&capabilities[i], task, wait_foreign);
2179         }
2180         boundTaskExiting(task);
2181     }
2182 #endif
2183 }
2184
2185 void
2186 freeScheduler( void )
2187 {
2188     nat still_running;
2189
2190     ACQUIRE_LOCK(&sched_mutex);
2191     still_running = freeTaskManager();
2192     // We can only free the Capabilities if there are no Tasks still
2193     // running.  We might have a Task about to return from a foreign
2194     // call into waitForReturnCapability(), for example (actually,
2195     // this should be the *only* thing that a still-running Task can
2196     // do at this point, and it will block waiting for the
2197     // Capability).
2198     if (still_running == 0) {
2199         freeCapabilities();
2200         if (n_capabilities != 1) {
2201             stgFree(capabilities);
2202         }
2203     }
2204     RELEASE_LOCK(&sched_mutex);
2205 #if defined(THREADED_RTS)
2206     closeMutex(&sched_mutex);
2207 #endif
2208 }
2209
2210 /* -----------------------------------------------------------------------------
2211    performGC
2212
2213    This is the interface to the garbage collector from Haskell land.
2214    We provide this so that external C code can allocate and garbage
2215    collect when called from Haskell via _ccall_GC.
2216    -------------------------------------------------------------------------- */
2217
2218 static void
2219 performGC_(rtsBool force_major)
2220 {
2221     Task *task;
2222
2223     // We must grab a new Task here, because the existing Task may be
2224     // associated with a particular Capability, and chained onto the
2225     // suspended_ccalling_tasks queue.
2226     ACQUIRE_LOCK(&sched_mutex);
2227     task = newBoundTask();
2228     RELEASE_LOCK(&sched_mutex);
2229
2230     waitForReturnCapability(&task->cap,task);
2231     scheduleDoGC(task->cap,task,force_major);
2232     releaseCapability(task->cap);
2233     boundTaskExiting(task);
2234 }
2235
2236 void
2237 performGC(void)
2238 {
2239     performGC_(rtsFalse);
2240 }
2241
2242 void
2243 performMajorGC(void)
2244 {
2245     performGC_(rtsTrue);
2246 }
2247
2248 /* -----------------------------------------------------------------------------
2249    Stack overflow
2250
2251    If the thread has reached its maximum stack size, then raise the
2252    StackOverflow exception in the offending thread.  Otherwise
2253    relocate the TSO into a larger chunk of memory and adjust its stack
2254    size appropriately.
2255    -------------------------------------------------------------------------- */
2256
2257 static StgTSO *
2258 threadStackOverflow(Capability *cap, StgTSO *tso)
2259 {
2260   nat new_stack_size, stack_words;
2261   lnat new_tso_size;
2262   StgPtr new_sp;
2263   StgTSO *dest;
2264
2265   IF_DEBUG(sanity,checkTSO(tso));
2266
2267   // don't allow throwTo() to modify the blocked_exceptions queue
2268   // while we are moving the TSO:
2269   lockClosure((StgClosure *)tso);
2270
2271   if (tso->stack_size >= tso->max_stack_size && !(tso->flags & TSO_BLOCKEX)) {
2272       // NB. never raise a StackOverflow exception if the thread is
2273       // inside Control.Exceptino.block.  It is impractical to protect
2274       // against stack overflow exceptions, since virtually anything
2275       // can raise one (even 'catch'), so this is the only sensible
2276       // thing to do here.  See bug #767.
2277
2278       debugTrace(DEBUG_gc,
2279                  "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
2280                  (long)tso->id, tso, (long)tso->stack_size, (long)tso->max_stack_size);
2281       IF_DEBUG(gc,
2282                /* If we're debugging, just print out the top of the stack */
2283                printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2284                                                 tso->sp+64)));
2285
2286       // Send this thread the StackOverflow exception
2287       unlockTSO(tso);
2288       throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure);
2289       return tso;
2290   }
2291
2292   /* Try to double the current stack size.  If that takes us over the
2293    * maximum stack size for this thread, then use the maximum instead
2294    * (that is, unless we're already at or over the max size and we
2295    * can't raise the StackOverflow exception (see above), in which
2296    * case just double the size). Finally round up so the TSO ends up as
2297    * a whole number of blocks.
2298    */
2299   if (tso->stack_size >= tso->max_stack_size) {
2300       new_stack_size = tso->stack_size * 2;
2301   } else {
2302       new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
2303   }
2304   new_tso_size   = (lnat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
2305                                        TSO_STRUCT_SIZE)/sizeof(W_);
2306   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
2307   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
2308
2309   debugTrace(DEBUG_sched,
2310              "increasing stack size from %ld words to %d.",
2311              (long)tso->stack_size, new_stack_size);
2312
2313   dest = (StgTSO *)allocateLocal(cap,new_tso_size);
2314   TICK_ALLOC_TSO(new_stack_size,0);
2315
2316   /* copy the TSO block and the old stack into the new area */
2317   memcpy(dest,tso,TSO_STRUCT_SIZE);
2318   stack_words = tso->stack + tso->stack_size - tso->sp;
2319   new_sp = (P_)dest + new_tso_size - stack_words;
2320   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
2321
2322   /* relocate the stack pointers... */
2323   dest->sp         = new_sp;
2324   dest->stack_size = new_stack_size;
2325
2326   /* Mark the old TSO as relocated.  We have to check for relocated
2327    * TSOs in the garbage collector and any primops that deal with TSOs.
2328    *
2329    * It's important to set the sp value to just beyond the end
2330    * of the stack, so we don't attempt to scavenge any part of the
2331    * dead TSO's stack.
2332    */
2333   tso->what_next = ThreadRelocated;
2334   setTSOLink(cap,tso,dest);
2335   tso->sp = (P_)&(tso->stack[tso->stack_size]);
2336   tso->why_blocked = NotBlocked;
2337
2338   IF_PAR_DEBUG(verbose,
2339                debugBelch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld\n",
2340                      tso->id, tso, tso->stack_size);
2341                /* If we're debugging, just print out the top of the stack */
2342                printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
2343                                                 tso->sp+64)));
2344
2345   unlockTSO(dest);
2346   unlockTSO(tso);
2347
2348   IF_DEBUG(sanity,checkTSO(dest));
2349 #if 0
2350   IF_DEBUG(scheduler,printTSO(dest));
2351 #endif
2352
2353   return dest;
2354 }
2355
2356 static StgTSO *
2357 threadStackUnderflow (Task *task STG_UNUSED, StgTSO *tso)
2358 {
2359     bdescr *bd, *new_bd;
2360     lnat free_w, tso_size_w;
2361     StgTSO *new_tso;
2362
2363     tso_size_w = tso_sizeW(tso);
2364
2365     if (tso_size_w < MBLOCK_SIZE_W ||
2366         (nat)(tso->stack + tso->stack_size - tso->sp) > tso->stack_size / 4)
2367     {
2368         return tso;
2369     }
2370
2371     // don't allow throwTo() to modify the blocked_exceptions queue
2372     // while we are moving the TSO:
2373     lockClosure((StgClosure *)tso);
2374
2375     // this is the number of words we'll free
2376     free_w = round_to_mblocks(tso_size_w/2);
2377
2378     bd = Bdescr((StgPtr)tso);
2379     new_bd = splitLargeBlock(bd, free_w / BLOCK_SIZE_W);
2380     bd->free = bd->start + TSO_STRUCT_SIZEW;
2381
2382     new_tso = (StgTSO *)new_bd->start;
2383     memcpy(new_tso,tso,TSO_STRUCT_SIZE);
2384     new_tso->stack_size = new_bd->free - new_tso->stack;
2385
2386     debugTrace(DEBUG_sched, "thread %ld: reducing TSO size from %lu words to %lu",
2387                (long)tso->id, tso_size_w, tso_sizeW(new_tso));
2388
2389     tso->what_next = ThreadRelocated;
2390     tso->_link = new_tso; // no write barrier reqd: same generation
2391
2392     // The TSO attached to this Task may have moved, so update the
2393     // pointer to it.
2394     if (task->tso == tso) {
2395         task->tso = new_tso;
2396     }
2397
2398     unlockTSO(new_tso);
2399     unlockTSO(tso);
2400
2401     IF_DEBUG(sanity,checkTSO(new_tso));
2402
2403     return new_tso;
2404 }
2405
2406 /* ---------------------------------------------------------------------------
2407    Interrupt execution
2408    - usually called inside a signal handler so it mustn't do anything fancy.
2409    ------------------------------------------------------------------------ */
2410
2411 void
2412 interruptStgRts(void)
2413 {
2414     sched_state = SCHED_INTERRUPTING;
2415     setContextSwitches();
2416     wakeUpRts();
2417 }
2418
2419 /* -----------------------------------------------------------------------------
2420    Wake up the RTS
2421
2422    This function causes at least one OS thread to wake up and run the
2423    scheduler loop.  It is invoked when the RTS might be deadlocked, or
2424    an external event has arrived that may need servicing (eg. a
2425    keyboard interrupt).
2426
2427    In the single-threaded RTS we don't do anything here; we only have
2428    one thread anyway, and the event that caused us to want to wake up
2429    will have interrupted any blocking system call in progress anyway.
2430    -------------------------------------------------------------------------- */
2431
2432 void
2433 wakeUpRts(void)
2434 {
2435 #if defined(THREADED_RTS)
2436     // This forces the IO Manager thread to wakeup, which will
2437     // in turn ensure that some OS thread wakes up and runs the
2438     // scheduler loop, which will cause a GC and deadlock check.
2439     ioManagerWakeup();
2440 #endif
2441 }
2442
2443 /* -----------------------------------------------------------------------------
2444  * checkBlackHoles()
2445  *
2446  * Check the blackhole_queue for threads that can be woken up.  We do
2447  * this periodically: before every GC, and whenever the run queue is
2448  * empty.
2449  *
2450  * An elegant solution might be to just wake up all the blocked
2451  * threads with awakenBlockedQueue occasionally: they'll go back to
2452  * sleep again if the object is still a BLACKHOLE.  Unfortunately this
2453  * doesn't give us a way to tell whether we've actually managed to
2454  * wake up any threads, so we would be busy-waiting.
2455  *
2456  * -------------------------------------------------------------------------- */
2457
2458 static rtsBool
2459 checkBlackHoles (Capability *cap)
2460 {
2461     StgTSO **prev, *t;
2462     rtsBool any_woke_up = rtsFalse;
2463     StgHalfWord type;
2464
2465     // blackhole_queue is global:
2466     ASSERT_LOCK_HELD(&sched_mutex);
2467
2468     debugTrace(DEBUG_sched, "checking threads blocked on black holes");
2469
2470     // ASSUMES: sched_mutex
2471     prev = &blackhole_queue;
2472     t = blackhole_queue;
2473     while (t != END_TSO_QUEUE) {
2474         ASSERT(t->why_blocked == BlockedOnBlackHole);
2475         type = get_itbl(UNTAG_CLOSURE(t->block_info.closure))->type;
2476         if (type != BLACKHOLE && type != CAF_BLACKHOLE) {
2477             IF_DEBUG(sanity,checkTSO(t));
2478             t = unblockOne(cap, t);
2479             *prev = t;
2480             any_woke_up = rtsTrue;
2481         } else {
2482             prev = &t->_link;
2483             t = t->_link;
2484         }
2485     }
2486
2487     return any_woke_up;
2488 }
2489
2490 /* -----------------------------------------------------------------------------
2491    Deleting threads
2492
2493    This is used for interruption (^C) and forking, and corresponds to
2494    raising an exception but without letting the thread catch the
2495    exception.
2496    -------------------------------------------------------------------------- */
2497
2498 static void
2499 deleteThread (Capability *cap, StgTSO *tso)
2500 {
2501     // NOTE: must only be called on a TSO that we have exclusive
2502     // access to, because we will call throwToSingleThreaded() below.
2503     // The TSO must be on the run queue of the Capability we own, or
2504     // we must own all Capabilities.
2505
2506     if (tso->why_blocked != BlockedOnCCall &&
2507         tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
2508         throwToSingleThreaded(cap,tso,NULL);
2509     }
2510 }
2511
2512 #ifdef FORKPROCESS_PRIMOP_SUPPORTED
2513 static void
2514 deleteThread_(Capability *cap, StgTSO *tso)
2515 { // for forkProcess only:
2516   // like deleteThread(), but we delete threads in foreign calls, too.
2517
2518     if (tso->why_blocked == BlockedOnCCall ||
2519         tso->why_blocked == BlockedOnCCall_NoUnblockExc) {
2520         unblockOne(cap,tso);
2521         tso->what_next = ThreadKilled;
2522     } else {
2523         deleteThread(cap,tso);
2524     }
2525 }
2526 #endif
2527
2528 /* -----------------------------------------------------------------------------
2529    raiseExceptionHelper
2530
2531    This function is called by the raise# primitve, just so that we can
2532    move some of the tricky bits of raising an exception from C-- into
2533    C.  Who knows, it might be a useful re-useable thing here too.
2534    -------------------------------------------------------------------------- */
2535
2536 StgWord
2537 raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
2538 {
2539     Capability *cap = regTableToCapability(reg);
2540     StgThunk *raise_closure = NULL;
2541     StgPtr p, next;
2542     StgRetInfoTable *info;
2543     //
2544     // This closure represents the expression 'raise# E' where E
2545     // is the exception raise.  It is used to overwrite all the
2546     // thunks which are currently under evaluataion.
2547     //
2548
2549     // OLD COMMENT (we don't have MIN_UPD_SIZE now):
2550     // LDV profiling: stg_raise_info has THUNK as its closure
2551     // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
2552     // payload, MIN_UPD_SIZE is more approprate than 1.  It seems that
2553     // 1 does not cause any problem unless profiling is performed.
2554     // However, when LDV profiling goes on, we need to linearly scan
2555     // small object pool, where raise_closure is stored, so we should
2556     // use MIN_UPD_SIZE.
2557     //
2558     // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
2559     //                                 sizeofW(StgClosure)+1);
2560     //
2561
2562     //
2563     // Walk up the stack, looking for the catch frame.  On the way,
2564     // we update any closures pointed to from update frames with the
2565     // raise closure that we just built.
2566     //
2567     p = tso->sp;
2568     while(1) {
2569         info = get_ret_itbl((StgClosure *)p);
2570         next = p + stack_frame_sizeW((StgClosure *)p);
2571         switch (info->i.type) {
2572
2573         case UPDATE_FRAME:
2574             // Only create raise_closure if we need to.
2575             if (raise_closure == NULL) {
2576                 raise_closure =
2577                     (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+1);
2578                 SET_HDR(raise_closure, &stg_raise_info, CCCS);
2579                 raise_closure->payload[0] = exception;
2580             }
2581             UPD_IND(((StgUpdateFrame *)p)->updatee,(StgClosure *)raise_closure);
2582             p = next;
2583             continue;
2584
2585         case ATOMICALLY_FRAME:
2586             debugTrace(DEBUG_stm, "found ATOMICALLY_FRAME at %p", p);
2587             tso->sp = p;
2588             return ATOMICALLY_FRAME;
2589
2590         case CATCH_FRAME:
2591             tso->sp = p;
2592             return CATCH_FRAME;
2593
2594         case CATCH_STM_FRAME:
2595             debugTrace(DEBUG_stm, "found CATCH_STM_FRAME at %p", p);
2596             tso->sp = p;
2597             return CATCH_STM_FRAME;
2598
2599         case STOP_FRAME:
2600             tso->sp = p;
2601             return STOP_FRAME;
2602
2603         case CATCH_RETRY_FRAME:
2604         default:
2605             p = next;
2606             continue;
2607         }
2608     }
2609 }
2610
2611
2612 /* -----------------------------------------------------------------------------
2613    findRetryFrameHelper
2614
2615    This function is called by the retry# primitive.  It traverses the stack
2616    leaving tso->sp referring to the frame which should handle the retry.
2617
2618    This should either be a CATCH_RETRY_FRAME (if the retry# is within an orElse#)
2619    or should be a ATOMICALLY_FRAME (if the retry# reaches the top level).
2620
2621    We skip CATCH_STM_FRAMEs (aborting and rolling back the nested tx that they
2622    create) because retries are not considered to be exceptions, despite the
2623    similar implementation.
2624
2625    We should not expect to see CATCH_FRAME or STOP_FRAME because those should
2626    not be created within memory transactions.
2627    -------------------------------------------------------------------------- */
2628
2629 StgWord
2630 findRetryFrameHelper (StgTSO *tso)
2631 {
2632   StgPtr           p, next;
2633   StgRetInfoTable *info;
2634
2635   p = tso -> sp;
2636   while (1) {
2637     info = get_ret_itbl((StgClosure *)p);
2638     next = p + stack_frame_sizeW((StgClosure *)p);
2639     switch (info->i.type) {
2640
2641     case ATOMICALLY_FRAME:
2642         debugTrace(DEBUG_stm,
2643                    "found ATOMICALLY_FRAME at %p during retry", p);
2644         tso->sp = p;
2645         return ATOMICALLY_FRAME;
2646
2647     case CATCH_RETRY_FRAME:
2648         debugTrace(DEBUG_stm,
2649                    "found CATCH_RETRY_FRAME at %p during retrry", p);
2650         tso->sp = p;
2651         return CATCH_RETRY_FRAME;
2652
2653     case CATCH_STM_FRAME: {
2654         StgTRecHeader *trec = tso -> trec;
2655         StgTRecHeader *outer = stmGetEnclosingTRec(trec);
2656         debugTrace(DEBUG_stm,
2657                    "found CATCH_STM_FRAME at %p during retry", p);
2658         debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer);
2659         stmAbortTransaction(tso -> cap, trec);
2660         stmFreeAbortedTRec(tso -> cap, trec);
2661         tso -> trec = outer;
2662         p = next;
2663         continue;
2664     }
2665
2666
2667     default:
2668       ASSERT(info->i.type != CATCH_FRAME);
2669       ASSERT(info->i.type != STOP_FRAME);
2670       p = next;
2671       continue;
2672     }
2673   }
2674 }
2675
2676 /* -----------------------------------------------------------------------------
2677    resurrectThreads is called after garbage collection on the list of
2678    threads found to be garbage.  Each of these threads will be woken
2679    up and sent a signal: BlockedOnDeadMVar if the thread was blocked
2680    on an MVar, or NonTermination if the thread was blocked on a Black
2681    Hole.
2682
2683    Locks: assumes we hold *all* the capabilities.
2684    -------------------------------------------------------------------------- */
2685
2686 void
2687 resurrectThreads (StgTSO *threads)
2688 {
2689     StgTSO *tso, *next;
2690     Capability *cap;
2691     step *step;
2692
2693     for (tso = threads; tso != END_TSO_QUEUE; tso = next) {
2694         next = tso->global_link;
2695
2696         step = Bdescr((P_)tso)->step;
2697         tso->global_link = step->threads;
2698         step->threads = tso;
2699
2700         debugTrace(DEBUG_sched, "resurrecting thread %lu", (unsigned long)tso->id);
2701
2702         // Wake up the thread on the Capability it was last on
2703         cap = tso->cap;
2704
2705         switch (tso->why_blocked) {
2706         case BlockedOnMVar:
2707         case BlockedOnException:
2708             /* Called by GC - sched_mutex lock is currently held. */
2709             throwToSingleThreaded(cap, tso,
2710                                   (StgClosure *)blockedOnDeadMVar_closure);
2711             break;
2712         case BlockedOnBlackHole:
2713             throwToSingleThreaded(cap, tso,
2714                                   (StgClosure *)nonTermination_closure);
2715             break;
2716         case BlockedOnSTM:
2717             throwToSingleThreaded(cap, tso,
2718                                   (StgClosure *)blockedIndefinitely_closure);
2719             break;
2720         case NotBlocked:
2721             /* This might happen if the thread was blocked on a black hole
2722              * belonging to a thread that we've just woken up (raiseAsync
2723              * can wake up threads, remember...).
2724              */
2725             continue;
2726         default:
2727             barf("resurrectThreads: thread blocked in a strange way");
2728         }
2729     }
2730 }
2731
2732 /* -----------------------------------------------------------------------------
2733    performPendingThrowTos is called after garbage collection, and
2734    passed a list of threads that were found to have pending throwTos
2735    (tso->blocked_exceptions was not empty), and were blocked.
2736    Normally this doesn't happen, because we would deliver the
2737    exception directly if the target thread is blocked, but there are
2738    small windows where it might occur on a multiprocessor (see
2739    throwTo()).
2740
2741    NB. we must be holding all the capabilities at this point, just
2742    like resurrectThreads().
2743    -------------------------------------------------------------------------- */
2744
2745 void
2746 performPendingThrowTos (StgTSO *threads)
2747 {
2748     StgTSO *tso, *next;
2749     Capability *cap;
2750     step *step;
2751
2752     for (tso = threads; tso != END_TSO_QUEUE; tso = next) {
2753         next = tso->global_link;
2754
2755         step = Bdescr((P_)tso)->step;
2756         tso->global_link = step->threads;
2757         step->threads = tso;
2758
2759         debugTrace(DEBUG_sched, "performing blocked throwTo to thread %lu", (unsigned long)tso->id);
2760
2761         cap = tso->cap;
2762         maybePerformBlockedException(cap, tso);
2763     }
2764 }