ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.36 1999/12/01 14:34:40 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Scheduler
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 /* Version with scheduler monitor support for SMPs.
  11
  12    This design provides a high-level API to create and schedule threads etc.
  13    as documented in the SMP design document.
  14
  15    It uses a monitor design controlled by a single mutex to exercise control
  16    over accesses to shared data structures, and builds on the Posix threads
  17    library.
  18
  19    The majority of state is shared.  In order to keep essential per-task state,
  20    there is a Capability structure, which contains all the information
  21    needed to run a thread: its STG registers, a pointer to its TSO, a
  22    nursery etc.  During STG execution, a pointer to the capability is
  23    kept in a register (BaseReg).
  24
  25    In a non-SMP build, there is one global capability, namely MainRegTable.
  26
  27    SDM & KH, 10/99
  28 */
  29
  30 #include "Rts.h"
  31 #include "SchedAPI.h"
  32 #include "RtsUtils.h"
  33 #include "RtsFlags.h"
  34 #include "Storage.h"
  35 #include "StgRun.h"
  36 #include "StgStartup.h"
  37 #include "GC.h"
  38 #include "Hooks.h"
  39 #include "Schedule.h"
  40 #include "StgMiscClosures.h"
  41 #include "Storage.h"
  42 #include "Evaluator.h"
  43 #include "Exception.h"
  44 #include "Printer.h"
  45 #include "Main.h"
  46 #include "Signals.h"
  47 #include "Profiling.h"
  48 #include "Sanity.h"
  49 #include "Stats.h"
  50
  51 /* Main threads:
  52  *
  53  * These are the threads which clients have requested that we run.
  54  *
  55  * In an SMP build, we might have several concurrent clients all
  56  * waiting for results, and each one will wait on a condition variable
  57  * until the result is available.
  58  *
  59  * In non-SMP, clients are strictly nested: the first client calls
  60  * into the RTS, which might call out again to C with a _ccall_GC, and
  61  * eventually re-enter the RTS.
  62  *
  63  * Main threads information is kept in a linked list:
  64  */
  65 typedef struct StgMainThread_ {
  66   StgTSO *         tso;
  67   SchedulerStatus  stat;
  68   StgClosure **    ret;
  69 #ifdef SMP
  70   pthread_cond_t wakeup;
  71 #endif
  72   struct StgMainThread_ *link;
  73 } StgMainThread;
  74
  75 /* Main thread queue.
  76  * Locks required: sched_mutex.
  77  */
  78 static StgMainThread *main_threads;
  79
  80 /* Thread queues.
  81  * Locks required: sched_mutex.
  82  */
  83 StgTSO *run_queue_hd, *run_queue_tl;
  84 StgTSO *blocked_queue_hd, *blocked_queue_tl;
  85
  86 /* Threads suspended in _ccall_GC.
  87  * Locks required: sched_mutex.
  88  */
  89 static StgTSO *suspended_ccalling_threads;
  90
  91 static void GetRoots(void);
  92 static StgTSO *threadStackOverflow(StgTSO *tso);
  93
  94 /* KH: The following two flags are shared memory locations.  There is no need
  95        to lock them, since they are only unset at the end of a scheduler
  96        operation.
  97 */
  98
  99 /* flag set by signal handler to precipitate a context switch */
 100 nat context_switch;
 101 /* if this flag is set as well, give up execution */
 102 static nat interrupted;
 103
 104 /* Next thread ID to allocate.
 105  * Locks required: sched_mutex
 106  */
 107 StgThreadID next_thread_id = 1;
 108
 109 /*
 110  * Pointers to the state of the current thread.
 111  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
 112  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
 113  */
 114
 115 /* The smallest stack size that makes any sense is:
 116  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
 117  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
 118  *  + 1                       (the realworld token for an IO thread)
 119  *  + 1                       (the closure to enter)
 120  *
 121  * A thread with this stack will bomb immediately with a stack
 122  * overflow, which will increase its stack size.
 123  */
 124
 125 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
 126
 127 /* Free capability list.
 128  * Locks required: sched_mutex.
 129  */
 130 #ifdef SMP
 131 Capability *free_capabilities;  /* Available capabilities for running threads */
 132 nat n_free_capabilities;        /* total number of available capabilities */
 133 #else
 134 Capability MainRegTable;        /* for non-SMP, we have one global capability */
 135 #endif
 136
 137 rtsBool ready_to_gc;
 138
 139 /* All our current task ids, saved in case we need to kill them later.
 140  */
 141 #ifdef SMP
 142 task_info *task_ids;
 143 #endif
 144
 145 void            addToBlockedQueue ( StgTSO *tso );
 146
 147 static void     schedule          ( void );
 148 static void     initThread        ( StgTSO *tso, nat stack_size );
 149        void     interruptStgRts   ( void );
 150
 151 #ifdef SMP
 152 pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
 153 pthread_mutex_t term_mutex        = PTHREAD_MUTEX_INITIALIZER;
 154 pthread_cond_t  thread_ready_cond = PTHREAD_COND_INITIALIZER;
 155 pthread_cond_t  gc_pending_cond   = PTHREAD_COND_INITIALIZER;
 156
 157 nat await_death;
 158 #endif
 159
 160 /* -----------------------------------------------------------------------------
 161    Main scheduling loop.
 162
 163    We use round-robin scheduling, each thread returning to the
 164    scheduler loop when one of these conditions is detected:
 165
 166       * out of heap space
 167       * timer expires (thread yields)
 168       * thread blocks
 169       * thread ends
 170       * stack overflow
 171
 172    Locking notes:  we acquire the scheduler lock once at the beginning
 173    of the scheduler loop, and release it when
 174
 175       * running a thread, or
 176       * waiting for work, or
 177       * waiting for a GC to complete.
 178
 179    -------------------------------------------------------------------------- */
 180
 181 static void
 182 schedule( void )
 183 {
 184   StgTSO *t;
 185   Capability *cap;
 186   StgThreadReturnCode ret;
 187
 188   ACQUIRE_LOCK(&sched_mutex);
 189
 190   while (1) {
 191
 192     /* If we're interrupted (the user pressed ^C, or some other
 193      * termination condition occurred), kill all the currently running
 194      * threads.
 195      */
 196     if (interrupted) {
 197       IF_DEBUG(scheduler,belch("schedule: interrupted"));
 198       for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 199         deleteThread(t);
 200       }
 201       for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 202         deleteThread(t);
 203       }
 204       run_queue_hd = run_queue_tl = END_TSO_QUEUE;
 205       blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
 206     }
 207
 208     /* Go through the list of main threads and wake up any
 209      * clients whose computations have finished.  ToDo: this
 210      * should be done more efficiently without a linear scan
 211      * of the main threads list, somehow...
 212      */
 213 #ifdef SMP
 214     {
 215       StgMainThread *m, **prev;
 216       prev = &main_threads;
 217       for (m = main_threads; m != NULL; m = m->link) {
 218         if (m->tso->whatNext == ThreadComplete) {
 219           if (m->ret) {
 220             *(m->ret) = (StgClosure *)m->tso->sp[0];
 221           }
 222           *prev = m->link;
 223           m->stat = Success;
 224           pthread_cond_broadcast(&m->wakeup);
 225         }
 226         if (m->tso->whatNext == ThreadKilled) {
 227           *prev = m->link;
 228           m->stat = Killed;
 229           pthread_cond_broadcast(&m->wakeup);
 230         }
 231       }
 232     }
 233 #else
 234     /* If our main thread has finished or been killed, return.
 235      */
 236     {
 237       StgMainThread *m = main_threads;
 238       if (m->tso->whatNext == ThreadComplete
 239           || m->tso->whatNext == ThreadKilled) {
 240         main_threads = main_threads->link;
 241         if (m->tso->whatNext == ThreadComplete) {
 242           /* we finished successfully, fill in the return value */
 243           if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
 244           m->stat = Success;
 245           return;
 246         } else {
 247           m->stat = Killed;
 248           return;
 249         }
 250       }
 251     }
 252 #endif
 253
 254     /* Check whether any waiting threads need to be woken up.  If the
 255      * run queue is empty, and there are no other tasks running, we
 256      * can wait indefinitely for something to happen.
 257      * ToDo: what if another client comes along & requests another
 258      * main thread?
 259      */
 260     if (blocked_queue_hd != END_TSO_QUEUE) {
 261       awaitEvent(
 262            (run_queue_hd == END_TSO_QUEUE)
 263 #ifdef SMP
 264         && (n_free_capabilities == RtsFlags.ConcFlags.nNodes)
 265 #endif
 266         );
 267     }
 268
 269     /* check for signals each time around the scheduler */
 270 #ifndef __MINGW32__
 271     if (signals_pending()) {
 272       start_signal_handlers();
 273     }
 274 #endif
 275
 276     /* Detect deadlock: when we have no threads to run, there are
 277      * no threads waiting on I/O or sleeping, and all the other
 278      * tasks are waiting for work, we must have a deadlock.  Inform
 279      * all the main threads.
 280      */
 281 #ifdef SMP
 282     if (blocked_queue_hd == END_TSO_QUEUE
 283         && run_queue_hd == END_TSO_QUEUE
 284         && (n_free_capabilities == RtsFlags.ConcFlags.nNodes)
 285         ) {
 286       StgMainThread *m;
 287       for (m = main_threads; m != NULL; m = m->link) {
 288           m->ret = NULL;
 289           m->stat = Deadlock;
 290           pthread_cond_broadcast(&m->wakeup);
 291       }
 292       main_threads = NULL;
 293     }
 294 #else /* ! SMP */
 295     if (blocked_queue_hd == END_TSO_QUEUE
 296         && run_queue_hd == END_TSO_QUEUE) {
 297       StgMainThread *m = main_threads;
 298       m->ret = NULL;
 299       m->stat = Deadlock;
 300       main_threads = m->link;
 301       return;
 302     }
 303 #endif
 304
 305 #ifdef SMP
 306     /* If there's a GC pending, don't do anything until it has
 307      * completed.
 308      */
 309     if (ready_to_gc) {
 310       IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): waiting for GC\n",
 311                                  pthread_self()););
 312       pthread_cond_wait(&gc_pending_cond, &sched_mutex);
 313     }
 314
 315     /* block until we've got a thread on the run queue and a free
 316      * capability.
 317      */
 318     while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
 319       IF_DEBUG(scheduler,
 320                fprintf(stderr, "schedule (task %ld): waiting for work\n",
 321                        pthread_self()););
 322       pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 323       IF_DEBUG(scheduler,
 324                fprintf(stderr, "schedule (task %ld): work now available\n",
 325                        pthread_self()););
 326     }
 327 #endif
 328
 329     /* grab a thread from the run queue
 330      */
 331     t = POP_RUN_QUEUE();
 332
 333     /* grab a capability
 334      */
 335 #ifdef SMP
 336     cap = free_capabilities;
 337     free_capabilities = cap->link;
 338     n_free_capabilities--;
 339 #else
 340     cap = &MainRegTable;
 341 #endif
 342
 343     cap->rCurrentTSO = t;
 344
 345     /* set the context_switch flag
 346      */
 347     if (run_queue_hd == END_TSO_QUEUE)
 348       context_switch = 0;
 349     else
 350       context_switch = 1;
 351
 352     RELEASE_LOCK(&sched_mutex);
 353
 354 #ifdef SMP
 355     IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): running thread %d\n", pthread_self(),t->id));
 356 #else
 357     IF_DEBUG(scheduler,fprintf(stderr,"schedule: running thread %d\n",t->id));
 358 #endif
 359
 360     /* Run the current thread
 361      */
 362     switch (cap->rCurrentTSO->whatNext) {
 363     case ThreadKilled:
 364     case ThreadComplete:
 365       /* Thread already finished, return to scheduler. */
 366       ret = ThreadFinished;
 367       break;
 368     case ThreadEnterGHC:
 369       ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
 370       break;
 371     case ThreadRunGHC:
 372       ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
 373       break;
 374     case ThreadEnterHugs:
 375 #ifdef INTERPRETER
 376       {
 377          StgClosure* c;
 378          IF_DEBUG(scheduler,belch("schedule: entering Hugs"));
 379          c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
 380          cap->rCurrentTSO->sp += 1;
 381          ret = enter(cap,c);
 382          break;
 383       }
 384 #else
 385       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 386 #endif
 387     default:
 388       barf("schedule: invalid whatNext field");
 389     }
 390
 391     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 392 #ifdef PROFILING
 393     CCCS = CCS_SYSTEM;
 394 #endif
 395
 396     ACQUIRE_LOCK(&sched_mutex);
 397
 398 #ifdef SMP
 399     IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): ", pthread_self()););
 400 #else
 401     IF_DEBUG(scheduler,fprintf(stderr,"schedule: "););
 402 #endif
 403     t = cap->rCurrentTSO;
 404
 405     switch (ret) {
 406     case HeapOverflow:
 407       /* make all the running tasks block on a condition variable,
 408        * maybe set context_switch and wait till they all pile in,
 409        * then have them wait on a GC condition variable.
 410        */
 411       IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
 412       threadPaused(t);
 413
 414       ready_to_gc = rtsTrue;
 415       context_switch = 1;               /* stop other threads ASAP */
 416       PUSH_ON_RUN_QUEUE(t);
 417       break;
 418
 419     case StackOverflow:
 420       /* just adjust the stack for this thread, then pop it back
 421        * on the run queue.
 422        */
 423       IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
 424       threadPaused(t);
 425       {
 426         StgMainThread *m;
 427         /* enlarge the stack */
 428         StgTSO *new_t = threadStackOverflow(t);
 429
 430         /* This TSO has moved, so update any pointers to it from the
 431          * main thread stack.  It better not be on any other queues...
 432          * (it shouldn't be)
 433          */
 434         for (m = main_threads; m != NULL; m = m->link) {
 435           if (m->tso == t) {
 436             m->tso = new_t;
 437           }
 438         }
 439         PUSH_ON_RUN_QUEUE(new_t);
 440       }
 441       break;
 442
 443     case ThreadYielding:
 444       /* put the thread back on the run queue.  Then, if we're ready to
 445        * GC, check whether this is the last task to stop.  If so, wake
 446        * up the GC thread.  getThread will block during a GC until the
 447        * GC is finished.
 448        */
 449       IF_DEBUG(scheduler,
 450                if (t->whatNext == ThreadEnterHugs) {
 451                  /* ToDo: or maybe a timer expired when we were in Hugs?
 452                   * or maybe someone hit ctrl-C
 453                   */
 454                  belch("thread %ld stopped to switch to Hugs", t->id);
 455                } else {
 456                  belch("thread %ld stopped, yielding", t->id);
 457                }
 458                );
 459       threadPaused(t);
 460       APPEND_TO_RUN_QUEUE(t);
 461       break;
 462
 463     case ThreadBlocked:
 464       /* don't need to do anything.  Either the thread is blocked on
 465        * I/O, in which case we'll have called addToBlockedQueue
 466        * previously, or it's blocked on an MVar or Blackhole, in which
 467        * case it'll be on the relevant queue already.
 468        */
 469       IF_DEBUG(scheduler,
 470                fprintf(stderr, "thread %d stopped, ", t->id);
 471                printThreadBlockage(t);
 472                fprintf(stderr, "\n"));
 473       threadPaused(t);
 474       break;
 475
 476     case ThreadFinished:
 477       /* Need to check whether this was a main thread, and if so, signal
 478        * the task that started it with the return value.  If we have no
 479        * more main threads, we probably need to stop all the tasks until
 480        * we get a new one.
 481        */
 482       IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
 483       t->whatNext = ThreadComplete;
 484       break;
 485
 486     default:
 487       barf("doneThread: invalid thread return code");
 488     }
 489
 490 #ifdef SMP
 491     cap->link = free_capabilities;
 492     free_capabilities = cap;
 493     n_free_capabilities++;
 494 #endif
 495
 496 #ifdef SMP
 497     if (ready_to_gc && n_free_capabilities == RtsFlags.ConcFlags.nNodes) {
 498 #else
 499     if (ready_to_gc) {
 500 #endif
 501       /* everybody back, start the GC.
 502        * Could do it in this thread, or signal a condition var
 503        * to do it in another thread.  Either way, we need to
 504        * broadcast on gc_pending_cond afterward.
 505        */
 506 #ifdef SMP
 507       IF_DEBUG(scheduler,belch("schedule (task %ld): doing GC", pthread_self()));
 508 #endif
 509       GarbageCollect(GetRoots);
 510       ready_to_gc = rtsFalse;
 511 #ifdef SMP
 512       pthread_cond_broadcast(&gc_pending_cond);
 513 #endif
 514     }
 515   } /* end of while(1) */
 516 }
 517
 518
 519 /* A hack for Hugs concurrency support.  Needs sanitisation (?) */
 520 void deleteAllThreads ( void )
 521 {
 522   StgTSO* t;
 523   IF_DEBUG(scheduler,belch("deleteAllThreads()"));
 524   for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 525     deleteThread(t);
 526   }
 527   for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 528     deleteThread(t);
 529   }
 530   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
 531   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
 532 }
 533
 534
 535 /* -----------------------------------------------------------------------------
 536  * Suspending & resuming Haskell threads.
 537  *
 538  * When making a "safe" call to C (aka _ccall_GC), the task gives back
 539  * its capability before calling the C function.  This allows another
 540  * task to pick up the capability and carry on running Haskell
 541  * threads.  It also means that if the C call blocks, it won't lock
 542  * the whole system.
 543  *
 544  * The Haskell thread making the C call is put to sleep for the
 545  * duration of the call, on the susepended_ccalling_threads queue.  We
 546  * give out a token to the task, which it can use to resume the thread
 547  * on return from the C function.
 548  * -------------------------------------------------------------------------- */
 549
 550 StgInt
 551 suspendThread( Capability *cap )
 552 {
 553   nat tok;
 554
 555   ACQUIRE_LOCK(&sched_mutex);
 556
 557 #ifdef SMP
 558   IF_DEBUG(scheduler,
 559            fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n",
 560                    pthread_self(), cap->rCurrentTSO->id));
 561 #else
 562   IF_DEBUG(scheduler,
 563            fprintf(stderr, "schedule: thread %d did a _ccall_gc\n",
 564                    cap->rCurrentTSO->id));
 565 #endif
 566
 567   threadPaused(cap->rCurrentTSO);
 568   cap->rCurrentTSO->link = suspended_ccalling_threads;
 569   suspended_ccalling_threads = cap->rCurrentTSO;
 570
 571   /* Use the thread ID as the token; it should be unique */
 572   tok = cap->rCurrentTSO->id;
 573
 574 #ifdef SMP
 575   cap->link = free_capabilities;
 576   free_capabilities = cap;
 577   n_free_capabilities++;
 578 #endif
 579
 580   RELEASE_LOCK(&sched_mutex);
 581   return tok;
 582 }
 583
 584 Capability *
 585 resumeThread( StgInt tok )
 586 {
 587   StgTSO *tso, **prev;
 588   Capability *cap;
 589
 590   ACQUIRE_LOCK(&sched_mutex);
 591
 592   prev = &suspended_ccalling_threads;
 593   for (tso = suspended_ccalling_threads;
 594        tso != END_TSO_QUEUE;
 595        prev = &tso->link, tso = tso->link) {
 596     if (tso->id == (StgThreadID)tok) {
 597       *prev = tso->link;
 598       break;
 599     }
 600   }
 601   if (tso == END_TSO_QUEUE) {
 602     barf("resumeThread: thread not found");
 603   }
 604
 605 #ifdef SMP
 606   while (free_capabilities == NULL) {
 607     IF_DEBUG(scheduler,
 608              fprintf(stderr,"schedule (task %ld): waiting to resume\n",
 609                      pthread_self()));
 610     pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 611     IF_DEBUG(scheduler,fprintf(stderr,
 612                                "schedule (task %ld): resuming thread %d\n",
 613                                pthread_self(), tso->id));
 614   }
 615   cap = free_capabilities;
 616   free_capabilities = cap->link;
 617   n_free_capabilities--;
 618 #else
 619   cap = &MainRegTable;
 620 #endif
 621
 622   cap->rCurrentTSO = tso;
 623
 624   RELEASE_LOCK(&sched_mutex);
 625   return cap;
 626 }
 627
 628 /* -----------------------------------------------------------------------------
 629  * Static functions
 630  * -------------------------------------------------------------------------- */
 631 static void unblockThread(StgTSO *tso);
 632
 633 /* -----------------------------------------------------------------------------
 634  * Comparing Thread ids.
 635  *
 636  * This is used from STG land in the implementation of the
 637  * instances of Eq/Ord for ThreadIds.
 638  * -------------------------------------------------------------------------- */
 639
 640 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
 641 {
 642   StgThreadID id1 = tso1->id;
 643   StgThreadID id2 = tso2->id;
 644
 645   if (id1 < id2) return (-1);
 646   if (id1 > id2) return 1;
 647   return 0;
 648 }
 649
 650 /* -----------------------------------------------------------------------------
 651    Create a new thread.
 652
 653    The new thread starts with the given stack size.  Before the
 654    scheduler can run, however, this thread needs to have a closure
 655    (and possibly some arguments) pushed on its stack.  See
 656    pushClosure() in Schedule.h.
 657
 658    createGenThread() and createIOThread() (in SchedAPI.h) are
 659    convenient packaged versions of this function.
 660    -------------------------------------------------------------------------- */
 661
 662 StgTSO *
 663 createThread(nat stack_size)
 664 {
 665   StgTSO *tso;
 666
 667   /* catch ridiculously small stack sizes */
 668   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
 669     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
 670   }
 671
 672   tso = (StgTSO *)allocate(stack_size);
 673   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
 674
 675   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
 676   return tso;
 677 }
 678
 679 void
 680 initThread(StgTSO *tso, nat stack_size)
 681 {
 682   SET_HDR(tso, &TSO_info, CCS_MAIN);
 683   tso->whatNext     = ThreadEnterGHC;
 684
 685   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
 686          protect the increment operation on next_thread_id.
 687          In future, we could use an atomic increment instead.
 688   */
 689
 690   ACQUIRE_LOCK(&sched_mutex);
 691   tso->id = next_thread_id++;
 692   RELEASE_LOCK(&sched_mutex);
 693
 694   tso->why_blocked  = NotBlocked;
 695
 696   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 697   tso->stack_size   = stack_size;
 698   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 699                               - TSO_STRUCT_SIZEW;
 700   tso->sp           = (P_)&(tso->stack) + stack_size;
 701
 702 #ifdef PROFILING
 703   tso->prof.CCCS = CCS_MAIN;
 704 #endif
 705
 706   /* put a stop frame on the stack */
 707   tso->sp -= sizeofW(StgStopFrame);
 708   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 709   tso->su = (StgUpdateFrame*)tso->sp;
 710
 711   IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words",
 712                            tso->id, tso->stack_size));
 713
 714 }
 715
 716
 717 /* -----------------------------------------------------------------------------
 718  * scheduleThread()
 719  *
 720  * scheduleThread puts a thread on the head of the runnable queue.
 721  * This will usually be done immediately after a thread is created.
 722  * The caller of scheduleThread must create the thread using e.g.
 723  * createThread and push an appropriate closure
 724  * on this thread's stack before the scheduler is invoked.
 725  * -------------------------------------------------------------------------- */
 726
 727 void
 728 scheduleThread(StgTSO *tso)
 729 {
 730   ACQUIRE_LOCK(&sched_mutex);
 731
 732   /* Put the new thread on the head of the runnable queue.  The caller
 733    * better push an appropriate closure on this thread's stack
 734    * beforehand.  In the SMP case, the thread may start running as
 735    * soon as we release the scheduler lock below.
 736    */
 737   PUSH_ON_RUN_QUEUE(tso);
 738   THREAD_RUNNABLE();
 739
 740   IF_DEBUG(scheduler,printTSO(tso));
 741   RELEASE_LOCK(&sched_mutex);
 742 }
 743
 744
 745 /* -----------------------------------------------------------------------------
 746  * startTasks()
 747  *
 748  * Start up Posix threads to run each of the scheduler tasks.
 749  * I believe the task ids are not needed in the system as defined.
 750   * KH @ 25/10/99
 751  * -------------------------------------------------------------------------- */
 752
 753 #ifdef SMP
 754 static void *
 755 taskStart( void *arg STG_UNUSED )
 756 {
 757   schedule();
 758   return NULL;
 759 }
 760 #endif
 761
 762 /* -----------------------------------------------------------------------------
 763  * initScheduler()
 764  *
 765  * Initialise the scheduler.  This resets all the queues - if the
 766  * queues contained any threads, they'll be garbage collected at the
 767  * next pass.
 768  *
 769  * This now calls startTasks(), so should only be called once!  KH @ 25/10/99
 770  * -------------------------------------------------------------------------- */
 771
 772 #ifdef SMP
 773 static void
 774 term_handler(int sig STG_UNUSED)
 775 {
 776   stat_workerStop();
 777   ACQUIRE_LOCK(&term_mutex);
 778   await_death--;
 779   RELEASE_LOCK(&term_mutex);
 780   pthread_exit(NULL);
 781 }
 782 #endif
 783
 784 void initScheduler(void)
 785 {
 786   run_queue_hd      = END_TSO_QUEUE;
 787   run_queue_tl      = END_TSO_QUEUE;
 788   blocked_queue_hd  = END_TSO_QUEUE;
 789   blocked_queue_tl  = END_TSO_QUEUE;
 790
 791   suspended_ccalling_threads  = END_TSO_QUEUE;
 792
 793   main_threads = NULL;
 794
 795   context_switch = 0;
 796   interrupted    = 0;
 797
 798   enteredCAFs = END_CAF_LIST;
 799
 800   /* Install the SIGHUP handler */
 801 #ifdef SMP
 802   {
 803     struct sigaction action,oact;
 804
 805     action.sa_handler = term_handler;
 806     sigemptyset(&action.sa_mask);
 807     action.sa_flags = 0;
 808     if (sigaction(SIGTERM, &action, &oact) != 0) {
 809       barf("can't install TERM handler");
 810     }
 811   }
 812 #endif
 813
 814 #ifdef SMP
 815   /* Allocate N Capabilities */
 816   {
 817     nat i;
 818     Capability *cap, *prev;
 819     cap  = NULL;
 820     prev = NULL;
 821     for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 822       cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
 823       cap->link = prev;
 824       prev = cap;
 825     }
 826     free_capabilities = cap;
 827     n_free_capabilities = RtsFlags.ConcFlags.nNodes;
 828   }
 829   IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
 830                              n_free_capabilities););
 831 #endif
 832 }
 833
 834 #ifdef SMP
 835 void
 836 startTasks( void )
 837 {
 838   nat i;
 839   int r;
 840   pthread_t tid;
 841
 842   /* make some space for saving all the thread ids */
 843   task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
 844                             "initScheduler:task_ids");
 845
 846   /* and create all the threads */
 847   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 848     r = pthread_create(&tid,NULL,taskStart,NULL);
 849     if (r != 0) {
 850       barf("startTasks: Can't create new Posix thread");
 851     }
 852     task_ids[i].id = tid;
 853     task_ids[i].mut_time = 0.0;
 854     task_ids[i].mut_etime = 0.0;
 855     task_ids[i].gc_time = 0.0;
 856     task_ids[i].gc_etime = 0.0;
 857     task_ids[i].elapsedtimestart = elapsedtime();
 858     IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
 859   }
 860 }
 861 #endif
 862
 863 void
 864 exitScheduler( void )
 865 {
 866 #ifdef SMP
 867   nat i;
 868
 869   /* Don't want to use pthread_cancel, since we'd have to install
 870    * these silly exception handlers (pthread_cleanup_{push,pop}) around
 871    * all our locks.
 872    */
 873 #if 0
 874   /* Cancel all our tasks */
 875   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 876     pthread_cancel(task_ids[i].id);
 877   }
 878
 879   /* Wait for all the tasks to terminate */
 880   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 881     IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n",
 882                                task_ids[i].id));
 883     pthread_join(task_ids[i].id, NULL);
 884   }
 885 #endif
 886
 887   /* Send 'em all a SIGHUP.  That should shut 'em up.
 888    */
 889   await_death = RtsFlags.ConcFlags.nNodes;
 890   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 891     pthread_kill(task_ids[i].id,SIGTERM);
 892   }
 893   while (await_death > 0) {
 894     sched_yield();
 895   }
 896 #endif
 897 }
 898
 899 /* -----------------------------------------------------------------------------
 900    Managing the per-task allocation areas.
 901
 902    Each capability comes with an allocation area.  These are
 903    fixed-length block lists into which allocation can be done.
 904
 905    ToDo: no support for two-space collection at the moment???
 906    -------------------------------------------------------------------------- */
 907
 908 /* -----------------------------------------------------------------------------
 909  * waitThread is the external interface for running a new computataion
 910  * and waiting for the result.
 911  *
 912  * In the non-SMP case, we create a new main thread, push it on the
 913  * main-thread stack, and invoke the scheduler to run it.  The
 914  * scheduler will return when the top main thread on the stack has
 915  * completed or died, and fill in the necessary fields of the
 916  * main_thread structure.
 917  *
 918  * In the SMP case, we create a main thread as before, but we then
 919  * create a new condition variable and sleep on it.  When our new
 920  * main thread has completed, we'll be woken up and the status/result
 921  * will be in the main_thread struct.
 922  * -------------------------------------------------------------------------- */
 923
 924 SchedulerStatus
 925 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 926 {
 927   StgMainThread *m;
 928   SchedulerStatus stat;
 929
 930   ACQUIRE_LOCK(&sched_mutex);
 931
 932   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
 933
 934   m->tso = tso;
 935   m->ret = ret;
 936   m->stat = NoStatus;
 937 #ifdef SMP
 938   pthread_cond_init(&m->wakeup, NULL);
 939 #endif
 940
 941   m->link = main_threads;
 942   main_threads = m;
 943
 944   IF_DEBUG(scheduler, fprintf(stderr, "schedule: new main thread (%d)\n",
 945                               m->tso->id));
 946
 947 #ifdef SMP
 948   do {
 949     pthread_cond_wait(&m->wakeup, &sched_mutex);
 950   } while (m->stat == NoStatus);
 951 #else
 952   schedule();
 953   ASSERT(m->stat != NoStatus);
 954 #endif
 955
 956   stat = m->stat;
 957
 958 #ifdef SMP
 959   pthread_cond_destroy(&m->wakeup);
 960 #endif
 961   free(m);
 962
 963   RELEASE_LOCK(&sched_mutex);
 964   return stat;
 965 }
 966
 967 /* -----------------------------------------------------------------------------
 968    Debugging: why is a thread blocked
 969    -------------------------------------------------------------------------- */
 970
 971 #ifdef DEBUG
 972 void printThreadBlockage(StgTSO *tso)
 973 {
 974   switch (tso->why_blocked) {
 975   case BlockedOnRead:
 976     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
 977     break;
 978   case BlockedOnWrite:
 979     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
 980     break;
 981   case BlockedOnDelay:
 982     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
 983     break;
 984   case BlockedOnMVar:
 985     fprintf(stderr,"blocked on an MVar");
 986     break;
 987   case BlockedOnException:
 988     fprintf(stderr,"blocked on delivering an exception to thread %d",
 989             tso->block_info.tso->id);
 990     break;
 991   case BlockedOnBlackHole:
 992     fprintf(stderr,"blocked on a black hole");
 993     break;
 994   case NotBlocked:
 995     fprintf(stderr,"not blocked");
 996     break;
 997   }
 998 }
 999 #endif
