ghc/rts/Schedule.c

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