ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.40 2000/01/13 10:37:31 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,"scheduler (task %ld): ", pthread_self()););
 446 #else
 447     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: "););
 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,"scheduler: Allocated %d capabilities\n",
 868                              n_free_capabilities););
 869 #endif
 870
 871 #if defined(SMP) || defined(PAR)
 872   initSparkPools();
 873 #endif
 874 }
 875
 876 #ifdef SMP
 877 void
 878 startTasks( void )
 879 {
 880   nat i;
 881   int r;
 882   pthread_t tid;
 883
 884   /* make some space for saving all the thread ids */
 885   task_ids = stgMallocBytes(RtsFlags.ParFlags.nNodes * sizeof(task_info),
 886                             "initScheduler:task_ids");
 887
 888   /* and create all the threads */
 889   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
 890     r = pthread_create(&tid,NULL,taskStart,NULL);
 891     if (r != 0) {
 892       barf("startTasks: Can't create new Posix thread");
 893     }
 894     task_ids[i].id = tid;
 895     task_ids[i].mut_time = 0.0;
 896     task_ids[i].mut_etime = 0.0;
 897     task_ids[i].gc_time = 0.0;
 898     task_ids[i].gc_etime = 0.0;
 899     task_ids[i].elapsedtimestart = elapsedtime();
 900     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: Started task: %ld\n",tid););
 901   }
 902 }
 903 #endif
 904
 905 void
 906 exitScheduler( void )
 907 {
 908 #ifdef SMP
 909   nat i;
 910
 911   /* Don't want to use pthread_cancel, since we'd have to install
 912    * these silly exception handlers (pthread_cleanup_{push,pop}) around
 913    * all our locks.
 914    */
 915 #if 0
 916   /* Cancel all our tasks */
 917   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
 918     pthread_cancel(task_ids[i].id);
 919   }
 920
 921   /* Wait for all the tasks to terminate */
 922   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
 923     IF_DEBUG(scheduler,fprintf(stderr,"scheduler: waiting for task %ld\n",
 924                                task_ids[i].id));
 925     pthread_join(task_ids[i].id, NULL);
 926   }
 927 #endif
 928
 929   /* Send 'em all a SIGHUP.  That should shut 'em up.
 930    */
 931   await_death = RtsFlags.ParFlags.nNodes;
 932   for (i = 0; i < RtsFlags.ParFlags.nNodes; i++) {
 933     pthread_kill(task_ids[i].id,SIGTERM);
 934   }
 935   while (await_death > 0) {
 936     sched_yield();
 937   }
 938 #endif
 939 }
 940
 941 /* -----------------------------------------------------------------------------
 942    Managing the per-task allocation areas.
 943
 944    Each capability comes with an allocation area.  These are
 945    fixed-length block lists into which allocation can be done.
 946
 947    ToDo: no support for two-space collection at the moment???
 948    -------------------------------------------------------------------------- */
 949
 950 /* -----------------------------------------------------------------------------
 951  * waitThread is the external interface for running a new computataion
 952  * and waiting for the result.
 953  *
 954  * In the non-SMP case, we create a new main thread, push it on the
 955  * main-thread stack, and invoke the scheduler to run it.  The
 956  * scheduler will return when the top main thread on the stack has
 957  * completed or died, and fill in the necessary fields of the
 958  * main_thread structure.
 959  *
 960  * In the SMP case, we create a main thread as before, but we then
 961  * create a new condition variable and sleep on it.  When our new
 962  * main thread has completed, we'll be woken up and the status/result
 963  * will be in the main_thread struct.
 964  * -------------------------------------------------------------------------- */
 965
 966 SchedulerStatus
 967 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 968 {
 969   StgMainThread *m;
 970   SchedulerStatus stat;
 971
 972   ACQUIRE_LOCK(&sched_mutex);
 973
 974   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
 975
 976   m->tso = tso;
 977   m->ret = ret;
 978   m->stat = NoStatus;
 979 #ifdef SMP
 980   pthread_cond_init(&m->wakeup, NULL);
 981 #endif
 982
 983   m->link = main_threads;
 984   main_threads = m;
 985
 986   IF_DEBUG(scheduler, fprintf(stderr, "scheduler: new main thread (%d)\n",
 987                               m->tso->id));
 988
 989 #ifdef SMP
 990   do {
 991     pthread_cond_wait(&m->wakeup, &sched_mutex);
 992   } while (m->stat == NoStatus);
 993 #else
 994   schedule();
 995   ASSERT(m->stat != NoStatus);
 996 #endif
 997
 998   stat = m->stat;
 999
1000 #ifdef SMP
1001   pthread_cond_destroy(&m->wakeup);
1002 #endif
1003
1004   IF_DEBUG(scheduler, fprintf(stderr, "scheduler: main thread (%d) finished\n",
1005                               m->tso->id));
1006   free(m);
1007
1008   RELEASE_LOCK(&sched_mutex);
1009
1010   return stat;
1011 }
1012
1013 /* -----------------------------------------------------------------------------
1014    Debugging: why is a thread blocked
1015    -------------------------------------------------------------------------- */
1016
1017 #ifdef DEBUG
1018 void printThreadBlockage(StgTSO *tso)
1019 {
1020   switch (tso->why_blocked) {
1021   case BlockedOnRead:
1022     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
1023     break;
1024   case BlockedOnWrite:
1025     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
1026     break;
1027   case BlockedOnDelay:
1028     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
1029     break;
1030   case BlockedOnMVar:
1031     fprintf(stderr,"blocked on an MVar");
1032     break;
1033   case BlockedOnException:
1034     fprintf(stderr,"blocked on delivering an exception to thread %d",
1035             tso->block_info.tso->id);
1036     break;
1037   case BlockedOnBlackHole:
1038     fprintf(stderr,"blocked on a black hole");
1039     break;
1040   case NotBlocked:
1041     fprintf(stderr,"not blocked");
1042     break;
1043   }
1044 }
1045 #endif
1046
1047 /* -----------------------------------------------------------------------------
1048    Where are the roots that we know about?
1049
1050         - all the threads on the runnable queue
1051         - all the threads on the blocked queue
1052         - all the thread currently executing a _ccall_GC
1053         - all the "main threads"
1054
1055    -------------------------------------------------------------------------- */
1056
1057 /* This has to be protected either by the scheduler monitor, or by the
1058         garbage collection monitor (probably the latter).
1059         KH @ 25/10/99
1060 */
1061
1062 static void GetRoots(void)
1063 {
1064   StgMainThread *m;
1065
1066   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1067   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1068
1069   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1070   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1071
1072   for (m = main_threads; m != NULL; m = m->link) {
1073     m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1074   }
1075   suspended_ccalling_threads =
1076     (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1077
1078 #if defined(SMP) || defined(PAR) || defined(GRAN)
1079   markSparkQueue();
1080 #endif
1081 }
1082
1083 /* -----------------------------------------------------------------------------
1084    performGC
1085
1086    This is the interface to the garbage collector from Haskell land.
1087    We provide this so that external C code can allocate and garbage
1088    collect when called from Haskell via _ccall_GC.
1089
1090    It might be useful to provide an interface whereby the programmer
1091    can specify more roots (ToDo).
1092
1093    This needs to be protected by the GC condition variable above.  KH.
1094    -------------------------------------------------------------------------- */
1095
1096 void (*extra_roots)(void);
1097
1098 void
1099 performGC(void)
1100 {
1101   GarbageCollect(GetRoots);
1102 }
1103
1104 static void
1105 AllRoots(void)
1106 {
1107   GetRoots();                   /* the scheduler's roots */
1108   extra_roots();                /* the user's roots */
1109 }
1110
1111 void
1112 performGCWithRoots(void (*get_roots)(void))
1113 {
1114   extra_roots = get_roots;
1115
1116   GarbageCollect(AllRoots);
1117 }
1118
1119 /* -----------------------------------------------------------------------------
1120    Stack overflow
1121
1122    If the thread has reached its maximum stack size,
1123    then bomb out.  Otherwise relocate the TSO into a larger chunk of
1124    memory and adjust its stack size appropriately.
1125    -------------------------------------------------------------------------- */
1126
1127 static StgTSO *
1128 threadStackOverflow(StgTSO *tso)
1129 {
1130   nat new_stack_size, new_tso_size, diff, stack_words;
1131   StgPtr new_sp;
1132   StgTSO *dest;
1133
1134   if (tso->stack_size >= tso->max_stack_size) {
1135 #if 0
1136     /* If we're debugging, just print out the top of the stack */
1137     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1138                                      tso->sp+64));
1139 #endif
1140 #ifdef INTERPRETER
1141     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1142     exit(1);
1143 #else
1144     /* Send this thread the StackOverflow exception */
1145     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1146 #endif
1147     return tso;
1148   }
1149
1150   /* Try to double the current stack size.  If that takes us over the
1151    * maximum stack size for this thread, then use the maximum instead.
1152    * Finally round up so the TSO ends up as a whole number of blocks.
1153    */
1154   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1155   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1156                                        TSO_STRUCT_SIZE)/sizeof(W_);
1157   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
1158   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1159
1160   IF_DEBUG(scheduler, fprintf(stderr,"scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1161
1162   dest = (StgTSO *)allocate(new_tso_size);
1163   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1164
1165   /* copy the TSO block and the old stack into the new area */
1166   memcpy(dest,tso,TSO_STRUCT_SIZE);
1167   stack_words = tso->stack + tso->stack_size - tso->sp;
1168   new_sp = (P_)dest + new_tso_size - stack_words;
1169   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1170
1171   /* relocate the stack pointers... */
1172   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1173   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
1174   dest->sp    = new_sp;
1175   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1176   dest->stack_size = new_stack_size;
1177
1178   /* and relocate the update frame list */
1179   relocate_TSO(tso, dest);
1180
1181   /* Mark the old one as dead so we don't try to scavenge it during
1182    * garbage collection (the TSO will likely be on a mutables list in
1183    * some generation, but it'll get collected soon enough).  It's
1184    * important to set the sp and su values to just beyond the end of
1185    * the stack, so we don't attempt to scavenge any part of the dead
1186    * TSO's stack.
1187    */
1188   tso->whatNext = ThreadKilled;
1189   tso->sp = (P_)&(tso->stack[tso->stack_size]);
1190   tso->su = (StgUpdateFrame *)tso->sp;
1191   tso->why_blocked = NotBlocked;
1192   dest->mut_link = NULL;
1193
1194   IF_DEBUG(sanity,checkTSO(tso));
1195 #if 0
1196   IF_DEBUG(scheduler,printTSO(dest));
1197 #endif
1198
1199 #if 0
1200   /* This will no longer work: KH */
1201   if (tso == MainTSO) { /* hack */
1202       MainTSO = dest;
1203   }
1204 #endif
1205   return dest;
1206 }
1207
1208 /* -----------------------------------------------------------------------------
1209    Wake up a queue that was blocked on some resource.
1210    -------------------------------------------------------------------------- */
1211
1212 static StgTSO *
1213 unblockOneLocked(StgTSO *tso)
1214 {
1215   StgTSO *next;
1216
1217   ASSERT(get_itbl(tso)->type == TSO);
1218   ASSERT(tso->why_blocked != NotBlocked);
1219   tso->why_blocked = NotBlocked;
1220   next = tso->link;
1221   PUSH_ON_RUN_QUEUE(tso);
1222   THREAD_RUNNABLE();
1223   IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
1224   return next;
1225 }
1226
1227 inline StgTSO *
1228 unblockOne(StgTSO *tso)
1229 {
1230   ACQUIRE_LOCK(&sched_mutex);
1231   tso = unblockOneLocked(tso);
1232   RELEASE_LOCK(&sched_mutex);
1233   return tso;
1234 }
1235
1236 void
1237 awakenBlockedQueue(StgTSO *tso)
1238 {
1239   ACQUIRE_LOCK(&sched_mutex);
1240   while (tso != END_TSO_QUEUE) {
1241     tso = unblockOneLocked(tso);
1242   }
1243   RELEASE_LOCK(&sched_mutex);
1244 }
1245
1246 /* -----------------------------------------------------------------------------
1247    Interrupt execution
1248    - usually called inside a signal handler so it mustn't do anything fancy.
1249    -------------------------------------------------------------------------- */
1250
1251 void
1252 interruptStgRts(void)
1253 {
1254     interrupted    = 1;
1255     context_switch = 1;
1256 }
1257
1258 /* -----------------------------------------------------------------------------
1259    Unblock a thread
1260
1261    This is for use when we raise an exception in another thread, which
1262    may be blocked.
1263    -------------------------------------------------------------------------- */
1264
1265 static void
1266 unblockThread(StgTSO *tso)
1267 {
1268   StgTSO *t, **last;
1269
1270   ACQUIRE_LOCK(&sched_mutex);
1271   switch (tso->why_blocked) {
1272
1273   case NotBlocked:
1274     return;  /* not blocked */
1275
1276   case BlockedOnMVar:
1277     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
1278     {
1279       StgTSO *last_tso = END_TSO_QUEUE;
1280       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
1281
1282       last = &mvar->head;
1283       for (t = mvar->head; t != END_TSO_QUEUE;
1284            last = &t->link, last_tso = t, t = t->link) {
1285         if (t == tso) {
1286           *last = tso->link;
1287           if (mvar->tail == tso) {
1288             mvar->tail = last_tso;
1289           }
1290           goto done;
1291         }
1292       }
1293       barf("unblockThread (MVAR): TSO not found");
1294     }
1295
1296   case BlockedOnBlackHole:
1297     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
1298     {
1299       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
1300
1301       last = &bq->blocking_queue;
1302       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
1303            last = &t->link, t = t->link) {
1304         if (t == tso) {
1305           *last = tso->link;
1306           goto done;
1307         }
1308       }
1309       barf("unblockThread (BLACKHOLE): TSO not found");
1310     }
1311
1312   case BlockedOnException:
1313     {
1314       StgTSO *target  = tso->block_info.tso;
1315
1316       ASSERT(get_itbl(target)->type == TSO);
1317       ASSERT(target->blocked_exceptions != NULL);
1318
1319       last = &target->blocked_exceptions;
1320       for (t = target->blocked_exceptions; t != END_TSO_QUEUE;
1321            last = &t->link, t = t->link) {
1322         ASSERT(get_itbl(t)->type == TSO);
1323         if (t == tso) {
1324           *last = tso->link;
1325           goto done;
1326         }
1327       }
1328       barf("unblockThread (Exception): TSO not found");
1329     }
1330
1331   case BlockedOnDelay:
1332   case BlockedOnRead:
1333   case BlockedOnWrite:
1334     {
1335       StgTSO *prev = NULL;
1336       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
1337            prev = t, t = t->link) {
1338         if (t == tso) {
1339           if (prev == NULL) {
1340             blocked_queue_hd = t->link;
1341             if (blocked_queue_tl == t) {
1342               blocked_queue_tl = END_TSO_QUEUE;
1343             }
1344           } else {
1345             prev->link = t->link;
1346             if (blocked_queue_tl == t) {
1347               blocked_queue_tl = prev;
1348             }
1349           }
1350           goto done;
1351         }
1352       }
1353       barf("unblockThread (I/O): TSO not found");
1354     }
1355
1356   default:
1357     barf("unblockThread");
1358   }
1359
1360  done:
1361   tso->link = END_TSO_QUEUE;
1362   tso->why_blocked = NotBlocked;
1363   tso->block_info.closure = NULL;
1364   PUSH_ON_RUN_QUEUE(tso);
1365   RELEASE_LOCK(&sched_mutex);
1366 }
1367
1368 /* -----------------------------------------------------------------------------
1369  * raiseAsync()
1370  *
1371  * The following function implements the magic for raising an
1372  * asynchronous exception in an existing thread.
1373  *
1374  * We first remove the thread from any queue on which it might be
1375  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
1376  *
1377  * We strip the stack down to the innermost CATCH_FRAME, building
1378  * thunks in the heap for all the active computations, so they can
1379  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
1380  * an application of the handler to the exception, and push it on
1381  * the top of the stack.
1382  *
1383  * How exactly do we save all the active computations?  We create an
1384  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
1385  * AP_UPDs pushes everything from the corresponding update frame
1386  * upwards onto the stack.  (Actually, it pushes everything up to the
1387  * next update frame plus a pointer to the next AP_UPD object.
1388  * Entering the next AP_UPD object pushes more onto the stack until we
1389  * reach the last AP_UPD object - at which point the stack should look
1390  * exactly as it did when we killed the TSO and we can continue
1391  * execution by entering the closure on top of the stack.
1392  *
1393  * We can also kill a thread entirely - this happens if either (a) the
1394  * exception passed to raiseAsync is NULL, or (b) there's no
1395  * CATCH_FRAME on the stack.  In either case, we strip the entire
1396  * stack and replace the thread with a zombie.
1397  *
1398  * -------------------------------------------------------------------------- */
1399
1400 void
1401 deleteThread(StgTSO *tso)
1402 {
1403   raiseAsync(tso,NULL);
1404 }
1405
1406 void
1407 raiseAsync(StgTSO *tso, StgClosure *exception)
1408 {
1409   StgUpdateFrame* su = tso->su;
1410   StgPtr          sp = tso->sp;
1411
1412   /* Thread already dead? */
1413   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
1414     return;
1415   }
1416
1417   IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id));
1418
1419   /* Remove it from any blocking queues */
1420   unblockThread(tso);
1421
1422   /* The stack freezing code assumes there's a closure pointer on
1423    * the top of the stack.  This isn't always the case with compiled
1424    * code, so we have to push a dummy closure on the top which just
1425    * returns to the next return address on the stack.
1426    */
1427   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
1428     *(--sp) = (W_)&dummy_ret_closure;
1429   }
1430
1431   while (1) {
1432     int words = ((P_)su - (P_)sp) - 1;
1433     nat i;
1434     StgAP_UPD * ap;
1435
1436     /* If we find a CATCH_FRAME, and we've got an exception to raise,
1437      * then build PAP(handler,exception), and leave it on top of
1438      * the stack ready to enter.
1439      */
1440     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
1441       StgCatchFrame *cf = (StgCatchFrame *)su;
1442       /* we've got an exception to raise, so let's pass it to the
1443        * handler in this frame.
1444        */
1445       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
1446       TICK_ALLOC_UPD_PAP(2,0);
1447       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
1448
1449       ap->n_args = 1;
1450       ap->fun = cf->handler;
1451       ap->payload[0] = (P_)exception;
1452
1453       /* sp currently points to the word above the CATCH_FRAME on the stack.
1454        */
1455       sp += sizeofW(StgCatchFrame);
1456       tso->su = cf->link;
1457
1458       /* Restore the blocked/unblocked state for asynchronous exceptions
1459        * at the CATCH_FRAME.
1460        *
1461        * If exceptions were unblocked at the catch, arrange that they
1462        * are unblocked again after executing the handler by pushing an
1463        * unblockAsyncExceptions_ret stack frame.
1464        */
1465       if (!cf->exceptions_blocked) {
1466         *(sp--) = (W_)&unblockAsyncExceptionszh_ret_info;
1467       }
1468
1469       /* Ensure that async exceptions are blocked when running the handler.
1470        */
1471       if (tso->blocked_exceptions == NULL) {
1472         tso->blocked_exceptions = END_TSO_QUEUE;
1473       }
1474
1475       /* Put the newly-built PAP on top of the stack, ready to execute
1476        * when the thread restarts.
1477        */
1478       sp[0] = (W_)ap;
1479       tso->sp = sp;
1480       tso->whatNext = ThreadEnterGHC;
1481       return;
1482     }
1483
1484     /* First build an AP_UPD consisting of the stack chunk above the
1485      * current update frame, with the top word on the stack as the
1486      * fun field.
1487      */
1488     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
1489
1490     ASSERT(words >= 0);
1491
1492     ap->n_args = words;
1493     ap->fun    = (StgClosure *)sp[0];
1494     sp++;
1495     for(i=0; i < (nat)words; ++i) {
1496       ap->payload[i] = (P_)*sp++;
1497     }
1498
1499     switch (get_itbl(su)->type) {
1500
1501     case UPDATE_FRAME:
1502       {
1503         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
1504         TICK_ALLOC_UP_THK(words+1,0);
1505
1506         IF_DEBUG(scheduler,
1507                  fprintf(stderr,  "scheduler: Updating ");
1508                  printPtr((P_)su->updatee);
1509                  fprintf(stderr,  " with ");
1510                  printObj((StgClosure *)ap);
1511                  );
1512
1513         /* Replace the updatee with an indirection - happily
1514          * this will also wake up any threads currently
1515          * waiting on the result.
1516          */
1517         UPD_IND_NOLOCK(su->updatee,ap);  /* revert the black hole */
1518         su = su->link;
1519         sp += sizeofW(StgUpdateFrame) -1;
1520         sp[0] = (W_)ap; /* push onto stack */
1521         break;
1522       }
1523
1524     case CATCH_FRAME:
1525       {
1526         StgCatchFrame *cf = (StgCatchFrame *)su;
1527         StgClosure* o;
1528
1529         /* We want a PAP, not an AP_UPD.  Fortunately, the
1530          * layout's the same.
1531          */
1532         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1533         TICK_ALLOC_UPD_PAP(words+1,0);
1534
1535         /* now build o = FUN(catch,ap,handler) */
1536         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
1537         TICK_ALLOC_FUN(2,0);
1538         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
1539         o->payload[0] = (StgClosure *)ap;
1540         o->payload[1] = cf->handler;
1541
1542         IF_DEBUG(scheduler,
1543                  fprintf(stderr,  "scheduler: Built ");
1544                  printObj((StgClosure *)o);
1545                  );
1546
1547         /* pop the old handler and put o on the stack */
1548         su = cf->link;
1549         sp += sizeofW(StgCatchFrame) - 1;
1550         sp[0] = (W_)o;
1551         break;
1552       }
1553
1554     case SEQ_FRAME:
1555       {
1556         StgSeqFrame *sf = (StgSeqFrame *)su;
1557         StgClosure* o;
1558
1559         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1560         TICK_ALLOC_UPD_PAP(words+1,0);
1561
1562         /* now build o = FUN(seq,ap) */
1563         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1564         TICK_ALLOC_SE_THK(1,0);
1565         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
1566         payloadCPtr(o,0) = (StgClosure *)ap;
1567
1568         IF_DEBUG(scheduler,
1569                  fprintf(stderr,  "scheduler: Built ");
1570                  printObj((StgClosure *)o);
1571                  );
1572
1573         /* pop the old handler and put o on the stack */
1574         su = sf->link;
1575         sp += sizeofW(StgSeqFrame) - 1;
1576         sp[0] = (W_)o;
1577         break;
1578       }
1579
1580     case STOP_FRAME:
1581       /* We've stripped the entire stack, the thread is now dead. */
1582       sp += sizeofW(StgStopFrame) - 1;
1583       sp[0] = (W_)exception;    /* save the exception */
1584       tso->whatNext = ThreadKilled;
1585       tso->su = (StgUpdateFrame *)(sp+1);
1586       tso->sp = sp;
1587       return;
1588
1589     default:
1590       barf("raiseAsync");
1591     }
1592   }
1593   barf("raiseAsync");
1594 }
1595
1596 /* -----------------------------------------------------------------------------
1597    Debuggery...
1598    -------------------------------------------------------------------------- */
1599
1600 #ifdef DEBUG
1601 static void
1602 sched_belch(char *s, ...)
1603 {
1604   va_list ap;
1605   va_start(ap,s);
1606 #ifdef SMP
1607   fprintf(stderr, "scheduler (task %ld): ", pthread_self());
1608 #else
1609   fprintf(stderr, "scheduler: ");
1610 #endif
1611   vfprintf(stderr, s, ap);
1612   fprintf(stderr, "\n");
1613 }
1614 #endif