ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.16 1999/03/16 13:20:16 simonm Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Scheduler
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "SchedAPI.h"
  12 #include "RtsUtils.h"
  13 #include "RtsFlags.h"
  14 #include "Storage.h"
  15 #include "StgRun.h"
  16 #include "StgStartup.h"
  17 #include "GC.h"
  18 #include "Hooks.h"
  19 #include "Schedule.h"
  20 #include "StgMiscClosures.h"
  21 #include "Storage.h"
  22 #include "Evaluator.h"
  23 #include "Printer.h"
  24 #include "Main.h"
  25 #include "Signals.h"
  26 #include "Profiling.h"
  27 #include "Sanity.h"
  28
  29 StgTSO *run_queue_hd, *run_queue_tl;
  30 StgTSO *blocked_queue_hd, *blocked_queue_tl;
  31 StgTSO *ccalling_threads;
  32
  33 #define MAX_SCHEDULE_NESTING 256
  34 nat next_main_thread;
  35 StgTSO *main_threads[MAX_SCHEDULE_NESTING];
  36
  37 static void GetRoots(void);
  38 static StgTSO *threadStackOverflow(StgTSO *tso);
  39
  40 /* flag set by signal handler to precipitate a context switch */
  41 nat context_switch;
  42 /* if this flag is set as well, give up execution */
  43 static nat interrupted;
  44
  45 /* Next thread ID to allocate */
  46 StgThreadID next_thread_id = 1;
  47
  48 /*
  49  * Pointers to the state of the current thread.
  50  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
  51  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
  52  */
  53 StgTSO      *CurrentTSO;
  54 StgRegTable  MainRegTable;
  55
  56 /*
  57  * The thread state for the main thread.
  58  */
  59 StgTSO   *MainTSO;
  60
  61 /* The smallest stack size that makes any sense is:
  62  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
  63  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
  64  *  + 1                       (the realworld token for an IO thread)
  65  *  + 1                       (the closure to enter)
  66  *
  67  * A thread with this stack will bomb immediately with a stack
  68  * overflow, which will increase its stack size.
  69  */
  70
  71 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
  72
  73 /* -----------------------------------------------------------------------------
  74  * Static functions
  75  * -------------------------------------------------------------------------- */
  76 static void unblockThread(StgTSO *tso);
  77
  78 /* -----------------------------------------------------------------------------
  79    Create a new thread.
  80
  81    The new thread starts with the given stack size.  Before the
  82    scheduler can run, however, this thread needs to have a closure
  83    (and possibly some arguments) pushed on its stack.  See
  84    pushClosure() in Schedule.h.
  85
  86    createGenThread() and createIOThread() (in SchedAPI.h) are
  87    convenient packaged versions of this function.
  88    -------------------------------------------------------------------------- */
  89
  90 StgTSO *
  91 createThread(nat stack_size)
  92 {
  93   StgTSO *tso;
  94
  95   /* catch ridiculously small stack sizes */
  96   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
  97     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
  98   }
  99
 100   tso = (StgTSO *)allocate(stack_size);
 101   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
 102
 103   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
 104   return tso;
 105 }
 106
 107 void
 108 initThread(StgTSO *tso, nat stack_size)
 109 {
 110   SET_INFO(tso,&TSO_info);
 111   tso->whatNext     = ThreadEnterGHC;
 112   tso->id           = next_thread_id++;
 113   tso->blocked_on   = NULL;
 114
 115   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 116   tso->stack_size   = stack_size;
 117   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 118                               - TSO_STRUCT_SIZEW;
 119   tso->sp           = (P_)&(tso->stack) + stack_size;
 120
 121 #ifdef PROFILING
 122   tso->prof.CCCS = CCS_MAIN;
 123 #endif
 124
 125   /* put a stop frame on the stack */
 126   tso->sp -= sizeofW(StgStopFrame);
 127   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 128   tso->su = (StgUpdateFrame*)tso->sp;
 129
 130   IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
 131                            tso->id, tso->stack_size));
 132
 133   /* Put the new thread on the head of the runnable queue.
 134    * The caller of createThread better push an appropriate closure
 135    * on this thread's stack before the scheduler is invoked.
 136    */
 137   tso->link = run_queue_hd;
 138   run_queue_hd = tso;
 139   if (run_queue_tl == END_TSO_QUEUE) {
 140     run_queue_tl = tso;
 141   }
 142
 143   IF_DEBUG(scheduler,printTSO(tso));
 144 }
 145
 146 /* -----------------------------------------------------------------------------
 147  * initScheduler()
 148  *
 149  * Initialise the scheduler.  This resets all the queues - if the
 150  * queues contained any threads, they'll be garbage collected at the
 151  * next pass.
 152  * -------------------------------------------------------------------------- */
 153
 154 void initScheduler(void)
 155 {
 156   run_queue_hd      = END_TSO_QUEUE;
 157   run_queue_tl      = END_TSO_QUEUE;
 158   blocked_queue_hd  = END_TSO_QUEUE;
 159   blocked_queue_tl  = END_TSO_QUEUE;
 160   ccalling_threads  = END_TSO_QUEUE;
 161   next_main_thread  = 0;
 162
 163   context_switch = 0;
 164   interrupted    = 0;
 165
 166   enteredCAFs = END_CAF_LIST;
 167 }
 168
 169 /* -----------------------------------------------------------------------------
 170    Main scheduling loop.
 171
 172    We use round-robin scheduling, each thread returning to the
 173    scheduler loop when one of these conditions is detected:
 174
 175       * stack overflow
 176       * out of heap space
 177       * timer expires (thread yields)
 178       * thread blocks
 179       * thread ends
 180    -------------------------------------------------------------------------- */
 181
 182 SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 183 {
 184   StgTSO *t;
 185   StgThreadReturnCode ret;
 186   StgTSO **MainTSO;
 187   rtsBool in_ccall_gc;
 188
 189   /* Return value is NULL by default, it is only filled in if the
 190    * main thread completes successfully.
 191    */
 192   if (ret_val) { *ret_val = NULL; }
 193
 194   /* Save away a pointer to the main thread so that we can keep track
 195    * of it should a garbage collection happen.  We keep a stack of
 196    * main threads in order to support scheduler re-entry.  We can't
 197    * use the normal TSO linkage for this stack, because the main TSO
 198    * may need to be linked onto other queues.
 199    */
 200   main_threads[next_main_thread] = main;
 201   MainTSO = &main_threads[next_main_thread];
 202   next_main_thread++;
 203   IF_DEBUG(scheduler,
 204            fprintf(stderr, "Scheduler entered: nesting = %d\n",
 205                    next_main_thread););
 206
 207   /* Are we being re-entered?
 208    */
 209   if (CurrentTSO != NULL) {
 210     /* This happens when a _ccall_gc from Haskell ends up re-entering
 211      * the scheduler.
 212      *
 213      * Block the current thread (put it on the ccalling_queue) and
 214      * continue executing.  The calling thread better have stashed
 215      * away its state properly and left its stack with a proper stack
 216      * frame on the top.
 217      */
 218     threadPaused(CurrentTSO);
 219     CurrentTSO->link = ccalling_threads;
 220     ccalling_threads = CurrentTSO;
 221     in_ccall_gc = rtsTrue;
 222     IF_DEBUG(scheduler,
 223              fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
 224                      CurrentTSO->id););
 225   } else {
 226     in_ccall_gc = rtsFalse;
 227   }
 228
 229   /* Take a thread from the run queue.
 230    */
 231   t = run_queue_hd;
 232   if (t != END_TSO_QUEUE) {
 233     run_queue_hd = t->link;
 234     t->link = END_TSO_QUEUE;
 235     if (run_queue_hd == END_TSO_QUEUE) {
 236       run_queue_tl = END_TSO_QUEUE;
 237     }
 238   }
 239
 240   while (t != END_TSO_QUEUE) {
 241     CurrentTSO = t;
 242
 243     /* If we have more threads on the run queue, set up a context
 244      * switch at some point in the future.
 245      */
 246     if (run_queue_hd != END_TSO_QUEUE) {
 247       context_switch = 1;
 248     } else {
 249       context_switch = 0;
 250     }
 251     IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
 252
 253     /* Be friendly to the storage manager: we're about to *run* this
 254      * thread, so we better make sure the TSO is mutable.
 255      */
 256     if (t->mut_link == NULL) {
 257       recordMutable((StgMutClosure *)t);
 258     }
 259
 260     /* Run the current thread */
 261     switch (t->whatNext) {
 262     case ThreadKilled:
 263     case ThreadComplete:
 264       /* thread already killed.  Drop it and carry on. */
 265       goto next_thread;
 266     case ThreadEnterGHC:
 267       ret = StgRun((StgFunPtr) stg_enterStackTop);
 268       break;
 269     case ThreadRunGHC:
 270       ret = StgRun((StgFunPtr) stg_returnToStackTop);
 271       break;
 272     case ThreadEnterHugs:
 273 #ifdef INTERPRETER
 274       {
 275           IF_DEBUG(scheduler,belch("entering Hugs"));
 276           LoadThreadState();
 277           /* CHECK_SENSIBLE_REGS(); */
 278           {
 279               StgClosure* c = (StgClosure *)Sp[0];
 280               Sp += 1;
 281               ret = enter(c);
 282           }
 283           SaveThreadState();
 284           break;
 285       }
 286 #else
 287       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 288 #endif
 289     default:
 290       barf("schedule: invalid whatNext field");
 291     }
 292
 293     /* We may have garbage collected while running the thread
 294      * (eg. something nefarious like _ccall_GC_ performGC), and hence
 295      * CurrentTSO may have moved.  Update t to reflect this.
 296      */
 297     t = CurrentTSO;
 298     CurrentTSO = NULL;
 299
 300     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 301 #ifdef PROFILING
 302     CCCS = CCS_SYSTEM;
 303 #endif
 304
 305     switch (ret) {
 306
 307     case HeapOverflow:
 308       IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
 309       threadPaused(t);
 310       PUSH_ON_RUN_QUEUE(t);
 311       GarbageCollect(GetRoots);
 312       break;
 313
 314     case StackOverflow:
 315       IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
 316       {
 317         nat i;
 318         /* enlarge the stack */
 319         StgTSO *new_t = threadStackOverflow(t);
 320
 321         /* This TSO has moved, so update any pointers to it from the
 322          * main thread stack.  It better not be on any other queues...
 323          * (it shouldn't be)
 324          */
 325         for (i = 0; i < next_main_thread; i++) {
 326           if (main_threads[i] == t) {
 327             main_threads[i] = new_t;
 328           }
 329         }
 330         t = new_t;
 331       }
 332       PUSH_ON_RUN_QUEUE(t);
 333       break;
 334
 335     case ThreadYielding:
 336       IF_DEBUG(scheduler,
 337                if (t->whatNext == ThreadEnterHugs) {
 338                    /* ToDo: or maybe a timer expired when we were in Hugs?
 339                     * or maybe someone hit ctrl-C
 340                     */
 341                    belch("Thread %ld stopped to switch to Hugs\n", t->id);
 342                } else {
 343                    belch("Thread %ld stopped, timer expired\n", t->id);
 344                }
 345                );
 346       threadPaused(t);
 347       if (interrupted) {
 348           IF_DEBUG(scheduler,belch("Scheduler interrupted - returning"));
 349           deleteThread(t);
 350           while (run_queue_hd != END_TSO_QUEUE) {
 351               run_queue_hd = t->link;
 352               deleteThread(t);
 353           }
 354           run_queue_tl = END_TSO_QUEUE;
 355           /* ToDo: should I do the same with blocked queues? */
 356           return Interrupted;
 357       }
 358
 359       /* Put the thread back on the run queue, at the end.
 360        * t->link is already set to END_TSO_QUEUE.
 361        */
 362       ASSERT(t->link == END_TSO_QUEUE);
 363       if (run_queue_tl == END_TSO_QUEUE) {
 364         run_queue_hd = run_queue_tl = t;
 365       } else {
 366         ASSERT(get_itbl(run_queue_tl)->type == TSO);
 367         if (run_queue_hd == run_queue_tl) {
 368           run_queue_hd->link = t;
 369           run_queue_tl = t;
 370         } else {
 371           run_queue_tl->link = t;
 372           run_queue_tl = t;
 373         }
 374       }
 375       break;
 376
 377     case ThreadBlocked:
 378       IF_DEBUG(scheduler,belch("Thread %ld stopped, blocking\n", t->id));
 379       threadPaused(t);
 380       /* assume the thread has put itself on some blocked queue
 381        * somewhere.
 382        */
 383       break;
 384
 385     case ThreadFinished:
 386       IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
 387       t->whatNext = ThreadComplete;
 388       break;
 389
 390     default:
 391       barf("schedule: invalid thread return code");
 392     }
 393
 394     /* check for signals each time around the scheduler */
 395 #ifndef __MINGW32__
 396     if (signals_pending()) {
 397       start_signal_handlers();
 398     }
 399 #endif
 400     /* If our main thread has finished or been killed, return.
 401      * If we were re-entered as a result of a _ccall_gc, then
 402      * pop the blocked thread off the ccalling_threads stack back
 403      * into CurrentTSO.
 404      */
 405     if ((*MainTSO)->whatNext == ThreadComplete
 406         || (*MainTSO)->whatNext == ThreadKilled) {
 407       next_main_thread--;
 408       if (in_ccall_gc) {
 409         CurrentTSO = ccalling_threads;
 410         ccalling_threads = ccalling_threads->link;
 411         /* remember to stub the link field of CurrentTSO */
 412         CurrentTSO->link = END_TSO_QUEUE;
 413       }
 414       if ((*MainTSO)->whatNext == ThreadComplete) {
 415         /* we finished successfully, fill in the return value */
 416         if (ret_val) { *ret_val = (StgClosure *)(*MainTSO)->sp[0]; };
 417         return Success;
 418       } else {
 419         return Killed;
 420       }
 421     }
 422
 423   next_thread:
 424     t = run_queue_hd;
 425     if (t != END_TSO_QUEUE) {
 426       run_queue_hd = t->link;
 427       t->link = END_TSO_QUEUE;
 428       if (run_queue_hd == END_TSO_QUEUE) {
 429         run_queue_tl = END_TSO_QUEUE;
 430       }
 431     }
 432   }
 433
 434   if (blocked_queue_hd != END_TSO_QUEUE) {
 435     return AllBlocked;
 436   } else {
 437     return Deadlock;
 438   }
 439 }
 440
 441 /* -----------------------------------------------------------------------------
 442    Where are the roots that we know about?
 443
 444         - all the threads on the runnable queue
 445         - all the threads on the blocked queue
 446         - all the thread currently executing a _ccall_GC
 447         - all the "main threads"
 448
 449    -------------------------------------------------------------------------- */
 450
 451 static void GetRoots(void)
 452 {
 453   nat i;
 454
 455   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
 456   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
 457
 458   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
 459   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
 460
 461   ccalling_threads  = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
 462
 463   for (i = 0; i < next_main_thread; i++) {
 464     main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
 465   }
 466 }
 467
 468 /* -----------------------------------------------------------------------------
 469    performGC
 470
 471    This is the interface to the garbage collector from Haskell land.
 472    We provide this so that external C code can allocate and garbage
 473    collect when called from Haskell via _ccall_GC.
 474
 475    It might be useful to provide an interface whereby the programmer
 476    can specify more roots (ToDo).
 477    -------------------------------------------------------------------------- */
 478
 479 void (*extra_roots)(void);
 480
 481 void
 482 performGC(void)
 483 {
 484   GarbageCollect(GetRoots);
 485 }
 486
 487 static void
 488 AllRoots(void)
 489 {
 490   GetRoots();                   /* the scheduler's roots */
 491   extra_roots();                /* the user's roots */
 492 }
 493
 494 void
 495 performGCWithRoots(void (*get_roots)(void))
 496 {
 497   extra_roots = get_roots;
 498
 499   GarbageCollect(AllRoots);
 500 }
 501
 502 /* -----------------------------------------------------------------------------
 503    Stack overflow
 504
 505    If the thread has reached its maximum stack size,
 506    then bomb out.  Otherwise relocate the TSO into a larger chunk of
 507    memory and adjust its stack size appropriately.
 508    -------------------------------------------------------------------------- */
 509
 510 static StgTSO *
 511 threadStackOverflow(StgTSO *tso)
 512 {
 513   nat new_stack_size, new_tso_size, diff, stack_words;
 514   StgPtr new_sp;
 515   StgTSO *dest;
 516
 517   if (tso->stack_size >= tso->max_stack_size) {
 518     /* ToDo: just kill this thread? */
 519 #ifdef DEBUG
 520     /* If we're debugging, just print out the top of the stack */
 521     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
 522                                      tso->sp+64));
 523 #endif
 524     stackOverflow(tso->max_stack_size);
 525   }
 526
 527   /* Try to double the current stack size.  If that takes us over the
 528    * maximum stack size for this thread, then use the maximum instead.
 529    * Finally round up so the TSO ends up as a whole number of blocks.
 530    */
 531   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
 532   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
 533                                        TSO_STRUCT_SIZE)/sizeof(W_);
 534   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
 535   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
 536
 537   IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
 538
 539   dest = (StgTSO *)allocate(new_tso_size);
 540   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
 541
 542   /* copy the TSO block and the old stack into the new area */
 543   memcpy(dest,tso,TSO_STRUCT_SIZE);
 544   stack_words = tso->stack + tso->stack_size - tso->sp;
 545   new_sp = (P_)dest + new_tso_size - stack_words;
 546   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
 547
 548   /* relocate the stack pointers... */
 549   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
 550   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
 551   dest->sp    = new_sp;
 552   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
 553   dest->stack_size = new_stack_size;
 554
 555   /* and relocate the update frame list */
 556   relocate_TSO(tso, dest);
 557
 558   /* Mark the old one as dead so we don't try to scavenge it during
 559    * garbage collection (the TSO will likely be on a mutables list in
 560    * some generation, but it'll get collected soon enough).
 561    */
 562   tso->whatNext = ThreadKilled;
 563   dest->mut_link = NULL;
 564
 565   IF_DEBUG(sanity,checkTSO(tso));
 566 #if 0
 567   IF_DEBUG(scheduler,printTSO(dest));
 568 #endif
 569   if (tso == MainTSO) { /* hack */
 570       MainTSO = dest;
 571   }
 572   return dest;
 573 }
 574
 575 /* -----------------------------------------------------------------------------
 576    Wake up a queue that was blocked on some resource (usually a
 577    computation in progress).
 578    -------------------------------------------------------------------------- */
 579
 580 void awaken_blocked_queue(StgTSO *q)
 581 {
 582   StgTSO *tso;
 583
 584   while (q != END_TSO_QUEUE) {
 585     ASSERT(get_itbl(q)->type == TSO);
 586     tso = q;
 587     q = tso->link;
 588     PUSH_ON_RUN_QUEUE(tso);
 589     tso->blocked_on = NULL;
 590     IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
 591   }
 592 }
 593
 594 /* -----------------------------------------------------------------------------
 595    Interrupt execution
 596    - usually called inside a signal handler so it mustn't do anything fancy.
 597    -------------------------------------------------------------------------- */
 598
 599 void
 600 interruptStgRts(void)
 601 {
 602     interrupted    = 1;
 603     context_switch = 1;
 604 }
 605
 606 /* -----------------------------------------------------------------------------
 607    Unblock a thread
 608
 609    This is for use when we raise an exception in another thread, which
 610    may be blocked.
 611    -------------------------------------------------------------------------- */
 612
 613 static void
 614 unblockThread(StgTSO *tso)
 615 {
 616   StgTSO *t, **last;
 617
 618   if (tso->blocked_on == NULL) {
 619     return;  /* not blocked */
 620   }
 621
 622   switch (get_itbl(tso->blocked_on)->type) {
 623
 624   case MVAR:
 625     {
 626       StgTSO *last_tso = END_TSO_QUEUE;
 627       StgMVar *mvar = (StgMVar *)(tso->blocked_on);
 628
 629       last = &mvar->head;
 630       for (t = mvar->head; t != END_TSO_QUEUE;
 631            last = &t->link, last_tso = t, t = t->link) {
 632         if (t == tso) {
 633           *last = tso->link;
 634           if (mvar->tail == tso) {
 635             mvar->tail = last_tso;
 636           }
 637           break;
 638         }
 639       }
 640     }
 641
 642   case BLACKHOLE_BQ:
 643     {
 644       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->blocked_on);
 645
 646       last = &bq->blocking_queue;
 647       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
 648            last = &t->link, t = t->link) {
 649         if (t == tso) {
 650           *last = tso->link;
 651           break;
 652         }
 653       }
 654     }
 655
 656   default:
 657     barf("unblockThread");
 658   }
 659
 660   tso->link = END_TSO_QUEUE;
 661   tso->blocked_on = NULL;
 662 }
 663
 664 /* -----------------------------------------------------------------------------
 665  * raiseAsync()
 666  *
 667  * The following function implements the magic for raising an
 668  * asynchronous exception in an existing thread.
 669  *
 670  * We first remove the thread from any queue on which it might be
 671  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
 672  *
 673  * We strip the stack down to the innermost CATCH_FRAME, building
 674  * thunks in the heap for all the active computations, so they can
 675  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
 676  * an application of the handler to the exception, and push it on
 677  * the top of the stack.
 678  *
 679  * How exactly do we save all the active computations?  We create an
 680  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
 681  * AP_UPDs pushes everything from the corresponding update frame
 682  * upwards onto the stack.  (Actually, it pushes everything up to the
 683  * next update frame plus a pointer to the next AP_UPD object.
 684  * Entering the next AP_UPD object pushes more onto the stack until we
 685  * reach the last AP_UPD object - at which point the stack should look
 686  * exactly as it did when we killed the TSO and we can continue
 687  * execution by entering the closure on top of the stack.
 688  *
 689  * We can also kill a thread entirely - this happens if either (a) the
 690  * exception passed to raiseAsync is NULL, or (b) there's no
 691  * CATCH_FRAME on the stack.  In either case, we strip the entire
 692  * stack and replace the thread with a zombie.
 693  *
 694  * -------------------------------------------------------------------------- */
 695
 696 void
 697 deleteThread(StgTSO *tso)
 698 {
 699   raiseAsync(tso,NULL);
 700 }
 701
 702 void
 703 raiseAsync(StgTSO *tso, StgClosure *exception)
 704 {
 705   StgUpdateFrame* su = tso->su;
 706   StgPtr          sp = tso->sp;
 707
 708   /* Thread already dead? */
 709   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
 710     return;
 711   }
 712
 713   IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
 714
 715   /* Remove it from any blocking queues */
 716   unblockThread(tso);
 717
 718   /* The stack freezing code assumes there's a closure pointer on
 719    * the top of the stack.  This isn't always the case with compiled
 720    * code, so we have to push a dummy closure on the top which just
 721    * returns to the next return address on the stack.
 722    */
 723   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
 724     *(--sp) = (W_)&dummy_ret_closure;
 725   }
 726
 727   while (1) {
 728     int words = ((P_)su - (P_)sp) - 1;
 729     nat i;
 730     StgAP_UPD * ap;
 731
 732     /* If we find a CATCH_FRAME, and we've got an exception to raise,
 733      * then build PAP(handler,exception), and leave it on top of
 734      * the stack ready to enter.
 735      */
 736     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
 737       StgCatchFrame *cf = (StgCatchFrame *)su;
 738       /* we've got an exception to raise, so let's pass it to the
 739        * handler in this frame.
 740        */
 741       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
 742       TICK_ALLOC_THK(2,0);
 743       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
 744
 745       ap->n_args = 1;
 746       ap->fun = cf->handler;
 747       ap->payload[0] = (P_)exception;
 748
 749       /* sp currently points to the word above the CATCH_FRAME on the
 750        * stack.  Replace the CATCH_FRAME with a pointer to the new handler
 751        * application.
 752        */
 753       sp += sizeofW(StgCatchFrame);
 754       sp[0] = (W_)ap;
 755       tso->su = cf->link;
 756       tso->sp = sp;
 757       tso->whatNext = ThreadEnterGHC;
 758       /* wake up the thread */
 759       if (tso->link == END_TSO_QUEUE) {
 760         PUSH_ON_RUN_QUEUE(tso);
 761       }
 762       return;
 763     }
 764
 765     /* First build an AP_UPD consisting of the stack chunk above the
 766      * current update frame, with the top word on the stack as the
 767      * fun field.
 768      */
 769     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
 770     TICK_ALLOC_THK(words+1,0);
 771
 772     ASSERT(words >= 0);
 773
 774     ap->n_args = words;
 775     ap->fun    = (StgClosure *)sp[0];
 776     sp++;
 777     for(i=0; i < (nat)words; ++i) {
 778       ap->payload[i] = (P_)*sp++;
 779     }
 780
 781     switch (get_itbl(su)->type) {
 782
 783     case UPDATE_FRAME:
 784       {
 785         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
 786
 787         IF_DEBUG(scheduler,
 788                  fprintf(stderr,  "Updating ");
 789                  printPtr((P_)su->updatee);
 790                  fprintf(stderr,  " with ");
 791                  printObj((StgClosure *)ap);
 792                  );
 793
 794         /* Replace the updatee with an indirection - happily
 795          * this will also wake up any threads currently
 796          * waiting on the result.
 797          */
 798         UPD_IND(su->updatee,ap);  /* revert the black hole */
 799         su = su->link;
 800         sp += sizeofW(StgUpdateFrame) -1;
 801         sp[0] = (W_)ap; /* push onto stack */
 802         break;
 803       }
 804
 805     case CATCH_FRAME:
 806       {
 807         StgCatchFrame *cf = (StgCatchFrame *)su;
 808         StgClosure* o;
 809
 810         /* We want a PAP, not an AP_UPD.  Fortunately, the
 811          * layout's the same.
 812          */
 813         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 814
 815         /* now build o = FUN(catch,ap,handler) */
 816         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
 817         TICK_ALLOC_THK(2,0);
 818         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
 819         o->payload[0] = (StgClosure *)ap;
 820         o->payload[1] = cf->handler;
 821
 822         IF_DEBUG(scheduler,
 823                  fprintf(stderr,  "Built ");
 824                  printObj((StgClosure *)o);
 825                  );
 826
 827         /* pop the old handler and put o on the stack */
 828         su = cf->link;
 829         sp += sizeofW(StgCatchFrame) - 1;
 830         sp[0] = (W_)o;
 831         break;
 832       }
 833
 834     case SEQ_FRAME:
 835       {
 836         StgSeqFrame *sf = (StgSeqFrame *)su;
 837         StgClosure* o;
 838
 839         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 840
 841         /* now build o = FUN(seq,ap) */
 842         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
 843         TICK_ALLOC_THK(1,0);
 844         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
 845         payloadCPtr(o,0) = (StgClosure *)ap;
 846
 847         IF_DEBUG(scheduler,
 848                  fprintf(stderr,  "Built ");
 849                  printObj((StgClosure *)o);
 850                  );
 851
 852         /* pop the old handler and put o on the stack */
 853         su = sf->link;
 854         sp += sizeofW(StgSeqFrame) - 1;
 855         sp[0] = (W_)o;
 856         break;
 857       }
 858
 859     case STOP_FRAME:
 860       /* We've stripped the entire stack, the thread is now dead. */
 861       sp += sizeofW(StgStopFrame) - 1;
 862       sp[0] = (W_)exception;    /* save the exception */
 863       tso->whatNext = ThreadKilled;
 864       tso->su = (StgUpdateFrame *)(sp+1);
 865       tso->sp = sp;
 866       return;
 867
 868     default:
 869       barf("raiseAsync");
 870     }
 871   }
 872   barf("raiseAsync");
 873 }