ghc/rts/Schedule.c

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