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