ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.19 1999/03/20 17:33:07 sof 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 #if 0
 519     /* If we're debugging, just print out the top of the stack */
 520     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
 521                                      tso->sp+64));
 522 #endif
 523     /* Send this thread the StackOverflow exception */
 524     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
 525     return tso;
 526   }
 527
 528   /* Try to double the current stack size.  If that takes us over the
 529    * maximum stack size for this thread, then use the maximum instead.
 530    * Finally round up so the TSO ends up as a whole number of blocks.
 531    */
 532   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
 533   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
 534                                        TSO_STRUCT_SIZE)/sizeof(W_);
 535   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
 536   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
 537
 538   IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
 539
 540   dest = (StgTSO *)allocate(new_tso_size);
 541   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
 542
 543   /* copy the TSO block and the old stack into the new area */
 544   memcpy(dest,tso,TSO_STRUCT_SIZE);
 545   stack_words = tso->stack + tso->stack_size - tso->sp;
 546   new_sp = (P_)dest + new_tso_size - stack_words;
 547   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
 548
 549   /* relocate the stack pointers... */
 550   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
 551   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
 552   dest->sp    = new_sp;
 553   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
 554   dest->stack_size = new_stack_size;
 555
 556   /* and relocate the update frame list */
 557   relocate_TSO(tso, dest);
 558
 559   /* Mark the old one as dead so we don't try to scavenge it during
 560    * garbage collection (the TSO will likely be on a mutables list in
 561    * some generation, but it'll get collected soon enough).  It's
 562    * important to set the sp and su values to just beyond the end of
 563    * the stack, so we don't attempt to scavenge any part of the dead
 564    * TSO's stack.
 565    */
 566   tso->whatNext = ThreadKilled;
 567   tso->sp = (P_)&(tso->stack[tso->stack_size]);
 568   tso->su = (StgUpdateFrame *)tso->sp;
 569   tso->blocked_on = NULL;
 570   dest->mut_link = NULL;
 571
 572   IF_DEBUG(sanity,checkTSO(tso));
 573 #if 0
 574   IF_DEBUG(scheduler,printTSO(dest));
 575 #endif
 576   if (tso == MainTSO) { /* hack */
 577       MainTSO = dest;
 578   }
 579   return dest;
 580 }
 581
 582 /* -----------------------------------------------------------------------------
 583    Wake up a queue that was blocked on some resource (usually a
 584    computation in progress).
 585    -------------------------------------------------------------------------- */
 586
 587 void awaken_blocked_queue(StgTSO *q)
 588 {
 589   StgTSO *tso;
 590
 591   while (q != END_TSO_QUEUE) {
 592     ASSERT(get_itbl(q)->type == TSO);
 593     tso = q;
 594     q = tso->link;
 595     PUSH_ON_RUN_QUEUE(tso);
 596     tso->blocked_on = NULL;
 597     IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
 598   }
 599 }
 600
 601 /* -----------------------------------------------------------------------------
 602    Interrupt execution
 603    - usually called inside a signal handler so it mustn't do anything fancy.
 604    -------------------------------------------------------------------------- */
 605
 606 void
 607 interruptStgRts(void)
 608 {
 609     interrupted    = 1;
 610     context_switch = 1;
 611 }
 612
 613 /* -----------------------------------------------------------------------------
 614    Unblock a thread
 615
 616    This is for use when we raise an exception in another thread, which
 617    may be blocked.
 618    -------------------------------------------------------------------------- */
 619
 620 static void
 621 unblockThread(StgTSO *tso)
 622 {
 623   StgTSO *t, **last;
 624
 625   if (tso->blocked_on == NULL) {
 626     return;  /* not blocked */
 627   }
 628
 629   switch (get_itbl(tso->blocked_on)->type) {
 630
 631   case MVAR:
 632     {
 633       StgTSO *last_tso = END_TSO_QUEUE;
 634       StgMVar *mvar = (StgMVar *)(tso->blocked_on);
 635
 636       last = &mvar->head;
 637       for (t = mvar->head; t != END_TSO_QUEUE;
 638            last = &t->link, last_tso = t, t = t->link) {
 639         if (t == tso) {
 640           *last = tso->link;
 641           if (mvar->tail == tso) {
 642             mvar->tail = last_tso;
 643           }
 644           goto done;
 645         }
 646       }
 647       barf("unblockThread (MVAR): TSO not found");
 648     }
 649
 650   case BLACKHOLE_BQ:
 651     {
 652       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->blocked_on);
 653
 654       last = &bq->blocking_queue;
 655       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
 656            last = &t->link, t = t->link) {
 657         if (t == tso) {
 658           *last = tso->link;
 659           goto done;
 660         }
 661       }
 662       barf("unblockThread (BLACKHOLE): TSO not found");
 663     }
 664
 665   default:
 666     barf("unblockThread");
 667   }
 668
 669  done:
 670   tso->link = END_TSO_QUEUE;
 671   tso->blocked_on = NULL;
 672   PUSH_ON_RUN_QUEUE(tso);
 673 }
 674
 675 /* -----------------------------------------------------------------------------
 676  * raiseAsync()
 677  *
 678  * The following function implements the magic for raising an
 679  * asynchronous exception in an existing thread.
 680  *
 681  * We first remove the thread from any queue on which it might be
 682  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
 683  *
 684  * We strip the stack down to the innermost CATCH_FRAME, building
 685  * thunks in the heap for all the active computations, so they can
 686  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
 687  * an application of the handler to the exception, and push it on
 688  * the top of the stack.
 689  *
 690  * How exactly do we save all the active computations?  We create an
 691  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
 692  * AP_UPDs pushes everything from the corresponding update frame
 693  * upwards onto the stack.  (Actually, it pushes everything up to the
 694  * next update frame plus a pointer to the next AP_UPD object.
 695  * Entering the next AP_UPD object pushes more onto the stack until we
 696  * reach the last AP_UPD object - at which point the stack should look
 697  * exactly as it did when we killed the TSO and we can continue
 698  * execution by entering the closure on top of the stack.
 699  *
 700  * We can also kill a thread entirely - this happens if either (a) the
 701  * exception passed to raiseAsync is NULL, or (b) there's no
 702  * CATCH_FRAME on the stack.  In either case, we strip the entire
 703  * stack and replace the thread with a zombie.
 704  *
 705  * -------------------------------------------------------------------------- */
 706
 707 void
 708 deleteThread(StgTSO *tso)
 709 {
 710   raiseAsync(tso,NULL);
 711 }
 712
 713 void
 714 raiseAsync(StgTSO *tso, StgClosure *exception)
 715 {
 716   StgUpdateFrame* su = tso->su;
 717   StgPtr          sp = tso->sp;
 718
 719   /* Thread already dead? */
 720   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
 721     return;
 722   }
 723
 724   IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
 725
 726   /* Remove it from any blocking queues */
 727   unblockThread(tso);
 728
 729   /* The stack freezing code assumes there's a closure pointer on
 730    * the top of the stack.  This isn't always the case with compiled
 731    * code, so we have to push a dummy closure on the top which just
 732    * returns to the next return address on the stack.
 733    */
 734   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
 735     *(--sp) = (W_)&dummy_ret_closure;
 736   }
 737
 738   while (1) {
 739     int words = ((P_)su - (P_)sp) - 1;
 740     nat i;
 741     StgAP_UPD * ap;
 742
 743     /* If we find a CATCH_FRAME, and we've got an exception to raise,
 744      * then build PAP(handler,exception), and leave it on top of
 745      * the stack ready to enter.
 746      */
 747     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
 748       StgCatchFrame *cf = (StgCatchFrame *)su;
 749       /* we've got an exception to raise, so let's pass it to the
 750        * handler in this frame.
 751        */
 752       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
 753       TICK_ALLOC_THK(2,0);
 754       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
 755
 756       ap->n_args = 1;
 757       ap->fun = cf->handler;
 758       ap->payload[0] = (P_)exception;
 759
 760       /* sp currently points to the word above the CATCH_FRAME on the
 761        * stack.  Replace the CATCH_FRAME with a pointer to the new handler
 762        * application.
 763        */
 764       sp += sizeofW(StgCatchFrame);
 765       sp[0] = (W_)ap;
 766       tso->su = cf->link;
 767       tso->sp = sp;
 768       tso->whatNext = ThreadEnterGHC;
 769       return;
 770     }
 771
 772     /* First build an AP_UPD consisting of the stack chunk above the
 773      * current update frame, with the top word on the stack as the
 774      * fun field.
 775      */
 776     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
 777     TICK_ALLOC_THK(words+1,0);
 778
 779     ASSERT(words >= 0);
 780
 781     ap->n_args = words;
 782     ap->fun    = (StgClosure *)sp[0];
 783     sp++;
 784     for(i=0; i < (nat)words; ++i) {
 785       ap->payload[i] = (P_)*sp++;
 786     }
 787
 788     switch (get_itbl(su)->type) {
 789
 790     case UPDATE_FRAME:
 791       {
 792         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
 793
 794         IF_DEBUG(scheduler,
 795                  fprintf(stderr,  "Updating ");
 796                  printPtr((P_)su->updatee);
 797                  fprintf(stderr,  " with ");
 798                  printObj((StgClosure *)ap);
 799                  );
 800
 801         /* Replace the updatee with an indirection - happily
 802          * this will also wake up any threads currently
 803          * waiting on the result.
 804          */
 805         UPD_IND(su->updatee,ap);  /* revert the black hole */
 806         su = su->link;
 807         sp += sizeofW(StgUpdateFrame) -1;
 808         sp[0] = (W_)ap; /* push onto stack */
 809         break;
 810       }
 811
 812     case CATCH_FRAME:
 813       {
 814         StgCatchFrame *cf = (StgCatchFrame *)su;
 815         StgClosure* o;
 816
 817         /* We want a PAP, not an AP_UPD.  Fortunately, the
 818          * layout's the same.
 819          */
 820         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 821
 822         /* now build o = FUN(catch,ap,handler) */
 823         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
 824         TICK_ALLOC_THK(2,0);
 825         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
 826         o->payload[0] = (StgClosure *)ap;
 827         o->payload[1] = cf->handler;
 828
 829         IF_DEBUG(scheduler,
 830                  fprintf(stderr,  "Built ");
 831                  printObj((StgClosure *)o);
 832                  );
 833
 834         /* pop the old handler and put o on the stack */
 835         su = cf->link;
 836         sp += sizeofW(StgCatchFrame) - 1;
 837         sp[0] = (W_)o;
 838         break;
 839       }
 840
 841     case SEQ_FRAME:
 842       {
 843         StgSeqFrame *sf = (StgSeqFrame *)su;
 844         StgClosure* o;
 845
 846         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 847
 848         /* now build o = FUN(seq,ap) */
 849         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
 850         TICK_ALLOC_THK(1,0);
 851         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
 852         payloadCPtr(o,0) = (StgClosure *)ap;
 853
 854         IF_DEBUG(scheduler,
 855                  fprintf(stderr,  "Built ");
 856                  printObj((StgClosure *)o);
 857                  );
 858
 859         /* pop the old handler and put o on the stack */
 860         su = sf->link;
 861         sp += sizeofW(StgSeqFrame) - 1;
 862         sp[0] = (W_)o;
 863         break;
 864       }
 865
 866     case STOP_FRAME:
 867       /* We've stripped the entire stack, the thread is now dead. */
 868       sp += sizeofW(StgStopFrame) - 1;
 869       sp[0] = (W_)exception;    /* save the exception */
 870       tso->whatNext = ThreadKilled;
 871       tso->su = (StgUpdateFrame *)(sp+1);
 872       tso->sp = sp;
 873       return;
 874
 875     default:
 876       barf("raiseAsync");
 877     }
 878   }
 879   barf("raiseAsync");
 880 }