ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.34 1999/11/18 12:10:29 sewardj 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 /* A hack for Hugs concurrency support.  Needs sanitisation (?) */
 519 void deleteAllThreads ( void )
 520 {
 521   StgTSO* t;
 522   IF_DEBUG(scheduler,belch("deleteAllThreads()"));
 523   for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 524     deleteThread(t);
 525   }
 526   for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
 527     deleteThread(t);
 528   }
 529   run_queue_hd = run_queue_tl = END_TSO_QUEUE;
 530   blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
 531 }
 532
 533
 534 /* -----------------------------------------------------------------------------
 535  * Suspending & resuming Haskell threads.
 536  *
 537  * When making a "safe" call to C (aka _ccall_GC), the task gives back
 538  * its capability before calling the C function.  This allows another
 539  * task to pick up the capability and carry on running Haskell
 540  * threads.  It also means that if the C call blocks, it won't lock
 541  * the whole system.
 542  *
 543  * The Haskell thread making the C call is put to sleep for the
 544  * duration of the call, on the susepended_ccalling_threads queue.  We
 545  * give out a token to the task, which it can use to resume the thread
 546  * on return from the C function.
 547  * -------------------------------------------------------------------------- */
 548
 549 StgInt
 550 suspendThread( Capability *cap )
 551 {
 552   nat tok;
 553
 554   ACQUIRE_LOCK(&sched_mutex);
 555
 556 #ifdef SMP
 557   IF_DEBUG(scheduler,
 558            fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n",
 559                    pthread_self(), cap->rCurrentTSO->id));
 560 #else
 561   IF_DEBUG(scheduler,
 562            fprintf(stderr, "schedule: thread %d did a _ccall_gc\n",
 563                    cap->rCurrentTSO->id));
 564 #endif
 565
 566   threadPaused(cap->rCurrentTSO);
 567   cap->rCurrentTSO->link = suspended_ccalling_threads;
 568   suspended_ccalling_threads = cap->rCurrentTSO;
 569
 570   /* Use the thread ID as the token; it should be unique */
 571   tok = cap->rCurrentTSO->id;
 572
 573 #ifdef SMP
 574   cap->link = free_capabilities;
 575   free_capabilities = cap;
 576   n_free_capabilities++;
 577 #endif
 578
 579   RELEASE_LOCK(&sched_mutex);
 580   return tok;
 581 }
 582
 583 Capability *
 584 resumeThread( StgInt tok )
 585 {
 586   StgTSO *tso, **prev;
 587   Capability *cap;
 588
 589   ACQUIRE_LOCK(&sched_mutex);
 590
 591   prev = &suspended_ccalling_threads;
 592   for (tso = suspended_ccalling_threads;
 593        tso != END_TSO_QUEUE;
 594        prev = &tso->link, tso = tso->link) {
 595     if (tso->id == (StgThreadID)tok) {
 596       *prev = tso->link;
 597       break;
 598     }
 599   }
 600   if (tso == END_TSO_QUEUE) {
 601     barf("resumeThread: thread not found");
 602   }
 603
 604 #ifdef SMP
 605   while (free_capabilities == NULL) {
 606     IF_DEBUG(scheduler,
 607              fprintf(stderr,"schedule (task %ld): waiting to resume\n",
 608                      pthread_self()));
 609     pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 610     IF_DEBUG(scheduler,fprintf(stderr,
 611                                "schedule (task %ld): resuming thread %d\n",
 612                                pthread_self(), tso->id));
 613   }
 614   cap = free_capabilities;
 615   free_capabilities = cap->link;
 616   n_free_capabilities--;
 617 #else
 618   cap = &MainRegTable;
 619 #endif
 620
 621   cap->rCurrentTSO = tso;
 622
 623   RELEASE_LOCK(&sched_mutex);
 624   return cap;
 625 }
 626
 627 /* -----------------------------------------------------------------------------
 628  * Static functions
 629  * -------------------------------------------------------------------------- */
 630 static void unblockThread(StgTSO *tso);
 631
 632 /* -----------------------------------------------------------------------------
 633  * Comparing Thread ids.
 634  *
 635  * This is used from STG land in the implementation of the
 636  * instances of Eq/Ord for ThreadIds.
 637  * -------------------------------------------------------------------------- */
 638
 639 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
 640 {
 641   StgThreadID id1 = tso1->id;
 642   StgThreadID id2 = tso2->id;
 643
 644   if (id1 < id2) return (-1);
 645   if (id1 > id2) return 1;
 646   return 0;
 647 }
 648
 649 /* -----------------------------------------------------------------------------
 650    Create a new thread.
 651
 652    The new thread starts with the given stack size.  Before the
 653    scheduler can run, however, this thread needs to have a closure
 654    (and possibly some arguments) pushed on its stack.  See
 655    pushClosure() in Schedule.h.
 656
 657    createGenThread() and createIOThread() (in SchedAPI.h) are
 658    convenient packaged versions of this function.
 659    -------------------------------------------------------------------------- */
 660
 661 StgTSO *
 662 createThread(nat stack_size)
 663 {
 664   StgTSO *tso;
 665
 666   /* catch ridiculously small stack sizes */
 667   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
 668     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
 669   }
 670
 671   tso = (StgTSO *)allocate(stack_size);
 672   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
 673
 674   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
 675   return tso;
 676 }
 677
 678 void
 679 initThread(StgTSO *tso, nat stack_size)
 680 {
 681   SET_INFO(tso,&TSO_info);
 682   tso->whatNext     = ThreadEnterGHC;
 683
 684   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
 685          protect the increment operation on next_thread_id.
 686          In future, we could use an atomic increment instead.
 687   */
 688
 689   ACQUIRE_LOCK(&sched_mutex);
 690   tso->id = next_thread_id++;
 691   RELEASE_LOCK(&sched_mutex);
 692
 693   tso->why_blocked  = NotBlocked;
 694
 695   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 696   tso->stack_size   = stack_size;
 697   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 698                               - TSO_STRUCT_SIZEW;
 699   tso->sp           = (P_)&(tso->stack) + stack_size;
 700
 701 #ifdef PROFILING
 702   tso->prof.CCCS = CCS_MAIN;
 703 #endif
 704
 705   /* put a stop frame on the stack */
 706   tso->sp -= sizeofW(StgStopFrame);
 707   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 708   tso->su = (StgUpdateFrame*)tso->sp;
 709
 710   IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words",
 711                            tso->id, tso->stack_size));
 712
 713 }
 714
 715
 716 /* -----------------------------------------------------------------------------
 717  * scheduleThread()
 718  *
 719  * scheduleThread puts a thread on the head of the runnable queue.
 720  * This will usually be done immediately after a thread is created.
 721  * The caller of scheduleThread must create the thread using e.g.
 722  * createThread and push an appropriate closure
 723  * on this thread's stack before the scheduler is invoked.
 724  * -------------------------------------------------------------------------- */
 725
 726 void
 727 scheduleThread(StgTSO *tso)
 728 {
 729   ACQUIRE_LOCK(&sched_mutex);
 730
 731   /* Put the new thread on the head of the runnable queue.  The caller
 732    * better push an appropriate closure on this thread's stack
 733    * beforehand.  In the SMP case, the thread may start running as
 734    * soon as we release the scheduler lock below.
 735    */
 736   PUSH_ON_RUN_QUEUE(tso);
 737   THREAD_RUNNABLE();
 738
 739   IF_DEBUG(scheduler,printTSO(tso));
 740   RELEASE_LOCK(&sched_mutex);
 741 }
 742
 743
 744 /* -----------------------------------------------------------------------------
 745  * startTasks()
 746  *
 747  * Start up Posix threads to run each of the scheduler tasks.
 748  * I believe the task ids are not needed in the system as defined.
 749   * KH @ 25/10/99
 750  * -------------------------------------------------------------------------- */
 751
 752 #ifdef SMP
 753 static void *
 754 taskStart( void *arg STG_UNUSED )
 755 {
 756   schedule();
 757   return NULL;
 758 }
 759 #endif
 760
 761 /* -----------------------------------------------------------------------------
 762  * initScheduler()
 763  *
 764  * Initialise the scheduler.  This resets all the queues - if the
 765  * queues contained any threads, they'll be garbage collected at the
 766  * next pass.
 767  *
 768  * This now calls startTasks(), so should only be called once!  KH @ 25/10/99
 769  * -------------------------------------------------------------------------- */
 770
 771 #ifdef SMP
 772 static void
 773 term_handler(int sig STG_UNUSED)
 774 {
 775   stat_workerStop();
 776   ACQUIRE_LOCK(&term_mutex);
 777   await_death--;
 778   RELEASE_LOCK(&term_mutex);
 779   pthread_exit(NULL);
 780 }
 781 #endif
 782
 783 void initScheduler(void)
 784 {
 785   run_queue_hd      = END_TSO_QUEUE;
 786   run_queue_tl      = END_TSO_QUEUE;
 787   blocked_queue_hd  = END_TSO_QUEUE;
 788   blocked_queue_tl  = END_TSO_QUEUE;
 789
 790   suspended_ccalling_threads  = END_TSO_QUEUE;
 791
 792   main_threads = NULL;
 793
 794   context_switch = 0;
 795   interrupted    = 0;
 796
 797   enteredCAFs = END_CAF_LIST;
 798
 799   /* Install the SIGHUP handler */
 800 #ifdef SMP
 801   {
 802     struct sigaction action,oact;
 803
 804     action.sa_handler = term_handler;
 805     sigemptyset(&action.sa_mask);
 806     action.sa_flags = 0;
 807     if (sigaction(SIGTERM, &action, &oact) != 0) {
 808       barf("can't install TERM handler");
 809     }
 810   }
 811 #endif
 812
 813 #ifdef SMP
 814   /* Allocate N Capabilities */
 815   {
 816     nat i;
 817     Capability *cap, *prev;
 818     cap  = NULL;
 819     prev = NULL;
 820     for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 821       cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
 822       cap->link = prev;
 823       prev = cap;
 824     }
 825     free_capabilities = cap;
 826     n_free_capabilities = RtsFlags.ConcFlags.nNodes;
 827   }
 828   IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
 829                              n_free_capabilities););
 830 #endif
 831 }
 832
 833 #ifdef SMP
 834 void
 835 startTasks( void )
 836 {
 837   nat i;
 838   int r;
 839   pthread_t tid;
 840
 841   /* make some space for saving all the thread ids */
 842   task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
 843                             "initScheduler:task_ids");
 844
 845   /* and create all the threads */
 846   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 847     r = pthread_create(&tid,NULL,taskStart,NULL);
 848     if (r != 0) {
 849       barf("startTasks: Can't create new Posix thread");
 850     }
 851     task_ids[i].id = tid;
 852     task_ids[i].mut_time = 0.0;
 853     task_ids[i].mut_etime = 0.0;
 854     task_ids[i].gc_time = 0.0;
 855     task_ids[i].gc_etime = 0.0;
 856     task_ids[i].elapsedtimestart = elapsedtime();
 857     IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
 858   }
 859 }
 860 #endif
 861
 862 void
 863 exitScheduler( void )
 864 {
 865 #ifdef SMP
 866   nat i;
 867
 868   /* Don't want to use pthread_cancel, since we'd have to install
 869    * these silly exception handlers (pthread_cleanup_{push,pop}) around
 870    * all our locks.
 871    */
 872 #if 0
 873   /* Cancel all our tasks */
 874   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 875     pthread_cancel(task_ids[i].id);
 876   }
 877
 878   /* Wait for all the tasks to terminate */
 879   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 880     IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n",
 881                                task_ids[i].id));
 882     pthread_join(task_ids[i].id, NULL);
 883   }
 884 #endif
 885
 886   /* Send 'em all a SIGHUP.  That should shut 'em up.
 887    */
 888   await_death = RtsFlags.ConcFlags.nNodes;
 889   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 890     pthread_kill(task_ids[i].id,SIGTERM);
 891   }
 892   while (await_death > 0) {
 893     sched_yield();
 894   }
 895 #endif
 896 }
 897
 898 /* -----------------------------------------------------------------------------
 899    Managing the per-task allocation areas.
 900
 901    Each capability comes with an allocation area.  These are
 902    fixed-length block lists into which allocation can be done.
 903
 904    ToDo: no support for two-space collection at the moment???
 905    -------------------------------------------------------------------------- */
 906
 907 /* -----------------------------------------------------------------------------
 908  * waitThread is the external interface for running a new computataion
 909  * and waiting for the result.
 910  *
 911  * In the non-SMP case, we create a new main thread, push it on the
 912  * main-thread stack, and invoke the scheduler to run it.  The
 913  * scheduler will return when the top main thread on the stack has
 914  * completed or died, and fill in the necessary fields of the
 915  * main_thread structure.
 916  *
 917  * In the SMP case, we create a main thread as before, but we then
 918  * create a new condition variable and sleep on it.  When our new
 919  * main thread has completed, we'll be woken up and the status/result
 920  * will be in the main_thread struct.
 921  * -------------------------------------------------------------------------- */
 922
 923 SchedulerStatus
 924 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 925 {
 926   StgMainThread *m;
 927   SchedulerStatus stat;
 928
 929   ACQUIRE_LOCK(&sched_mutex);
 930
 931   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
 932
 933   m->tso = tso;
 934   m->ret = ret;
 935   m->stat = NoStatus;
 936 #ifdef SMP
 937   pthread_cond_init(&m->wakeup, NULL);
 938 #endif
 939
 940   m->link = main_threads;
 941   main_threads = m;
 942
 943   IF_DEBUG(scheduler, fprintf(stderr, "schedule: new main thread (%d)\n",
 944                               m->tso->id));
 945
 946 #ifdef SMP
 947   do {
 948     pthread_cond_wait(&m->wakeup, &sched_mutex);
 949   } while (m->stat == NoStatus);
 950 #else
 951   schedule();
 952   ASSERT(m->stat != NoStatus);
 953 #endif
 954
 955   stat = m->stat;
 956
 957 #ifdef SMP
 958   pthread_cond_destroy(&m->wakeup);
 959 #endif
 960   free(m);
 961
 962   RELEASE_LOCK(&sched_mutex);
 963   return stat;
 964 }
 965
 966 /* -----------------------------------------------------------------------------
 967    Debugging: why is a thread blocked
 968    -------------------------------------------------------------------------- */
 969
 970 #ifdef DEBUG
 971 void printThreadBlockage(StgTSO *tso)
 972 {
 973   switch (tso->why_blocked) {
 974   case BlockedOnRead:
 975     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
 976     break;
 977   case BlockedOnWrite:
 978     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
 979     break;
 980   case BlockedOnDelay:
 981     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
 982     break;
 983   case BlockedOnMVar:
 984     fprintf(stderr,"blocked on an MVar");
 985     break;
 986   case BlockedOnBlackHole:
 987     fprintf(stderr,"blocked on a black hole");
 988     break;
 989   case NotBlocked:
 990     fprintf(stderr,"not blocked");
 991     break;
 992   }
 993 }
 994 #endif
 995
 996 /* -----------------------------------------------------------------------------
 997    Where are the roots that we know about?
 998
 999         - all the threads on the runnable queue
1000         - all the threads on the blocked queue
1001         - all the thread currently executing a _ccall_GC
1002         - all the "main threads"
1003
1004    -------------------------------------------------------------------------- */
1005
1006 /* This has to be protected either by the scheduler monitor, or by the
1007         garbage collection monitor (probably the latter).
1008         KH @ 25/10/99
1009 */
1010
1011 static void GetRoots(void)
1012 {
1013   StgMainThread *m;
1014
1015   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1016   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1017
1018   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1019   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1020
1021   for (m = main_threads; m != NULL; m = m->link) {
1022     m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1023   }
1024   suspended_ccalling_threads =
1025     (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1026 }
1027
1028 /* -----------------------------------------------------------------------------
1029    performGC
1030
1031    This is the interface to the garbage collector from Haskell land.
1032    We provide this so that external C code can allocate and garbage
1033    collect when called from Haskell via _ccall_GC.
1034
1035    It might be useful to provide an interface whereby the programmer
1036    can specify more roots (ToDo).
1037
1038    This needs to be protected by the GC condition variable above.  KH.
1039    -------------------------------------------------------------------------- */
1040
1041 void (*extra_roots)(void);
1042
1043 void
1044 performGC(void)
1045 {
1046   GarbageCollect(GetRoots);
1047 }
1048
1049 static void
1050 AllRoots(void)
1051 {
1052   GetRoots();                   /* the scheduler's roots */
1053   extra_roots();                /* the user's roots */
1054 }
1055
1056 void
1057 performGCWithRoots(void (*get_roots)(void))
1058 {
1059   extra_roots = get_roots;
1060
1061   GarbageCollect(AllRoots);
1062 }
1063
1064 /* -----------------------------------------------------------------------------
1065    Stack overflow
1066
1067    If the thread has reached its maximum stack size,
1068    then bomb out.  Otherwise relocate the TSO into a larger chunk of
1069    memory and adjust its stack size appropriately.
1070    -------------------------------------------------------------------------- */
1071
1072 static StgTSO *
1073 threadStackOverflow(StgTSO *tso)
1074 {
1075   nat new_stack_size, new_tso_size, diff, stack_words;
1076   StgPtr new_sp;
1077   StgTSO *dest;
1078
1079   if (tso->stack_size >= tso->max_stack_size) {
1080 #if 0
1081     /* If we're debugging, just print out the top of the stack */
1082     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1083                                      tso->sp+64));
1084 #endif
1085 #ifdef INTERPRETER
1086     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1087     exit(1);
1088 #else
1089     /* Send this thread the StackOverflow exception */
1090     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1091 #endif
1092     return tso;
1093   }
1094
1095   /* Try to double the current stack size.  If that takes us over the
1096    * maximum stack size for this thread, then use the maximum instead.
1097    * Finally round up so the TSO ends up as a whole number of blocks.
1098    */
1099   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1100   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1101                                        TSO_STRUCT_SIZE)/sizeof(W_);
1102   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
1103   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1104
1105   IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1106
1107   dest = (StgTSO *)allocate(new_tso_size);
1108   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1109
1110   /* copy the TSO block and the old stack into the new area */
1111   memcpy(dest,tso,TSO_STRUCT_SIZE);
1112   stack_words = tso->stack + tso->stack_size - tso->sp;
1113   new_sp = (P_)dest + new_tso_size - stack_words;
1114   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1115
1116   /* relocate the stack pointers... */
1117   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1118   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
1119   dest->sp    = new_sp;
1120   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1121   dest->stack_size = new_stack_size;
1122
1123   /* and relocate the update frame list */
1124   relocate_TSO(tso, dest);
1125
1126   /* Mark the old one as dead so we don't try to scavenge it during
1127    * garbage collection (the TSO will likely be on a mutables list in
1128    * some generation, but it'll get collected soon enough).  It's
1129    * important to set the sp and su values to just beyond the end of
1130    * the stack, so we don't attempt to scavenge any part of the dead
1131    * TSO's stack.
1132    */
1133   tso->whatNext = ThreadKilled;
1134   tso->sp = (P_)&(tso->stack[tso->stack_size]);
1135   tso->su = (StgUpdateFrame *)tso->sp;
1136   tso->why_blocked = NotBlocked;
1137   dest->mut_link = NULL;
1138
1139   IF_DEBUG(sanity,checkTSO(tso));
1140 #if 0
1141   IF_DEBUG(scheduler,printTSO(dest));
1142 #endif
1143
1144 #if 0
1145   /* This will no longer work: KH */
1146   if (tso == MainTSO) { /* hack */
1147       MainTSO = dest;
1148   }
1149 #endif
1150   return dest;
1151 }
1152
1153 /* -----------------------------------------------------------------------------
1154    Wake up a queue that was blocked on some resource.
1155    -------------------------------------------------------------------------- */
1156
1157 static StgTSO *
1158 unblockOneLocked(StgTSO *tso)
1159 {
1160   StgTSO *next;
1161
1162   ASSERT(get_itbl(tso)->type == TSO);
1163   ASSERT(tso->why_blocked != NotBlocked);
1164   tso->why_blocked = NotBlocked;
1165   next = tso->link;
1166   PUSH_ON_RUN_QUEUE(tso);
1167   THREAD_RUNNABLE();
1168 #ifdef SMP
1169   IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld",
1170                            pthread_self(), tso->id));
1171 #else
1172   IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
1173 #endif
1174   return next;
1175 }
1176
1177 inline StgTSO *
1178 unblockOne(StgTSO *tso)
1179 {
1180   ACQUIRE_LOCK(&sched_mutex);
1181   tso = unblockOneLocked(tso);
1182   RELEASE_LOCK(&sched_mutex);
1183   return tso;
1184 }
1185
1186 void
1187 awakenBlockedQueue(StgTSO *tso)
1188 {
1189   ACQUIRE_LOCK(&sched_mutex);
1190   while (tso != END_TSO_QUEUE) {
1191     tso = unblockOneLocked(tso);
1192   }
1193   RELEASE_LOCK(&sched_mutex);
1194 }
1195
1196 /* -----------------------------------------------------------------------------
1197    Interrupt execution
1198    - usually called inside a signal handler so it mustn't do anything fancy.
1199    -------------------------------------------------------------------------- */
1200
1201 void
1202 interruptStgRts(void)
1203 {
1204     interrupted    = 1;
1205     context_switch = 1;
1206 }
1207
1208 /* -----------------------------------------------------------------------------
1209    Unblock a thread
1210
1211    This is for use when we raise an exception in another thread, which
1212    may be blocked.
1213    -------------------------------------------------------------------------- */
1214
1215 static void
1216 unblockThread(StgTSO *tso)
1217 {
1218   StgTSO *t, **last;
1219
1220   ACQUIRE_LOCK(&sched_mutex);
1221   switch (tso->why_blocked) {
1222
1223   case NotBlocked:
1224     return;  /* not blocked */
1225
1226   case BlockedOnMVar:
1227     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
1228     {
1229       StgTSO *last_tso = END_TSO_QUEUE;
1230       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
1231
1232       last = &mvar->head;
1233       for (t = mvar->head; t != END_TSO_QUEUE;
1234            last = &t->link, last_tso = t, t = t->link) {
1235         if (t == tso) {
1236           *last = tso->link;
1237           if (mvar->tail == tso) {
1238             mvar->tail = last_tso;
1239           }
1240           goto done;
1241         }
1242       }
1243       barf("unblockThread (MVAR): TSO not found");
1244     }
1245
1246   case BlockedOnBlackHole:
1247     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
1248     {
1249       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
1250
1251       last = &bq->blocking_queue;
1252       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
1253            last = &t->link, t = t->link) {
1254         if (t == tso) {
1255           *last = tso->link;
1256           goto done;
1257         }
1258       }
1259       barf("unblockThread (BLACKHOLE): TSO not found");
1260     }
1261
1262   case BlockedOnDelay:
1263   case BlockedOnRead:
1264   case BlockedOnWrite:
1265     {
1266       StgTSO *prev = NULL;
1267       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
1268            prev = t, t = t->link) {
1269         if (t == tso) {
1270           if (prev == NULL) {
1271             blocked_queue_hd = t->link;
1272             if (blocked_queue_tl == t) {
1273               blocked_queue_tl = END_TSO_QUEUE;
1274             }
1275           } else {
1276             prev->link = t->link;
1277             if (blocked_queue_tl == t) {
1278               blocked_queue_tl = prev;
1279             }
1280           }
1281           goto done;
1282         }
1283       }
1284       barf("unblockThread (I/O): TSO not found");
1285     }
1286
1287   default:
1288     barf("unblockThread");
1289   }
1290
1291  done:
1292   tso->link = END_TSO_QUEUE;
1293   tso->why_blocked = NotBlocked;
1294   tso->block_info.closure = NULL;
1295   PUSH_ON_RUN_QUEUE(tso);
1296   RELEASE_LOCK(&sched_mutex);
1297 }
1298
1299 /* -----------------------------------------------------------------------------
1300  * raiseAsync()
1301  *
1302  * The following function implements the magic for raising an
1303  * asynchronous exception in an existing thread.
1304  *
1305  * We first remove the thread from any queue on which it might be
1306  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
1307  *
1308  * We strip the stack down to the innermost CATCH_FRAME, building
1309  * thunks in the heap for all the active computations, so they can
1310  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
1311  * an application of the handler to the exception, and push it on
1312  * the top of the stack.
1313  *
1314  * How exactly do we save all the active computations?  We create an
1315  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
1316  * AP_UPDs pushes everything from the corresponding update frame
1317  * upwards onto the stack.  (Actually, it pushes everything up to the
1318  * next update frame plus a pointer to the next AP_UPD object.
1319  * Entering the next AP_UPD object pushes more onto the stack until we
1320  * reach the last AP_UPD object - at which point the stack should look
1321  * exactly as it did when we killed the TSO and we can continue
1322  * execution by entering the closure on top of the stack.
1323  *
1324  * We can also kill a thread entirely - this happens if either (a) the
1325  * exception passed to raiseAsync is NULL, or (b) there's no
1326  * CATCH_FRAME on the stack.  In either case, we strip the entire
1327  * stack and replace the thread with a zombie.
1328  *
1329  * -------------------------------------------------------------------------- */
1330
1331 void
1332 deleteThread(StgTSO *tso)
1333 {
1334   raiseAsync(tso,NULL);
1335 }
1336
1337 void
1338 raiseAsync(StgTSO *tso, StgClosure *exception)
1339 {
1340   StgUpdateFrame* su = tso->su;
1341   StgPtr          sp = tso->sp;
1342
1343   /* Thread already dead? */
1344   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
1345     return;
1346   }
1347
1348   IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
1349
1350   /* Remove it from any blocking queues */
1351   unblockThread(tso);
1352
1353   /* The stack freezing code assumes there's a closure pointer on
1354    * the top of the stack.  This isn't always the case with compiled
1355    * code, so we have to push a dummy closure on the top which just
1356    * returns to the next return address on the stack.
1357    */
1358   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
1359     *(--sp) = (W_)&dummy_ret_closure;
1360   }
1361
1362   while (1) {
1363     int words = ((P_)su - (P_)sp) - 1;
1364     nat i;
1365     StgAP_UPD * ap;
1366
1367     /* If we find a CATCH_FRAME, and we've got an exception to raise,
1368      * then build PAP(handler,exception), and leave it on top of
1369      * the stack ready to enter.
1370      */
1371     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
1372       StgCatchFrame *cf = (StgCatchFrame *)su;
1373       /* we've got an exception to raise, so let's pass it to the
1374        * handler in this frame.
1375        */
1376       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
1377       TICK_ALLOC_UPD_PAP(2,0);
1378       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
1379
1380       ap->n_args = 1;
1381       ap->fun = cf->handler;
1382       ap->payload[0] = (P_)exception;
1383
1384       /* sp currently points to the word above the CATCH_FRAME on the
1385        * stack.  Replace the CATCH_FRAME with a pointer to the new handler
1386        * application.
1387        */
1388       sp += sizeofW(StgCatchFrame);
1389       sp[0] = (W_)ap;
1390       tso->su = cf->link;
1391       tso->sp = sp;
1392       tso->whatNext = ThreadEnterGHC;
1393       return;
1394     }
1395
1396     /* First build an AP_UPD consisting of the stack chunk above the
1397      * current update frame, with the top word on the stack as the
1398      * fun field.
1399      */
1400     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
1401
1402     ASSERT(words >= 0);
1403
1404     ap->n_args = words;
1405     ap->fun    = (StgClosure *)sp[0];
1406     sp++;
1407     for(i=0; i < (nat)words; ++i) {
1408       ap->payload[i] = (P_)*sp++;
1409     }
1410
1411     switch (get_itbl(su)->type) {
1412
1413     case UPDATE_FRAME:
1414       {
1415         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
1416         TICK_ALLOC_UP_THK(words+1,0);
1417
1418         IF_DEBUG(scheduler,
1419                  fprintf(stderr,  "schedule: Updating ");
1420                  printPtr((P_)su->updatee);
1421                  fprintf(stderr,  " with ");
1422                  printObj((StgClosure *)ap);
1423                  );
1424
1425         /* Replace the updatee with an indirection - happily
1426          * this will also wake up any threads currently
1427          * waiting on the result.
1428          */
1429         UPD_IND_NOLOCK(su->updatee,ap);  /* revert the black hole */
1430         su = su->link;
1431         sp += sizeofW(StgUpdateFrame) -1;
1432         sp[0] = (W_)ap; /* push onto stack */
1433         break;
1434       }
1435
1436     case CATCH_FRAME:
1437       {
1438         StgCatchFrame *cf = (StgCatchFrame *)su;
1439         StgClosure* o;
1440
1441         /* We want a PAP, not an AP_UPD.  Fortunately, the
1442          * layout's the same.
1443          */
1444         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1445         TICK_ALLOC_UPD_PAP(words+1,0);
1446
1447         /* now build o = FUN(catch,ap,handler) */
1448         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
1449         TICK_ALLOC_FUN(2,0);
1450         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
1451         o->payload[0] = (StgClosure *)ap;
1452         o->payload[1] = cf->handler;
1453
1454         IF_DEBUG(scheduler,
1455                  fprintf(stderr,  "schedule: Built ");
1456                  printObj((StgClosure *)o);
1457                  );
1458
1459         /* pop the old handler and put o on the stack */
1460         su = cf->link;
1461         sp += sizeofW(StgCatchFrame) - 1;
1462         sp[0] = (W_)o;
1463         break;
1464       }
1465
1466     case SEQ_FRAME:
1467       {
1468         StgSeqFrame *sf = (StgSeqFrame *)su;
1469         StgClosure* o;
1470
1471         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1472         TICK_ALLOC_UPD_PAP(words+1,0);
1473
1474         /* now build o = FUN(seq,ap) */
1475         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1476         TICK_ALLOC_SE_THK(1,0);
1477         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
1478         payloadCPtr(o,0) = (StgClosure *)ap;
1479
1480         IF_DEBUG(scheduler,
1481                  fprintf(stderr,  "schedule: Built ");
1482                  printObj((StgClosure *)o);
1483                  );
1484
1485         /* pop the old handler and put o on the stack */
1486         su = sf->link;
1487         sp += sizeofW(StgSeqFrame) - 1;
1488         sp[0] = (W_)o;
1489         break;
1490       }
1491
1492     case STOP_FRAME:
1493       /* We've stripped the entire stack, the thread is now dead. */
1494       sp += sizeofW(StgStopFrame) - 1;
1495       sp[0] = (W_)exception;    /* save the exception */
1496       tso->whatNext = ThreadKilled;
1497       tso->su = (StgUpdateFrame *)(sp+1);
1498       tso->sp = sp;
1499       return;
1500
1501     default:
1502       barf("raiseAsync");
1503     }
1504   }
1505   barf("raiseAsync");
1506 }
1507