ghc/rts/Schedule.c

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