ghc/rts/Schedule.c

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