ghc/rts/Schedule.c

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