ghc/rts/Schedule.c

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