ghc/rts/Schedule.c

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