ghc/rts/Schedule.c

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