ghc/rts/Schedule.c

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