ghc/rts/Schedule.c

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