ghc/rts/Schedule.c

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