1000
1001 /* -----------------------------------------------------------------------------
1002    Where are the roots that we know about?
1003
1004         - all the threads on the runnable queue
1005         - all the threads on the blocked queue
1006         - all the thread currently executing a _ccall_GC
1007         - all the "main threads"
1008
1009    -------------------------------------------------------------------------- */
1010
1011 /* This has to be protected either by the scheduler monitor, or by the
1012         garbage collection monitor (probably the latter).
1013         KH @ 25/10/99
1014 */
1015
1016 static void GetRoots(void)
1017 {
1018   StgMainThread *m;
1019
1020   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1021   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1022
1023   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1024   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1025
1026   for (m = main_threads; m != NULL; m = m->link) {
1027     m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1028   }
1029   suspended_ccalling_threads =
1030     (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1031 }
1032
1033 /* -----------------------------------------------------------------------------
1034    performGC
1035
1036    This is the interface to the garbage collector from Haskell land.
1037    We provide this so that external C code can allocate and garbage
1038    collect when called from Haskell via _ccall_GC.
1039
1040    It might be useful to provide an interface whereby the programmer
1041    can specify more roots (ToDo).
1042
1043    This needs to be protected by the GC condition variable above.  KH.
1044    -------------------------------------------------------------------------- */
1045
1046 void (*extra_roots)(void);
1047
1048 void
1049 performGC(void)
1050 {
1051   GarbageCollect(GetRoots);
1052 }
1053
1054 static void
1055 AllRoots(void)
1056 {
1057   GetRoots();                   /* the scheduler's roots */
1058   extra_roots();                /* the user's roots */
1059 }
1060
1061 void
1062 performGCWithRoots(void (*get_roots)(void))
1063 {
1064   extra_roots = get_roots;
1065
1066   GarbageCollect(AllRoots);
1067 }
1068
1069 /* -----------------------------------------------------------------------------
1070    Stack overflow
1071
1072    If the thread has reached its maximum stack size,
1073    then bomb out.  Otherwise relocate the TSO into a larger chunk of
1074    memory and adjust its stack size appropriately.
1075    -------------------------------------------------------------------------- */
1076
1077 static StgTSO *
1078 threadStackOverflow(StgTSO *tso)
1079 {
1080   nat new_stack_size, new_tso_size, diff, stack_words;
1081   StgPtr new_sp;
1082   StgTSO *dest;
1083
1084   if (tso->stack_size >= tso->max_stack_size) {
1085 #if 0
1086     /* If we're debugging, just print out the top of the stack */
1087     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1088                                      tso->sp+64));
1089 #endif
1090 #ifdef INTERPRETER
1091     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1092     exit(1);
1093 #else
1094     /* Send this thread the StackOverflow exception */
1095     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1096 #endif
1097     return tso;
1098   }
1099
1100   /* Try to double the current stack size.  If that takes us over the
1101    * maximum stack size for this thread, then use the maximum instead.
1102    * Finally round up so the TSO ends up as a whole number of blocks.
1103    */
1104   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1105   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1106                                        TSO_STRUCT_SIZE)/sizeof(W_);
1107   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
1108   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1109
1110   IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1111
1112   dest = (StgTSO *)allocate(new_tso_size);
1113   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1114
1115   /* copy the TSO block and the old stack into the new area */
1116   memcpy(dest,tso,TSO_STRUCT_SIZE);
1117   stack_words = tso->stack + tso->stack_size - tso->sp;
1118   new_sp = (P_)dest + new_tso_size - stack_words;
1119   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1120
1121   /* relocate the stack pointers... */
1122   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1123   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
1124   dest->sp    = new_sp;
1125   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1126   dest->stack_size = new_stack_size;
1127
1128   /* and relocate the update frame list */
1129   relocate_TSO(tso, dest);
1130
1131   /* Mark the old one as dead so we don't try to scavenge it during
1132    * garbage collection (the TSO will likely be on a mutables list in
1133    * some generation, but it'll get collected soon enough).  It's
1134    * important to set the sp and su values to just beyond the end of
1135    * the stack, so we don't attempt to scavenge any part of the dead
1136    * TSO's stack.
1137    */
1138   tso->whatNext = ThreadKilled;
1139   tso->sp = (P_)&(tso->stack[tso->stack_size]);
1140   tso->su = (StgUpdateFrame *)tso->sp;
1141   tso->why_blocked = NotBlocked;
1142   dest->mut_link = NULL;
1143
1144   IF_DEBUG(sanity,checkTSO(tso));
1145 #if 0
1146   IF_DEBUG(scheduler,printTSO(dest));
1147 #endif
1148
1149 #if 0
1150   /* This will no longer work: KH */
1151   if (tso == MainTSO) { /* hack */
1152       MainTSO = dest;
1153   }
1154 #endif
1155   return dest;
1156 }
1157
1158 /* -----------------------------------------------------------------------------
1159    Wake up a queue that was blocked on some resource.
1160    -------------------------------------------------------------------------- */
1161
1162 static StgTSO *
1163 unblockOneLocked(StgTSO *tso)
1164 {
1165   StgTSO *next;
1166
1167   ASSERT(get_itbl(tso)->type == TSO);
1168   ASSERT(tso->why_blocked != NotBlocked);
1169   tso->why_blocked = NotBlocked;
1170   next = tso->link;
1171   PUSH_ON_RUN_QUEUE(tso);
1172   THREAD_RUNNABLE();
1173 #ifdef SMP
1174   IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld",
1175                            pthread_self(), tso->id));
1176 #else
1177   IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
1178 #endif
1179   return next;
1180 }
1181
1182 inline StgTSO *
1183 unblockOne(StgTSO *tso)
1184 {
1185   ACQUIRE_LOCK(&sched_mutex);
1186   tso = unblockOneLocked(tso);
1187   RELEASE_LOCK(&sched_mutex);
1188   return tso;
1189 }
1190
1191 void
1192 awakenBlockedQueue(StgTSO *tso)
1193 {
1194   ACQUIRE_LOCK(&sched_mutex);
1195   while (tso != END_TSO_QUEUE) {
1196     tso = unblockOneLocked(tso);
1197   }
1198   RELEASE_LOCK(&sched_mutex);
1199 }
1200
1201 /* -----------------------------------------------------------------------------
1202    Interrupt execution
1203    - usually called inside a signal handler so it mustn't do anything fancy.
1204    -------------------------------------------------------------------------- */
1205
1206 void
1207 interruptStgRts(void)
1208 {
1209     interrupted    = 1;
1210     context_switch = 1;
1211 }
1212
1213 /* -----------------------------------------------------------------------------
1214    Unblock a thread
1215
1216    This is for use when we raise an exception in another thread, which
1217    may be blocked.
1218    -------------------------------------------------------------------------- */
1219
1220 static void
1221 unblockThread(StgTSO *tso)
1222 {
1223   StgTSO *t, **last;
1224
1225   ACQUIRE_LOCK(&sched_mutex);
1226   switch (tso->why_blocked) {
1227
1228   case NotBlocked:
1229     return;  /* not blocked */
1230
1231   case BlockedOnMVar:
1232     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
1233     {
1234       StgTSO *last_tso = END_TSO_QUEUE;
1235       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
1236
1237       last = &mvar->head;
1238       for (t = mvar->head; t != END_TSO_QUEUE;
1239            last = &t->link, last_tso = t, t = t->link) {
1240         if (t == tso) {
1241           *last = tso->link;
1242           if (mvar->tail == tso) {
1243             mvar->tail = last_tso;
1244           }
1245           goto done;
1246         }
1247       }
1248       barf("unblockThread (MVAR): TSO not found");
1249     }
1250
1251   case BlockedOnBlackHole:
1252     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
1253     {
1254       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
1255
1256       last = &bq->blocking_queue;
1257       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
1258            last = &t->link, t = t->link) {
1259         if (t == tso) {
1260           *last = tso->link;
1261           goto done;
1262         }
1263       }
1264       barf("unblockThread (BLACKHOLE): TSO not found");
1265     }
1266
1267   case BlockedOnException:
1268     {
1269       StgTSO *tso  = tso->block_info.tso;
1270
1271       ASSERT(get_itbl(tso)->type == TSO);
1272       ASSERT(tso->blocked_exceptions != NULL);
1273
1274       last = &tso->blocked_exceptions;
1275       for (t = tso->blocked_exceptions; t != END_TSO_QUEUE;
1276            last = &t->link, t = t->link) {
1277         ASSERT(get_itbl(t)->type == TSO);
1278         if (t == tso) {
1279           *last = tso->link;
1280           goto done;
1281         }
1282       }
1283       barf("unblockThread (Exception): TSO not found");
1284     }
1285
1286   case BlockedOnDelay:
1287   case BlockedOnRead:
1288   case BlockedOnWrite:
1289     {
1290       StgTSO *prev = NULL;
1291       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
1292            prev = t, t = t->link) {
1293         if (t == tso) {
1294           if (prev == NULL) {
1295             blocked_queue_hd = t->link;
1296             if (blocked_queue_tl == t) {
1297               blocked_queue_tl = END_TSO_QUEUE;
1298             }
1299           } else {
1300             prev->link = t->link;
1301             if (blocked_queue_tl == t) {
1302               blocked_queue_tl = prev;
1303             }
1304           }
1305           goto done;
1306         }
1307       }
1308       barf("unblockThread (I/O): TSO not found");
1309     }
1310
1311   default:
1312     barf("unblockThread");
1313   }
1314
1315  done:
1316   tso->link = END_TSO_QUEUE;
1317   tso->why_blocked = NotBlocked;
1318   tso->block_info.closure = NULL;
1319   PUSH_ON_RUN_QUEUE(tso);
1320   RELEASE_LOCK(&sched_mutex);
1321 }
1322
1323 /* -----------------------------------------------------------------------------
1324  * raiseAsync()
1325  *
1326  * The following function implements the magic for raising an
1327  * asynchronous exception in an existing thread.
1328  *
1329  * We first remove the thread from any queue on which it might be
1330  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
1331  *
1332  * We strip the stack down to the innermost CATCH_FRAME, building
1333  * thunks in the heap for all the active computations, so they can
1334  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
1335  * an application of the handler to the exception, and push it on
1336  * the top of the stack.
1337  *
1338  * How exactly do we save all the active computations?  We create an
1339  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
1340  * AP_UPDs pushes everything from the corresponding update frame
1341  * upwards onto the stack.  (Actually, it pushes everything up to the
1342  * next update frame plus a pointer to the next AP_UPD object.
1343  * Entering the next AP_UPD object pushes more onto the stack until we
1344  * reach the last AP_UPD object - at which point the stack should look
1345  * exactly as it did when we killed the TSO and we can continue
1346  * execution by entering the closure on top of the stack.
1347  *
1348  * We can also kill a thread entirely - this happens if either (a) the
1349  * exception passed to raiseAsync is NULL, or (b) there's no
1350  * CATCH_FRAME on the stack.  In either case, we strip the entire
1351  * stack and replace the thread with a zombie.
1352  *
1353  * -------------------------------------------------------------------------- */
1354
1355 void
1356 deleteThread(StgTSO *tso)
1357 {
1358   raiseAsync(tso,NULL);
1359 }
1360
1361 void
1362 raiseAsync(StgTSO *tso, StgClosure *exception)
1363 {
1364   StgUpdateFrame* su = tso->su;
1365   StgPtr          sp = tso->sp;
1366
1367   /* Thread already dead? */
1368   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
1369     return;
1370   }
1371
1372   IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
1373
1374   /* Remove it from any blocking queues */
1375   unblockThread(tso);
1376
1377   /* The stack freezing code assumes there's a closure pointer on
1378    * the top of the stack.  This isn't always the case with compiled
1379    * code, so we have to push a dummy closure on the top which just
1380    * returns to the next return address on the stack.
1381    */
1382   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
1383     *(--sp) = (W_)&dummy_ret_closure;
1384   }
1385
1386   while (1) {
1387     int words = ((P_)su - (P_)sp) - 1;
1388     nat i;
1389     StgAP_UPD * ap;
1390
1391     /* If we find a CATCH_FRAME, and we've got an exception to raise,
1392      * then build PAP(handler,exception), and leave it on top of
1393      * the stack ready to enter.
1394      */
1395     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
1396       StgCatchFrame *cf = (StgCatchFrame *)su;
1397       /* we've got an exception to raise, so let's pass it to the
1398        * handler in this frame.
1399        */
1400       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
1401       TICK_ALLOC_UPD_PAP(2,0);
1402       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
1403
1404       ap->n_args = 1;
1405       ap->fun = cf->handler;
1406       ap->payload[0] = (P_)exception;
1407
1408       /* sp currently points to the word above the CATCH_FRAME on the stack.
1409        */
1410       sp += sizeofW(StgCatchFrame);
1411       tso->su = cf->link;
1412
1413       /* Restore the blocked/unblocked state for asynchronous exceptions
1414        * at the CATCH_FRAME.
1415        *
1416        * If exceptions were unblocked at the catch, arrange that they
1417        * are unblocked again after executing the handler by pushing an
1418        * unblockAsyncExceptions_ret stack frame.
1419        */
1420       if (!cf->exceptions_blocked) {
1421         *(sp--) = (W_)&unblockAsyncExceptionszh_ret_info;
1422       }
1423
1424       /* Ensure that async exceptions are blocked when running the handler.
1425        */
1426       if (tso->blocked_exceptions == NULL) {
1427         tso->blocked_exceptions = END_TSO_QUEUE;
1428       }
1429
1430       /* Put the newly-built PAP on top of the stack, ready to execute
1431        * when the thread restarts.
1432        */
1433       sp[0] = (W_)ap;
1434       tso->sp = sp;
1435       tso->whatNext = ThreadEnterGHC;
1436       return;
1437     }
1438
1439     /* First build an AP_UPD consisting of the stack chunk above the
1440      * current update frame, with the top word on the stack as the
1441      * fun field.
1442      */
1443     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
1444
1445     ASSERT(words >= 0);
1446
1447     ap->n_args = words;
1448     ap->fun    = (StgClosure *)sp[0];
1449     sp++;
1450     for(i=0; i < (nat)words; ++i) {
1451       ap->payload[i] = (P_)*sp++;
1452     }
1453
1454     switch (get_itbl(su)->type) {
1455
1456     case UPDATE_FRAME:
1457       {
1458         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
1459         TICK_ALLOC_UP_THK(words+1,0);
1460
1461         IF_DEBUG(scheduler,
1462                  fprintf(stderr,  "schedule: Updating ");
1463                  printPtr((P_)su->updatee);
1464                  fprintf(stderr,  " with ");
1465                  printObj((StgClosure *)ap);
1466                  );
1467
1468         /* Replace the updatee with an indirection - happily
1469          * this will also wake up any threads currently
1470          * waiting on the result.
1471          */
1472         UPD_IND_NOLOCK(su->updatee,ap);  /* revert the black hole */
1473         su = su->link;
1474         sp += sizeofW(StgUpdateFrame) -1;
1475         sp[0] = (W_)ap; /* push onto stack */
1476         break;
1477       }
1478
1479     case CATCH_FRAME:
1480       {
1481         StgCatchFrame *cf = (StgCatchFrame *)su;
1482         StgClosure* o;
1483
1484         /* We want a PAP, not an AP_UPD.  Fortunately, the
1485          * layout's the same.
1486          */
1487         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1488         TICK_ALLOC_UPD_PAP(words+1,0);
1489
1490         /* now build o = FUN(catch,ap,handler) */
1491         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
1492         TICK_ALLOC_FUN(2,0);
1493         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
1494         o->payload[0] = (StgClosure *)ap;
1495         o->payload[1] = cf->handler;
1496
1497         IF_DEBUG(scheduler,
1498                  fprintf(stderr,  "schedule: Built ");
1499                  printObj((StgClosure *)o);
1500                  );
1501
1502         /* pop the old handler and put o on the stack */
1503         su = cf->link;
1504         sp += sizeofW(StgCatchFrame) - 1;
1505         sp[0] = (W_)o;
1506         break;
1507       }
1508
1509     case SEQ_FRAME:
1510       {
1511         StgSeqFrame *sf = (StgSeqFrame *)su;
1512         StgClosure* o;
1513
1514         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1515         TICK_ALLOC_UPD_PAP(words+1,0);
1516
1517         /* now build o = FUN(seq,ap) */
1518         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1519         TICK_ALLOC_SE_THK(1,0);
1520         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
1521         payloadCPtr(o,0) = (StgClosure *)ap;
1522
1523         IF_DEBUG(scheduler,
1524                  fprintf(stderr,  "schedule: Built ");
1525                  printObj((StgClosure *)o);
1526                  );
1527
1528         /* pop the old handler and put o on the stack */
1529         su = sf->link;
1530         sp += sizeofW(StgSeqFrame) - 1;
1531         sp[0] = (W_)o;
1532         break;
1533       }
1534
1535     case STOP_FRAME:
1536       /* We've stripped the entire stack, the thread is now dead. */
1537       sp += sizeofW(StgStopFrame) - 1;
1538       sp[0] = (W_)exception;    /* save the exception */
1539       tso->whatNext = ThreadKilled;
1540       tso->su = (StgUpdateFrame *)(sp+1);
1541       tso->sp = sp;
1542       return;
1543
1544     default:
1545       barf("raiseAsync");
1546     }
1547   }
1548   barf("raiseAsync");
1549 }
1550