ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.27 1999/10/19 15:41:18 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Scheduler
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11 #include "SchedAPI.h"
  12 #include "RtsUtils.h"
  13 #include "RtsFlags.h"
  14 #include "Storage.h"
  15 #include "StgRun.h"
  16 #include "StgStartup.h"
  17 #include "GC.h"
  18 #include "Hooks.h"
  19 #include "Schedule.h"
  20 #include "StgMiscClosures.h"
  21 #include "Storage.h"
  22 #include "Evaluator.h"
  23 #include "Printer.h"
  24 #include "Main.h"
  25 #include "Signals.h"
  26 #include "Profiling.h"
  27 #include "Sanity.h"
  28
  29 StgTSO *run_queue_hd, *run_queue_tl;
  30 StgTSO *blocked_queue_hd, *blocked_queue_tl;
  31 StgTSO *ccalling_threads;
  32
  33 #define MAX_SCHEDULE_NESTING 256
  34 nat next_main_thread;
  35 StgTSO *main_threads[MAX_SCHEDULE_NESTING];
  36
  37 static void GetRoots(void);
  38 static StgTSO *threadStackOverflow(StgTSO *tso);
  39
  40 /* flag set by signal handler to precipitate a context switch */
  41 nat context_switch;
  42 /* if this flag is set as well, give up execution */
  43 static nat interrupted;
  44
  45 /* Next thread ID to allocate */
  46 StgThreadID next_thread_id = 1;
  47
  48 /*
  49  * Pointers to the state of the current thread.
  50  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
  51  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
  52  */
  53 StgTSO      *CurrentTSO;
  54 StgRegTable  MainRegTable;
  55
  56 /*
  57  * The thread state for the main thread.
  58  */
  59 StgTSO   *MainTSO;
  60
  61 /* The smallest stack size that makes any sense is:
  62  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
  63  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
  64  *  + 1                       (the realworld token for an IO thread)
  65  *  + 1                       (the closure to enter)
  66  *
  67  * A thread with this stack will bomb immediately with a stack
  68  * overflow, which will increase its stack size.
  69  */
  70
  71 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
  72
  73 /* -----------------------------------------------------------------------------
  74  * Static functions
  75  * -------------------------------------------------------------------------- */
  76 static void unblockThread(StgTSO *tso);
  77
  78 /* -----------------------------------------------------------------------------
  79  * Comparing Thread ids.
  80  *
  81  * This is used from STG land in the implementation of the
  82  * instances of Eq/Ord for ThreadIds.
  83  * -------------------------------------------------------------------------- */
  84
  85 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
  86 {
  87   StgThreadID id1 = tso1->id;
  88   StgThreadID id2 = tso2->id;
  89
  90   if (id1 < id2) return (-1);
  91   if (id1 > id2) return 1;
  92   return 0;
  93 }
  94
  95 /* -----------------------------------------------------------------------------
  96    Create a new thread.
  97
  98    The new thread starts with the given stack size.  Before the
  99    scheduler can run, however, this thread needs to have a closure
 100    (and possibly some arguments) pushed on its stack.  See
 101    pushClosure() in Schedule.h.
 102
 103    createGenThread() and createIOThread() (in SchedAPI.h) are
 104    convenient packaged versions of this function.
 105    -------------------------------------------------------------------------- */
 106
 107 StgTSO *
 108 createThread(nat stack_size)
 109 {
 110   StgTSO *tso;
 111
 112   /* catch ridiculously small stack sizes */
 113   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
 114     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
 115   }
 116
 117   tso = (StgTSO *)allocate(stack_size);
 118   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
 119
 120   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
 121   return tso;
 122 }
 123
 124 void
 125 initThread(StgTSO *tso, nat stack_size)
 126 {
 127   SET_INFO(tso,&TSO_info);
 128   tso->whatNext     = ThreadEnterGHC;
 129   tso->id           = next_thread_id++;
 130   tso->why_blocked  = NotBlocked;
 131
 132   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 133   tso->stack_size   = stack_size;
 134   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 135                               - TSO_STRUCT_SIZEW;
 136   tso->sp           = (P_)&(tso->stack) + stack_size;
 137
 138 #ifdef PROFILING
 139   tso->prof.CCCS = CCS_MAIN;
 140 #endif
 141
 142   /* put a stop frame on the stack */
 143   tso->sp -= sizeofW(StgStopFrame);
 144   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 145   tso->su = (StgUpdateFrame*)tso->sp;
 146
 147   IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
 148                            tso->id, tso->stack_size));
 149
 150   /* Put the new thread on the head of the runnable queue.
 151    * The caller of createThread better push an appropriate closure
 152    * on this thread's stack before the scheduler is invoked.
 153    */
 154   tso->link = run_queue_hd;
 155   run_queue_hd = tso;
 156   if (run_queue_tl == END_TSO_QUEUE) {
 157     run_queue_tl = tso;
 158   }
 159
 160   IF_DEBUG(scheduler,printTSO(tso));
 161 }
 162
 163 /* -----------------------------------------------------------------------------
 164  * initScheduler()
 165  *
 166  * Initialise the scheduler.  This resets all the queues - if the
 167  * queues contained any threads, they'll be garbage collected at the
 168  * next pass.
 169  * -------------------------------------------------------------------------- */
 170
 171 void initScheduler(void)
 172 {
 173   run_queue_hd      = END_TSO_QUEUE;
 174   run_queue_tl      = END_TSO_QUEUE;
 175   blocked_queue_hd  = END_TSO_QUEUE;
 176   blocked_queue_tl  = END_TSO_QUEUE;
 177   ccalling_threads  = END_TSO_QUEUE;
 178   next_main_thread  = 0;
 179
 180   context_switch = 0;
 181   interrupted    = 0;
 182
 183   enteredCAFs = END_CAF_LIST;
 184 }
 185
 186 /* -----------------------------------------------------------------------------
 187    Main scheduling loop.
 188
 189    We use round-robin scheduling, each thread returning to the
 190    scheduler loop when one of these conditions is detected:
 191
 192       * stack overflow
 193       * out of heap space
 194       * timer expires (thread yields)
 195       * thread blocks
 196       * thread ends
 197    -------------------------------------------------------------------------- */
 198
 199 SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 200 {
 201   StgTSO *t;
 202   StgThreadReturnCode ret;
 203   StgTSO **MainTSO;
 204   rtsBool in_ccall_gc;
 205
 206   /* Return value is NULL by default, it is only filled in if the
 207    * main thread completes successfully.
 208    */
 209   if (ret_val) { *ret_val = NULL; }
 210
 211   /* Save away a pointer to the main thread so that we can keep track
 212    * of it should a garbage collection happen.  We keep a stack of
 213    * main threads in order to support scheduler re-entry.  We can't
 214    * use the normal TSO linkage for this stack, because the main TSO
 215    * may need to be linked onto other queues.
 216    */
 217   main_threads[next_main_thread] = main;
 218   MainTSO = &main_threads[next_main_thread];
 219   next_main_thread++;
 220   IF_DEBUG(scheduler,
 221            fprintf(stderr, "Scheduler entered: nesting = %d\n",
 222                    next_main_thread););
 223
 224   /* Are we being re-entered?
 225    */
 226   if (CurrentTSO != NULL) {
 227     /* This happens when a _ccall_gc from Haskell ends up re-entering
 228      * the scheduler.
 229      *
 230      * Block the current thread (put it on the ccalling_queue) and
 231      * continue executing.  The calling thread better have stashed
 232      * away its state properly and left its stack with a proper stack
 233      * frame on the top.
 234      */
 235     threadPaused(CurrentTSO);
 236     CurrentTSO->link = ccalling_threads;
 237     ccalling_threads = CurrentTSO;
 238     in_ccall_gc = rtsTrue;
 239     IF_DEBUG(scheduler,
 240              fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
 241                      CurrentTSO->id););
 242   } else {
 243     in_ccall_gc = rtsFalse;
 244   }
 245
 246   /* Take a thread from the run queue.
 247    */
 248   t = run_queue_hd;
 249   if (t != END_TSO_QUEUE) {
 250     run_queue_hd = t->link;
 251     t->link = END_TSO_QUEUE;
 252     if (run_queue_hd == END_TSO_QUEUE) {
 253       run_queue_tl = END_TSO_QUEUE;
 254     }
 255   }
 256
 257   while (t != END_TSO_QUEUE) {
 258     CurrentTSO = t;
 259
 260     /* If we have more threads on the run queue, set up a context
 261      * switch at some point in the future.
 262      */
 263     if (run_queue_hd != END_TSO_QUEUE || blocked_queue_hd != END_TSO_QUEUE) {
 264       context_switch = 1;
 265     } else {
 266       context_switch = 0;
 267     }
 268     IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
 269
 270     /* Be friendly to the storage manager: we're about to *run* this
 271      * thread, so we better make sure the TSO is mutable.
 272      */
 273     if (t->mut_link == NULL) {
 274       recordMutable((StgMutClosure *)t);
 275     }
 276
 277     /* Run the current thread */
 278     switch (t->whatNext) {
 279     case ThreadKilled:
 280     case ThreadComplete:
 281       /* thread already killed.  Drop it and carry on. */
 282       goto next_thread;
 283     case ThreadEnterGHC:
 284       ret = StgRun((StgFunPtr) stg_enterStackTop);
 285       break;
 286     case ThreadRunGHC:
 287       ret = StgRun((StgFunPtr) stg_returnToStackTop);
 288       break;
 289     case ThreadEnterHugs:
 290 #ifdef INTERPRETER
 291       {
 292           IF_DEBUG(scheduler,belch("entering Hugs"));
 293           LoadThreadState();
 294           /* CHECK_SENSIBLE_REGS(); */
 295           {
 296               StgClosure* c = (StgClosure *)Sp[0];
 297               Sp += 1;
 298               ret = enter(c);
 299           }
 300           SaveThreadState();
 301           break;
 302       }
 303 #else
 304       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 305 #endif
 306     default:
 307       barf("schedule: invalid whatNext field");
 308     }
 309
 310     /* We may have garbage collected while running the thread
 311      * (eg. something nefarious like _ccall_GC_ performGC), and hence
 312      * CurrentTSO may have moved.  Update t to reflect this.
 313      */
 314     t = CurrentTSO;
 315     CurrentTSO = NULL;
 316
 317     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 318 #ifdef PROFILING
 319     CCCS = CCS_SYSTEM;
 320 #endif
 321
 322     switch (ret) {
 323
 324     case HeapOverflow:
 325       IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
 326       threadPaused(t);
 327       PUSH_ON_RUN_QUEUE(t);
 328       GarbageCollect(GetRoots);
 329       break;
 330
 331     case StackOverflow:
 332       IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
 333       {
 334         nat i;
 335         /* enlarge the stack */
 336         StgTSO *new_t = threadStackOverflow(t);
 337
 338         /* This TSO has moved, so update any pointers to it from the
 339          * main thread stack.  It better not be on any other queues...
 340          * (it shouldn't be)
 341          */
 342         for (i = 0; i < next_main_thread; i++) {
 343           if (main_threads[i] == t) {
 344             main_threads[i] = new_t;
 345           }
 346         }
 347         t = new_t;
 348       }
 349       PUSH_ON_RUN_QUEUE(t);
 350       break;
 351
 352     case ThreadYielding:
 353       IF_DEBUG(scheduler,
 354                if (t->whatNext == ThreadEnterHugs) {
 355                    /* ToDo: or maybe a timer expired when we were in Hugs?
 356                     * or maybe someone hit ctrl-C
 357                     */
 358                    belch("Thread %ld stopped to switch to Hugs\n", t->id);
 359                } else {
 360                    belch("Thread %ld stopped, timer expired\n", t->id);
 361                }
 362                );
 363       threadPaused(t);
 364       if (interrupted) {
 365           IF_DEBUG(scheduler,belch("Scheduler interrupted - returning"));
 366           deleteThread(t);
 367           while (run_queue_hd != END_TSO_QUEUE) {
 368               run_queue_hd = t->link;
 369               deleteThread(t);
 370           }
 371           run_queue_tl = END_TSO_QUEUE;
 372           /* ToDo: should I do the same with blocked queues? */
 373           return Interrupted;
 374       }
 375
 376       /* Put the thread back on the run queue, at the end.
 377        * t->link is already set to END_TSO_QUEUE.
 378        */
 379       PUSH_ON_RUN_QUEUE(t);
 380       break;
 381
 382     case ThreadBlocked:
 383       IF_DEBUG(scheduler,
 384                fprintf(stderr, "Thread %d stopped, ", t->id);
 385                printThreadBlockage(t);
 386                fprintf(stderr, "\n"));
 387       threadPaused(t);
 388       /* assume the thread has put itself on some blocked queue
 389        * somewhere.
 390        */
 391       break;
 392
 393     case ThreadFinished:
 394       IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
 395       t->whatNext = ThreadComplete;
 396       break;
 397
 398     default:
 399       barf("schedule: invalid thread return code");
 400     }
 401
 402     /* check for signals each time around the scheduler */
 403 #ifndef __MINGW32__
 404     if (signals_pending()) {
 405       start_signal_handlers();
 406     }
 407 #endif
 408     /* If our main thread has finished or been killed, return.
 409      * If we were re-entered as a result of a _ccall_gc, then
 410      * pop the blocked thread off the ccalling_threads stack back
 411      * into CurrentTSO.
 412      */
 413     if ((*MainTSO)->whatNext == ThreadComplete
 414         || (*MainTSO)->whatNext == ThreadKilled) {
 415       next_main_thread--;
 416       if (in_ccall_gc) {
 417         CurrentTSO = ccalling_threads;
 418         ccalling_threads = ccalling_threads->link;
 419         /* remember to stub the link field of CurrentTSO */
 420         CurrentTSO->link = END_TSO_QUEUE;
 421       }
 422       if ((*MainTSO)->whatNext == ThreadComplete) {
 423         /* we finished successfully, fill in the return value */
 424         if (ret_val) { *ret_val = (StgClosure *)(*MainTSO)->sp[0]; };
 425         return Success;
 426       } else {
 427         return Killed;
 428       }
 429     }
 430
 431   next_thread:
 432     /* Checked whether any waiting threads need to be woken up.
 433      * If the run queue is empty, we can wait indefinitely for
 434      * something to happen.
 435      */
 436     if (blocked_queue_hd != END_TSO_QUEUE) {
 437       awaitEvent(run_queue_hd == END_TSO_QUEUE);
 438     }
 439
 440     t = run_queue_hd;
 441     if (t != END_TSO_QUEUE) {
 442       run_queue_hd = t->link;
 443       t->link = END_TSO_QUEUE;
 444       if (run_queue_hd == END_TSO_QUEUE) {
 445         run_queue_tl = END_TSO_QUEUE;
 446       }
 447     }
 448   }
 449
 450   /* If we got to here, then we ran out of threads to run, but the
 451    * main thread hasn't finished yet.  It must be blocked on an MVar
 452    * or a black hole somewhere, so we return deadlock.
 453    */
 454   return Deadlock;
 455 }
 456
 457 /* -----------------------------------------------------------------------------
 458    Debugging: why is a thread blocked
 459    -------------------------------------------------------------------------- */
 460
 461 #ifdef DEBUG
 462 void printThreadBlockage(StgTSO *tso)
 463 {
 464   switch (tso->why_blocked) {
 465   case BlockedOnRead:
 466     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
 467     break;
 468   case BlockedOnWrite:
 469     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
 470     break;
 471   case BlockedOnDelay:
 472     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
 473     break;
 474   case BlockedOnMVar:
 475     fprintf(stderr,"blocked on an MVar");
 476     break;
 477   case BlockedOnBlackHole:
 478     fprintf(stderr,"blocked on a black hole");
 479     break;
 480   case NotBlocked:
 481     fprintf(stderr,"not blocked");
 482     break;
 483   }
 484 }
 485 #endif
 486
 487 /* -----------------------------------------------------------------------------
 488    Where are the roots that we know about?
 489
 490         - all the threads on the runnable queue
 491         - all the threads on the blocked queue
 492         - all the thread currently executing a _ccall_GC
 493         - all the "main threads"
 494
 495    -------------------------------------------------------------------------- */
 496
 497 static void GetRoots(void)
 498 {
 499   nat i;
 500
 501   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
 502   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
 503
 504   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
 505   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
 506
 507   ccalling_threads  = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
 508
 509   for (i = 0; i < next_main_thread; i++) {
 510     main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
 511   }
 512 }
 513
 514 /* -----------------------------------------------------------------------------
 515    performGC
 516
 517    This is the interface to the garbage collector from Haskell land.
 518    We provide this so that external C code can allocate and garbage
 519    collect when called from Haskell via _ccall_GC.
 520
 521    It might be useful to provide an interface whereby the programmer
 522    can specify more roots (ToDo).
 523    -------------------------------------------------------------------------- */
 524
 525 void (*extra_roots)(void);
 526
 527 void
 528 performGC(void)
 529 {
 530   GarbageCollect(GetRoots);
 531 }
 532
 533 static void
 534 AllRoots(void)
 535 {
 536   GetRoots();                   /* the scheduler's roots */
 537   extra_roots();                /* the user's roots */
 538 }
 539
 540 void
 541 performGCWithRoots(void (*get_roots)(void))
 542 {
 543   extra_roots = get_roots;
 544
 545   GarbageCollect(AllRoots);
 546 }
 547
 548 /* -----------------------------------------------------------------------------
 549    Stack overflow
 550
 551    If the thread has reached its maximum stack size,
 552    then bomb out.  Otherwise relocate the TSO into a larger chunk of
 553    memory and adjust its stack size appropriately.
 554    -------------------------------------------------------------------------- */
 555
 556 static StgTSO *
 557 threadStackOverflow(StgTSO *tso)
 558 {
 559   nat new_stack_size, new_tso_size, diff, stack_words;
 560   StgPtr new_sp;
 561   StgTSO *dest;
 562
 563   if (tso->stack_size >= tso->max_stack_size) {
 564 #if 0
 565     /* If we're debugging, just print out the top of the stack */
 566     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
 567                                      tso->sp+64));
 568 #endif
 569 #ifdef INTERPRETER
 570     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
 571     exit(1);
 572 #else
 573     /* Send this thread the StackOverflow exception */
 574     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
 575 #endif
 576     return tso;
 577   }
 578
 579   /* Try to double the current stack size.  If that takes us over the
 580    * maximum stack size for this thread, then use the maximum instead.
 581    * Finally round up so the TSO ends up as a whole number of blocks.
 582    */
 583   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
 584   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
 585                                        TSO_STRUCT_SIZE)/sizeof(W_);
 586   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
 587   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
 588
 589   IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
 590
 591   dest = (StgTSO *)allocate(new_tso_size);
 592   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
 593
 594   /* copy the TSO block and the old stack into the new area */
 595   memcpy(dest,tso,TSO_STRUCT_SIZE);
 596   stack_words = tso->stack + tso->stack_size - tso->sp;
 597   new_sp = (P_)dest + new_tso_size - stack_words;
 598   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
 599
 600   /* relocate the stack pointers... */
 601   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
 602   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
 603   dest->sp    = new_sp;
 604   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
 605   dest->stack_size = new_stack_size;
 606
 607   /* and relocate the update frame list */
 608   relocate_TSO(tso, dest);
 609
 610   /* Mark the old one as dead so we don't try to scavenge it during
 611    * garbage collection (the TSO will likely be on a mutables list in
 612    * some generation, but it'll get collected soon enough).  It's
 613    * important to set the sp and su values to just beyond the end of
 614    * the stack, so we don't attempt to scavenge any part of the dead
 615    * TSO's stack.
 616    */
 617   tso->whatNext = ThreadKilled;
 618   tso->sp = (P_)&(tso->stack[tso->stack_size]);
 619   tso->su = (StgUpdateFrame *)tso->sp;
 620   tso->why_blocked = NotBlocked;
 621   dest->mut_link = NULL;
 622
 623   IF_DEBUG(sanity,checkTSO(tso));
 624 #if 0
 625   IF_DEBUG(scheduler,printTSO(dest));
 626 #endif
 627   if (tso == MainTSO) { /* hack */
 628       MainTSO = dest;
 629   }
 630   return dest;
 631 }
 632
 633 /* -----------------------------------------------------------------------------
 634    Wake up a queue that was blocked on some resource.
 635    -------------------------------------------------------------------------- */
 636
 637 StgTSO *unblockOne(StgTSO *tso)
 638 {
 639   StgTSO *next;
 640
 641   ASSERT(get_itbl(tso)->type == TSO);
 642   ASSERT(tso->why_blocked != NotBlocked);
 643   tso->why_blocked = NotBlocked;
 644   next = tso->link;
 645   tso->link = END_TSO_QUEUE;
 646   PUSH_ON_RUN_QUEUE(tso);
 647   IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
 648   return next;
 649 }
 650
 651 void awakenBlockedQueue(StgTSO *tso)
 652 {
 653   while (tso != END_TSO_QUEUE) {
 654     tso = unblockOne(tso);
 655   }
 656 }
 657
 658 /* -----------------------------------------------------------------------------
 659    Interrupt execution
 660    - usually called inside a signal handler so it mustn't do anything fancy.
 661    -------------------------------------------------------------------------- */
 662
 663 void
 664 interruptStgRts(void)
 665 {
 666     interrupted    = 1;
 667     context_switch = 1;
 668 }
 669
 670 /* -----------------------------------------------------------------------------
 671    Unblock a thread
 672
 673    This is for use when we raise an exception in another thread, which
 674    may be blocked.
 675    -------------------------------------------------------------------------- */
 676
 677 static void
 678 unblockThread(StgTSO *tso)
 679 {
 680   StgTSO *t, **last;
 681
 682   switch (tso->why_blocked) {
 683
 684   case NotBlocked:
 685     return;  /* not blocked */
 686
 687   case BlockedOnMVar:
 688     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
 689     {
 690       StgTSO *last_tso = END_TSO_QUEUE;
 691       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
 692
 693       last = &mvar->head;
 694       for (t = mvar->head; t != END_TSO_QUEUE;
 695            last = &t->link, last_tso = t, t = t->link) {
 696         if (t == tso) {
 697           *last = tso->link;
 698           if (mvar->tail == tso) {
 699             mvar->tail = last_tso;
 700           }
 701           goto done;
 702         }
 703       }
 704       barf("unblockThread (MVAR): TSO not found");
 705     }
 706
 707   case BlockedOnBlackHole:
 708     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
 709     {
 710       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
 711
 712       last = &bq->blocking_queue;
 713       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
 714            last = &t->link, t = t->link) {
 715         if (t == tso) {
 716           *last = tso->link;
 717           goto done;
 718         }
 719       }
 720       barf("unblockThread (BLACKHOLE): TSO not found");
 721     }
 722
 723   case BlockedOnDelay:
 724   case BlockedOnRead:
 725   case BlockedOnWrite:
 726     {
 727       last = &blocked_queue_hd;
 728       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
 729            last = &t->link, t = t->link) {
 730         if (t == tso) {
 731           *last = tso->link;
 732           if (blocked_queue_tl == t) {
 733             blocked_queue_tl = tso->link;
 734           }
 735           goto done;
 736         }
 737       }
 738       barf("unblockThread (I/O): TSO not found");
 739     }
 740
 741   default:
 742     barf("unblockThread");
 743   }
 744
 745  done:
 746   tso->link = END_TSO_QUEUE;
 747   tso->why_blocked = NotBlocked;
 748   tso->block_info.closure = NULL;
 749   PUSH_ON_RUN_QUEUE(tso);
 750 }
 751
 752 /* -----------------------------------------------------------------------------
 753  * raiseAsync()
 754  *
 755  * The following function implements the magic for raising an
 756  * asynchronous exception in an existing thread.
 757  *
 758  * We first remove the thread from any queue on which it might be
 759  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
 760  *
 761  * We strip the stack down to the innermost CATCH_FRAME, building
 762  * thunks in the heap for all the active computations, so they can
 763  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
 764  * an application of the handler to the exception, and push it on
 765  * the top of the stack.
 766  *
 767  * How exactly do we save all the active computations?  We create an
 768  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
 769  * AP_UPDs pushes everything from the corresponding update frame
 770  * upwards onto the stack.  (Actually, it pushes everything up to the
 771  * next update frame plus a pointer to the next AP_UPD object.
 772  * Entering the next AP_UPD object pushes more onto the stack until we
 773  * reach the last AP_UPD object - at which point the stack should look
 774  * exactly as it did when we killed the TSO and we can continue
 775  * execution by entering the closure on top of the stack.
 776  *
 777  * We can also kill a thread entirely - this happens if either (a) the
 778  * exception passed to raiseAsync is NULL, or (b) there's no
 779  * CATCH_FRAME on the stack.  In either case, we strip the entire
 780  * stack and replace the thread with a zombie.
 781  *
 782  * -------------------------------------------------------------------------- */
 783
 784 void
 785 deleteThread(StgTSO *tso)
 786 {
 787   raiseAsync(tso,NULL);
 788 }
 789
 790 void
 791 raiseAsync(StgTSO *tso, StgClosure *exception)
 792 {
 793   StgUpdateFrame* su = tso->su;
 794   StgPtr          sp = tso->sp;
 795
 796   /* Thread already dead? */
 797   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
 798     return;
 799   }
 800
 801   IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
 802
 803   /* Remove it from any blocking queues */
 804   unblockThread(tso);
 805
 806   /* The stack freezing code assumes there's a closure pointer on
 807    * the top of the stack.  This isn't always the case with compiled
 808    * code, so we have to push a dummy closure on the top which just
 809    * returns to the next return address on the stack.
 810    */
 811   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
 812     *(--sp) = (W_)&dummy_ret_closure;
 813   }
 814
 815   while (1) {
 816     int words = ((P_)su - (P_)sp) - 1;
 817     nat i;
 818     StgAP_UPD * ap;
 819
 820     /* If we find a CATCH_FRAME, and we've got an exception to raise,
 821      * then build PAP(handler,exception), and leave it on top of
 822      * the stack ready to enter.
 823      */
 824     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
 825       StgCatchFrame *cf = (StgCatchFrame *)su;
 826       /* we've got an exception to raise, so let's pass it to the
 827        * handler in this frame.
 828        */
 829       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
 830       TICK_ALLOC_UPD_PAP(2,0);
 831       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
 832
 833       ap->n_args = 1;
 834       ap->fun = cf->handler;
 835       ap->payload[0] = (P_)exception;
 836
 837       /* sp currently points to the word above the CATCH_FRAME on the
 838        * stack.  Replace the CATCH_FRAME with a pointer to the new handler
 839        * application.
 840        */
 841       sp += sizeofW(StgCatchFrame);
 842       sp[0] = (W_)ap;
 843       tso->su = cf->link;
 844       tso->sp = sp;
 845       tso->whatNext = ThreadEnterGHC;
 846       return;
 847     }
 848
 849     /* First build an AP_UPD consisting of the stack chunk above the
 850      * current update frame, with the top word on the stack as the
 851      * fun field.
 852      */
 853     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
 854
 855     ASSERT(words >= 0);
 856
 857     ap->n_args = words;
 858     ap->fun    = (StgClosure *)sp[0];
 859     sp++;
 860     for(i=0; i < (nat)words; ++i) {
 861       ap->payload[i] = (P_)*sp++;
 862     }
 863
 864     switch (get_itbl(su)->type) {
 865
 866     case UPDATE_FRAME:
 867       {
 868         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
 869         TICK_ALLOC_UP_THK(words+1,0);
 870
 871         IF_DEBUG(scheduler,
 872                  fprintf(stderr,  "Updating ");
 873                  printPtr((P_)su->updatee);
 874                  fprintf(stderr,  " with ");
 875                  printObj((StgClosure *)ap);
 876                  );
 877
 878         /* Replace the updatee with an indirection - happily
 879          * this will also wake up any threads currently
 880          * waiting on the result.
 881          */
 882         UPD_IND(su->updatee,ap);  /* revert the black hole */
 883         su = su->link;
 884         sp += sizeofW(StgUpdateFrame) -1;
 885         sp[0] = (W_)ap; /* push onto stack */
 886         break;
 887       }
 888
 889     case CATCH_FRAME:
 890       {
 891         StgCatchFrame *cf = (StgCatchFrame *)su;
 892         StgClosure* o;
 893
 894         /* We want a PAP, not an AP_UPD.  Fortunately, the
 895          * layout's the same.
 896          */
 897         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 898         TICK_ALLOC_UPD_PAP(words+1,0);
 899
 900         /* now build o = FUN(catch,ap,handler) */
 901         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
 902         TICK_ALLOC_FUN(2,0);
 903         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
 904         o->payload[0] = (StgClosure *)ap;
 905         o->payload[1] = cf->handler;
 906
 907         IF_DEBUG(scheduler,
 908                  fprintf(stderr,  "Built ");
 909                  printObj((StgClosure *)o);
 910                  );
 911
 912         /* pop the old handler and put o on the stack */
 913         su = cf->link;
 914         sp += sizeofW(StgCatchFrame) - 1;
 915         sp[0] = (W_)o;
 916         break;
 917       }
 918
 919     case SEQ_FRAME:
 920       {
 921         StgSeqFrame *sf = (StgSeqFrame *)su;
 922         StgClosure* o;
 923
 924         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
 925         TICK_ALLOC_UPD_PAP(words+1,0);
 926
 927         /* now build o = FUN(seq,ap) */
 928         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
 929         TICK_ALLOC_SE_THK(1,0);
 930         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
 931         payloadCPtr(o,0) = (StgClosure *)ap;
 932
 933         IF_DEBUG(scheduler,
 934                  fprintf(stderr,  "Built ");
 935                  printObj((StgClosure *)o);
 936                  );
 937
 938         /* pop the old handler and put o on the stack */
 939         su = sf->link;
 940         sp += sizeofW(StgSeqFrame) - 1;
 941         sp[0] = (W_)o;
 942         break;
 943       }
 944
 945     case STOP_FRAME:
 946       /* We've stripped the entire stack, the thread is now dead. */
 947       sp += sizeofW(StgStopFrame) - 1;
 948       sp[0] = (W_)exception;    /* save the exception */
 949       tso->whatNext = ThreadKilled;
 950       tso->su = (StgUpdateFrame *)(sp+1);
 951       tso->sp = sp;
 952       return;
 953
 954     default:
 955       barf("raiseAsync");
 956     }
 957   }
 958   barf("raiseAsync");
 959 }