ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.10 1999/02/26 12:32:51 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    Create a new thread.
  75
  76    The new thread starts with the given stack size.  Before the
  77    scheduler can run, however, this thread needs to have a closure
  78    (and possibly some arguments) pushed on its stack.  See
  79    pushClosure() in Schedule.h.
  80
  81    createGenThread() and createIOThread() (in Schedule.h) are
  82    convenient packaged versions of this function.
  83    -------------------------------------------------------------------------- */
  84
  85 StgTSO *
  86 createThread(nat stack_size)
  87 {
  88   StgTSO *tso;
  89
  90   /* catch ridiculously small stack sizes */
  91   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
  92     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
  93   }
  94
  95   tso = (StgTSO *)allocate(stack_size);
  96   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
  97
  98   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
  99   return tso;
 100 }
 101
 102 void
 103 initThread(StgTSO *tso, nat stack_size)
 104 {
 105   SET_INFO(tso,&TSO_info);
 106   tso->whatNext     = ThreadEnterGHC;
 107   tso->state        = tso_state_runnable;
 108   tso->id           = next_thread_id++;
 109
 110   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 111   tso->stack_size   = stack_size;
 112   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 113                               - TSO_STRUCT_SIZEW;
 114   tso->sp           = (P_)&(tso->stack) + stack_size;
 115
 116 #ifdef PROFILING
 117   tso->prof.CCCS = CCS_MAIN;
 118 #endif
 119
 120   /* put a stop frame on the stack */
 121   tso->sp -= sizeofW(StgStopFrame);
 122   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 123   tso->su = (StgUpdateFrame*)tso->sp;
 124
 125   IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
 126                            tso->id, tso->stack_size));
 127
 128   /* Put the new thread on the head of the runnable queue.
 129    * The caller of createThread better push an appropriate closure
 130    * on this thread's stack before the scheduler is invoked.
 131    */
 132   tso->link = run_queue_hd;
 133   run_queue_hd = tso;
 134   if (run_queue_tl == END_TSO_QUEUE) {
 135     run_queue_tl = tso;
 136   }
 137
 138   IF_DEBUG(scheduler,printTSO(tso));
 139 }
 140
 141 /* -----------------------------------------------------------------------------
 142    Delete a thread - reverting all blackholes to (something
 143    equivalent to) their former state.
 144
 145    We create an AP_UPD for every UpdateFrame on the stack.
 146    Entering one of these AP_UPDs pushes everything from the corresponding
 147    update frame upwards onto the stack.  (Actually, it pushes everything
 148    up to the next update frame plus a pointer to the next AP_UPD
 149    object.  Entering the next AP_UPD object pushes more onto the
 150    stack until we reach the last AP_UPD object - at which point
 151    the stack should look exactly as it did when we killed the TSO
 152    and we can continue execution by entering the closure on top of
 153    the stack.
 154    -------------------------------------------------------------------------- */
 155
 156 void deleteThread(StgTSO *tso)
 157 {
 158     StgUpdateFrame* su = tso->su;
 159     StgPtr          sp = tso->sp;
 160
 161     /* Thread already dead? */
 162     if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
 163       return;
 164     }
 165
 166     IF_DEBUG(scheduler, belch("Killing thread %ld.", tso->id));
 167
 168     tso->whatNext = ThreadKilled; /* changed to ThreadComplete in schedule() */
 169     tso->link = END_TSO_QUEUE; /* Just to be on the safe side... */
 170
 171     /* Threads that finish normally leave Su pointing to the word
 172      * beyond the top of the stack, and Sp pointing to the last word
 173      * on the stack, which is the return value of the thread.
 174      */
 175     if ((P_)tso->su >= tso->stack + tso->stack_size
 176         || get_itbl(tso->su)->type == STOP_FRAME) {
 177       return;
 178     }
 179
 180     IF_DEBUG(scheduler,
 181              fprintf(stderr, "Freezing TSO stack\n");
 182              printTSO(tso);
 183              );
 184
 185     /* The stack freezing code assumes there's a closure pointer on
 186      * the top of the stack.  This isn't always the case with compiled
 187      * code, so we have to push a dummy closure on the top which just
 188      * returns to the next return address on the stack.
 189      */
 190     if (LOOKS_LIKE_GHC_INFO(*sp)) {
 191       *(--sp) = (W_)&dummy_ret_closure;
 192     }
 193
 194     while (1) {
 195       int words = (stgCast(StgPtr,su) - stgCast(StgPtr,sp)) - 1;
 196       nat i;
 197       StgAP_UPD* ap = stgCast(StgAP_UPD*,allocate(AP_sizeW(words)));
 198       TICK_ALLOC_THK(words+1,0);
 199
 200       /* First build an AP_UPD consisting of the stack chunk above the
 201        * current update frame, with the top word on the stack as the
 202        * fun field.
 203        */
 204       ASSERT(words >= 0);
 205
 206       /*      if (words == 0) {  -- optimisation
 207         ap = stgCast(StgAP_UPD*,*stgCast(StgPtr*,sp)++);
 208       } else */ {
 209         ap->n_args = words;
 210         ap->fun    = stgCast(StgClosure*,*stgCast(StgPtr*,sp)++);
 211         for(i=0; i < (nat)words; ++i) {
 212           payloadWord(ap,i) = *sp++;
 213         }
 214       }
 215
 216       switch (get_itbl(su)->type) {
 217
 218       case UPDATE_FRAME:
 219         {
 220           SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
 221
 222           IF_DEBUG(scheduler,
 223                    fprintf(stderr,  "Updating ");
 224                    printPtr(stgCast(StgPtr,su->updatee));
 225                    fprintf(stderr,  " with ");
 226                    printObj(stgCast(StgClosure*,ap));
 227                    );
 228
 229           /* Replace the updatee with an indirection - happily
 230            * this will also wake up any threads currently
 231            * waiting on the result.
 232            */
 233           UPD_IND(su->updatee,ap);  /* revert the black hole */
 234           su = su->link;
 235           sp += sizeofW(StgUpdateFrame) -1;
 236           sp[0] = stgCast(StgWord,ap); /* push onto stack */
 237           break;
 238         }
 239
 240       case CATCH_FRAME:
 241         {
 242           StgCatchFrame *cf = (StgCatchFrame *)su;
 243           StgClosure* o;
 244
 245           /* We want a PAP, not an AP_UPD.  Fortunately, the
 246            * layout's the same.
 247            */
 248           SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 249
 250           /* now build o = FUN(catch,ap,handler) */
 251           o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+2));
 252           TICK_ALLOC_THK(2,0);
 253           SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
 254           payloadCPtr(o,0) = stgCast(StgClosure*,ap);
 255           payloadCPtr(o,1) = cf->handler;
 256
 257           IF_DEBUG(scheduler,
 258                    fprintf(stderr,  "Built ");
 259                    printObj(stgCast(StgClosure*,o));
 260                    );
 261
 262           /* pop the old handler and put o on the stack */
 263           su = cf->link;
 264           sp += sizeofW(StgCatchFrame) - 1;
 265           sp[0] = (W_)o;
 266           break;
 267         }
 268
 269       case SEQ_FRAME:
 270         {
 271           StgSeqFrame *sf = (StgSeqFrame *)su;
 272           StgClosure* o;
 273
 274           SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 275
 276           /* now build o = FUN(seq,ap) */
 277           o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+1));
 278           TICK_ALLOC_THK(1,0);
 279           SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
 280           payloadCPtr(o,0) = stgCast(StgClosure*,ap);
 281
 282           IF_DEBUG(scheduler,
 283                    fprintf(stderr,  "Built ");
 284                    printObj(stgCast(StgClosure*,o));
 285                    );
 286
 287           /* pop the old handler and put o on the stack */
 288           su = sf->link;
 289           sp += sizeofW(StgSeqFrame) - 1;
 290           sp[0] = (W_)o;
 291           break;
 292         }
 293
 294       case STOP_FRAME:
 295         return;
 296
 297       default:
 298         barf("freezeTSO");
 299       }
 300     }
 301 }
 302
 303 void initScheduler(void)
 304 {
 305   run_queue_hd      = END_TSO_QUEUE;
 306   run_queue_tl      = END_TSO_QUEUE;
 307   blocked_queue_hd  = END_TSO_QUEUE;
 308   blocked_queue_tl  = END_TSO_QUEUE;
 309   ccalling_threads  = END_TSO_QUEUE;
 310   next_main_thread  = 0;
 311
 312   context_switch = 0;
 313   interrupted    = 0;
 314
 315   enteredCAFs = END_CAF_LIST;
 316 }
 317
 318 /* -----------------------------------------------------------------------------
 319    Main scheduling loop.
 320
 321    We use round-robin scheduling, each thread returning to the
 322    scheduler loop when one of these conditions is detected:
 323
 324       * stack overflow
 325       * out of heap space
 326       * timer expires (thread yields)
 327       * thread blocks
 328       * thread ends
 329    -------------------------------------------------------------------------- */
 330
 331 SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 332 {
 333   StgTSO *t;
 334   StgThreadReturnCode ret;
 335   StgTSO **MainTSO;
 336   rtsBool in_ccall_gc;
 337
 338   /* Return value is NULL by default, it is only filled in if the
 339    * main thread completes successfully.
 340    */
 341   if (ret_val) { *ret_val = NULL; }
 342
 343   /* Save away a pointer to the main thread so that we can keep track
 344    * of it should a garbage collection happen.  We keep a stack of
 345    * main threads in order to support scheduler re-entry.  We can't
 346    * use the normal TSO linkage for this stack, because the main TSO
 347    * may need to be linked onto other queues.
 348    */
 349   main_threads[next_main_thread] = main;
 350   MainTSO = &main_threads[next_main_thread];
 351   next_main_thread++;
 352   IF_DEBUG(scheduler,
 353            fprintf(stderr, "Scheduler entered: nesting = %d\n",
 354                    next_main_thread););
 355
 356   /* Are we being re-entered?
 357    */
 358   if (CurrentTSO != NULL) {
 359     /* This happens when a _ccall_gc from Haskell ends up re-entering
 360      * the scheduler.
 361      *
 362      * Block the current thread (put it on the ccalling_queue) and
 363      * continue executing.  The calling thread better have stashed
 364      * away its state properly and left its stack with a proper stack
 365      * frame on the top.
 366      */
 367     threadPaused(CurrentTSO);
 368     CurrentTSO->link = ccalling_threads;
 369     ccalling_threads = CurrentTSO;
 370     in_ccall_gc = rtsTrue;
 371     IF_DEBUG(scheduler,
 372              fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
 373                      CurrentTSO->id););
 374   } else {
 375     in_ccall_gc = rtsFalse;
 376   }
 377
 378   /* Take a thread from the run queue.
 379    */
 380   t = run_queue_hd;
 381   if (t != END_TSO_QUEUE) {
 382     run_queue_hd = t->link;
 383     t->link = END_TSO_QUEUE;
 384     if (run_queue_hd == END_TSO_QUEUE) {
 385       run_queue_tl = END_TSO_QUEUE;
 386     }
 387   }
 388
 389   while (t != END_TSO_QUEUE) {
 390     CurrentTSO = t;
 391
 392     /* If we have more threads on the run queue, set up a context
 393      * switch at some point in the future.
 394      */
 395     if (run_queue_hd != END_TSO_QUEUE) {
 396       context_switch = 1;
 397     } else {
 398       context_switch = 0;
 399     }
 400     IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
 401
 402     /* Be friendly to the storage manager: we're about to *run* this
 403      * thread, so we better make sure the TSO is mutable.
 404      */
 405     if (t->mut_link == NULL) {
 406       recordMutable((StgMutClosure *)t);
 407     }
 408
 409     /* Run the current thread */
 410     switch (t->whatNext) {
 411     case ThreadKilled:
 412     case ThreadComplete:
 413       /* thread already killed.  Drop it and carry on. */
 414       goto next_thread;
 415     case ThreadEnterGHC:
 416       ret = StgRun((StgFunPtr) stg_enterStackTop);
 417       break;
 418     case ThreadRunGHC:
 419       ret = StgRun((StgFunPtr) stg_returnToStackTop);
 420       break;
 421     case ThreadEnterHugs:
 422 #ifdef INTERPRETER
 423       {
 424           IF_DEBUG(scheduler,belch("entering Hugs"));
 425           LoadThreadState();
 426           /* CHECK_SENSIBLE_REGS(); */
 427           {
 428               StgClosure* c = stgCast(StgClosure*,*Sp);
 429               Sp += 1;
 430               ret = enter(c);
 431           }
 432           SaveThreadState();
 433           break;
 434       }
 435 #else
 436       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 437 #endif
 438     default:
 439       barf("schedule: invalid whatNext field");
 440     }
 441
 442     /* We may have garbage collected while running the thread
 443      * (eg. something nefarious like _ccall_GC_ performGC), and hence
 444      * CurrentTSO may have moved.  Update t to reflect this.
 445      */
 446     t = CurrentTSO;
 447     CurrentTSO = NULL;
 448
 449     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 450 #ifdef PROFILING
 451     CCCS = CCS_SYSTEM;
 452 #endif
 453
 454     switch (ret) {
 455
 456     case HeapOverflow:
 457       IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
 458       threadPaused(t);
 459       PUSH_ON_RUN_QUEUE(t);
 460       GarbageCollect(GetRoots);
 461       break;
 462
 463     case StackOverflow:
 464       IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
 465       {
 466         nat i;
 467         /* enlarge the stack */
 468         StgTSO *new_t = threadStackOverflow(t);
 469
 470         /* This TSO has moved, so update any pointers to it from the
 471          * main thread stack.  It better not be on any other queues...
 472          * (it shouldn't be)
 473          */
 474         for (i = 0; i < next_main_thread; i++) {
 475           if (main_threads[i] == t) {
 476             main_threads[i] = new_t;
 477           }
 478         }
 479         t = new_t;
 480       }
 481       PUSH_ON_RUN_QUEUE(t);
 482       break;
 483
 484     case ThreadYielding:
 485       IF_DEBUG(scheduler,
 486                if (t->whatNext == ThreadEnterHugs) {
 487                    /* ToDo: or maybe a timer expired when we were in Hugs?
 488                     * or maybe someone hit ctrl-C
 489                     */
 490                    belch("Thread %ld stopped to switch to Hugs\n", t->id);
 491                } else {
 492                    belch("Thread %ld stopped, timer expired\n", t->id);
 493                }
 494                );
 495       threadPaused(t);
 496       if (interrupted) {
 497           IF_DEBUG(scheduler,belch("Scheduler interrupted - returning"));
 498           deleteThread(t);
 499           while (run_queue_hd != END_TSO_QUEUE) {
 500               run_queue_hd = t->link;
 501               deleteThread(t);
 502           }
 503           run_queue_tl = END_TSO_QUEUE;
 504           /* ToDo: should I do the same with blocked queues? */
 505           return Interrupted;
 506       }
 507
 508       /* Put the thread back on the run queue, at the end.
 509        * t->link is already set to END_TSO_QUEUE.
 510        */
 511       ASSERT(t->link == END_TSO_QUEUE);
 512       if (run_queue_tl == END_TSO_QUEUE) {
 513         run_queue_hd = run_queue_tl = t;
 514       } else {
 515         ASSERT(get_itbl(run_queue_tl)->type == TSO);
 516         if (run_queue_hd == run_queue_tl) {
 517           run_queue_hd->link = t;
 518           run_queue_tl = t;
 519         } else {
 520           run_queue_tl->link = t;
 521           run_queue_tl = t;
 522         }
 523       }
 524       break;
 525
 526     case ThreadBlocked:
 527       IF_DEBUG(scheduler,belch("Thread %ld stopped, blocking\n", t->id));
 528       threadPaused(t);
 529       /* assume the thread has put itself on some blocked queue
 530        * somewhere.
 531        */
 532       break;
 533
 534     case ThreadFinished:
 535       IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
 536       deleteThread(t);
 537       t->whatNext = ThreadComplete;
 538       break;
 539
 540     default:
 541       barf("schedule: invalid thread return code");
 542     }
 543
 544     /* check for signals each time around the scheduler */
 545     if (signals_pending()) {
 546       start_signal_handlers();
 547     }
 548
 549     /* If our main thread has finished or been killed, return.
 550      * If we were re-entered as a result of a _ccall_gc, then
 551      * pop the blocked thread off the ccalling_threads stack back
 552      * into CurrentTSO.
 553      */
 554     if ((*MainTSO)->whatNext == ThreadComplete
 555         || (*MainTSO)->whatNext == ThreadKilled) {
 556       next_main_thread--;
 557       if (in_ccall_gc) {
 558         CurrentTSO = ccalling_threads;
 559         ccalling_threads = ccalling_threads->link;
 560         /* remember to stub the link field of CurrentTSO */
 561         CurrentTSO->link = END_TSO_QUEUE;
 562       }
 563       if ((*MainTSO)->whatNext == ThreadComplete) {
 564         /* we finished successfully, fill in the return value */
 565         if (ret_val) { *ret_val = (StgClosure *)(*MainTSO)->sp[0]; };
 566         return Success;
 567       } else {
 568         return Killed;
 569       }
 570     }
 571
 572   next_thread:
 573     t = run_queue_hd;
 574     if (t != END_TSO_QUEUE) {
 575       run_queue_hd = t->link;
 576       t->link = END_TSO_QUEUE;
 577       if (run_queue_hd == END_TSO_QUEUE) {
 578         run_queue_tl = END_TSO_QUEUE;
 579       }
 580     }
 581   }
 582
 583   if (blocked_queue_hd != END_TSO_QUEUE) {
 584     return AllBlocked;
 585   } else {
 586     return Deadlock;
 587   }
 588 }
 589
 590 /* -----------------------------------------------------------------------------
 591    Where are the roots that we know about?
 592
 593         - all the threads on the runnable queue
 594         - all the threads on the blocked queue
 595         - all the thread currently executing a _ccall_GC
 596         - all the "main threads"
 597
 598    -------------------------------------------------------------------------- */
 599
 600 static void GetRoots(void)
 601 {
 602   nat i;
 603
 604   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
 605   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
 606
 607   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
 608   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
 609
 610   ccalling_threads  = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
 611
 612   for (i = 0; i < next_main_thread; i++) {
 613     main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
 614   }
 615 }
 616
 617 /* -----------------------------------------------------------------------------
 618    performGC
 619
 620    This is the interface to the garbage collector from Haskell land.
 621    We provide this so that external C code can allocate and garbage
 622    collect when called from Haskell via _ccall_GC.
 623
 624    It might be useful to provide an interface whereby the programmer
 625    can specify more roots (ToDo).
 626    -------------------------------------------------------------------------- */
 627
 628 void (*extra_roots)(void);
 629
 630 void
 631 performGC(void)
 632 {
 633   GarbageCollect(GetRoots);
 634 }
 635
 636 static void
 637 AllRoots(void)
 638 {
 639   GetRoots();                   /* the scheduler's roots */
 640   extra_roots();                /* the user's roots */
 641 }
 642
 643 void
 644 performGCWithRoots(void (*get_roots)(void))
 645 {
 646   extra_roots = get_roots;
 647
 648   GarbageCollect(AllRoots);
 649 }
 650
 651 /* -----------------------------------------------------------------------------
 652    Stack overflow
 653
 654    If the thread has reached its maximum stack size,
 655    then bomb out.  Otherwise relocate the TSO into a larger chunk of
 656    memory and adjust its stack size appropriately.
 657    -------------------------------------------------------------------------- */
 658
 659 static StgTSO *
 660 threadStackOverflow(StgTSO *tso)
 661 {
 662   nat new_stack_size, new_tso_size, diff, stack_words;
 663   StgPtr new_sp;
 664   StgTSO *dest;
 665
 666   if (tso->stack_size >= tso->max_stack_size) {
 667     /* ToDo: just kill this thread? */
 668 #ifdef DEBUG
 669     /* If we're debugging, just print out the top of the stack */
 670     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
 671                                      tso->sp+64));
 672 #endif
 673     stackOverflow(tso->max_stack_size);
 674   }
 675
 676   /* Try to double the current stack size.  If that takes us over the
 677    * maximum stack size for this thread, then use the maximum instead.
 678    * Finally round up so the TSO ends up as a whole number of blocks.
 679    */
 680   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
 681   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
 682                                        TSO_STRUCT_SIZE)/sizeof(W_);
 683   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
 684   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
 685
 686   IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
 687
 688   dest = (StgTSO *)allocate(new_tso_size);
 689   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
 690
 691   /* copy the TSO block and the old stack into the new area */
 692   memcpy(dest,tso,TSO_STRUCT_SIZE);
 693   stack_words = tso->stack + tso->stack_size - tso->sp;
 694   new_sp = (P_)dest + new_tso_size - stack_words;
 695   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
 696
 697   /* relocate the stack pointers... */
 698   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
 699   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
 700   dest->sp    = new_sp;
 701   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
 702   dest->stack_size = new_stack_size;
 703
 704   /* and relocate the update frame list */
 705   relocate_TSO(tso, dest);
 706
 707   /* Mark the old one as dead so we don't try to scavenge it during
 708    * garbage collection (the TSO will likely be on a mutables list in
 709    * some generation, but it'll get collected soon enough).
 710    */
 711   tso->whatNext = ThreadKilled;
 712   dest->mut_link = NULL;
 713
 714   IF_DEBUG(sanity,checkTSO(tso));
 715 #if 0
 716   IF_DEBUG(scheduler,printTSO(dest));
 717 #endif
 718   if (tso == MainTSO) { /* hack */
 719       MainTSO = dest;
 720   }
 721   return dest;
 722 }
 723
 724 /* -----------------------------------------------------------------------------
 725    Wake up a queue that was blocked on some resource (usually a
 726    computation in progress).
 727    -------------------------------------------------------------------------- */
 728
 729 void awaken_blocked_queue(StgTSO *q)
 730 {
 731   StgTSO *tso;
 732
 733   while (q != END_TSO_QUEUE) {
 734     ASSERT(get_itbl(q)->type == TSO);
 735     tso = q;
 736     q = tso->link;
 737     PUSH_ON_RUN_QUEUE(tso);
 738     IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
 739   }
 740 }
 741
 742 /* -----------------------------------------------------------------------------
 743    Interrupt execution
 744    - usually called inside a signal handler so it mustn't do anything fancy.
 745    -------------------------------------------------------------------------- */
 746
 747 void interruptStgRts(void)
 748 {
 749     interrupted    = 1;
 750     context_switch = 1;
 751 }
 752