ghc/rts/Schedule.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Schedule.c,v 1.30 1999/11/08 15:30:39 sewardj Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Scheduler
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 /* Version with scheduler monitor support for SMPs.
  11
  12    This design provides a high-level API to create and schedule threads etc.
  13    as documented in the SMP design document.
  14
  15    It uses a monitor design controlled by a single mutex to exercise control
  16    over accesses to shared data structures, and builds on the Posix threads
  17    library.
  18
  19    The majority of state is shared.  In order to keep essential per-task state,
  20    there is a Capability structure, which contains all the information
  21    needed to run a thread: its STG registers, a pointer to its TSO, a
  22    nursery etc.  During STG execution, a pointer to the capability is
  23    kept in a register (BaseReg).
  24
  25    In a non-SMP build, there is one global capability, namely MainRegTable.
  26
  27    SDM & KH, 10/99
  28 */
  29
  30 #include "Rts.h"
  31 #include "SchedAPI.h"
  32 #include "RtsUtils.h"
  33 #include "RtsFlags.h"
  34 #include "Storage.h"
  35 #include "StgRun.h"
  36 #include "StgStartup.h"
  37 #include "GC.h"
  38 #include "Hooks.h"
  39 #include "Schedule.h"
  40 #include "StgMiscClosures.h"
  41 #include "Storage.h"
  42 #include "Evaluator.h"
  43 #include "Printer.h"
  44 #include "Main.h"
  45 #include "Signals.h"
  46 #include "Profiling.h"
  47 #include "Sanity.h"
  48 #include "Stats.h"
  49
  50 /* Main threads:
  51  *
  52  * These are the threads which clients have requested that we run.
  53  *
  54  * In an SMP build, we might have several concurrent clients all
  55  * waiting for results, and each one will wait on a condition variable
  56  * until the result is available.
  57  *
  58  * In non-SMP, clients are strictly nested: the first client calls
  59  * into the RTS, which might call out again to C with a _ccall_GC, and
  60  * eventually re-enter the RTS.
  61  *
  62  * Main threads information is kept in a linked list:
  63  */
  64 typedef struct StgMainThread_ {
  65   StgTSO *         tso;
  66   SchedulerStatus  stat;
  67   StgClosure **    ret;
  68 #ifdef SMP
  69   pthread_cond_t wakeup;
  70 #endif
  71   struct StgMainThread_ *link;
  72 } StgMainThread;
  73
  74 /* Main thread queue.
  75  * Locks required: sched_mutex.
  76  */
  77 static StgMainThread *main_threads;
  78
  79 /* Thread queues.
  80  * Locks required: sched_mutex.
  81  */
  82 StgTSO *run_queue_hd, *run_queue_tl;
  83 StgTSO *blocked_queue_hd, *blocked_queue_tl;
  84
  85 /* Threads suspended in _ccall_GC.
  86  * Locks required: sched_mutex.
  87  */
  88 static StgTSO *suspended_ccalling_threads;
  89
  90 #ifndef SMP
  91 static rtsBool in_ccall_gc;
  92 #endif
  93
  94 static void GetRoots(void);
  95 static StgTSO *threadStackOverflow(StgTSO *tso);
  96
  97 /* KH: The following two flags are shared memory locations.  There is no need
  98        to lock them, since they are only unset at the end of a scheduler
  99        operation.
 100 */
 101
 102 /* flag set by signal handler to precipitate a context switch */
 103 nat context_switch;
 104 /* if this flag is set as well, give up execution */
 105 static nat interrupted;
 106
 107 /* Next thread ID to allocate.
 108  * Locks required: sched_mutex
 109  */
 110 StgThreadID next_thread_id = 1;
 111
 112 /*
 113  * Pointers to the state of the current thread.
 114  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
 115  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
 116  */
 117
 118 /* The smallest stack size that makes any sense is:
 119  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
 120  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
 121  *  + 1                       (the realworld token for an IO thread)
 122  *  + 1                       (the closure to enter)
 123  *
 124  * A thread with this stack will bomb immediately with a stack
 125  * overflow, which will increase its stack size.
 126  */
 127
 128 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
 129
 130 /* Free capability list.
 131  * Locks required: sched_mutex.
 132  */
 133 #ifdef SMP
 134 Capability *free_capabilities;  /* Available capabilities for running threads */
 135 nat n_free_capabilities;        /* total number of available capabilities */
 136 #else
 137 Capability MainRegTable;        /* for non-SMP, we have one global capability */
 138 #endif
 139
 140 rtsBool ready_to_gc;
 141
 142 /* All our current task ids, saved in case we need to kill them later.
 143  */
 144 #ifdef SMP
 145 task_info *task_ids;
 146 #endif
 147
 148 void            addToBlockedQueue ( StgTSO *tso );
 149
 150 static void     schedule          ( void );
 151 static void     initThread        ( StgTSO *tso, nat stack_size );
 152        void     interruptStgRts   ( void );
 153
 154 #ifdef SMP
 155 pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
 156 pthread_mutex_t term_mutex        = PTHREAD_MUTEX_INITIALIZER;
 157 pthread_cond_t  thread_ready_cond = PTHREAD_COND_INITIALIZER;
 158 pthread_cond_t  gc_pending_cond   = PTHREAD_COND_INITIALIZER;
 159
 160 nat await_death;
 161 #endif
 162
 163 /* -----------------------------------------------------------------------------
 164    Main scheduling loop.
 165
 166    We use round-robin scheduling, each thread returning to the
 167    scheduler loop when one of these conditions is detected:
 168
 169       * out of heap space
 170       * timer expires (thread yields)
 171       * thread blocks
 172       * thread ends
 173       * stack overflow
 174
 175    Locking notes:  we acquire the scheduler lock once at the beginning
 176    of the scheduler loop, and release it when
 177
 178       * running a thread, or
 179       * waiting for work, or
 180       * waiting for a GC to complete.
 181
 182    -------------------------------------------------------------------------- */
 183
 184 static void
 185 schedule( void )
 186 {
 187   StgTSO *t;
 188   Capability *cap;
 189   StgThreadReturnCode ret;
 190
 191   ACQUIRE_LOCK(&sched_mutex);
 192
 193   while (1) {
 194
 195     /* Check whether any waiting threads need to be woken up.
 196      * If the run queue is empty, we can wait indefinitely for
 197      * something to happen.
 198      */
 199     if (blocked_queue_hd != END_TSO_QUEUE) {
 200       awaitEvent(run_queue_hd == END_TSO_QUEUE);
 201     }
 202
 203     /* check for signals each time around the scheduler */
 204 #ifndef __MINGW32__
 205     if (signals_pending()) {
 206       start_signal_handlers();
 207     }
 208 #endif
 209
 210 #ifdef SMP
 211     /* If there's a GC pending, don't do anything until it has
 212      * completed.
 213      */
 214     if (ready_to_gc) {
 215       IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): waiting for GC\n",
 216                                  pthread_self()););
 217       pthread_cond_wait(&gc_pending_cond, &sched_mutex);
 218     }
 219
 220     /* block until we've got a thread on the run queue and a free
 221      * capability.
 222      */
 223     while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
 224       IF_DEBUG(scheduler,
 225                fprintf(stderr, "schedule (task %ld): waiting for work\n",
 226                        pthread_self()););
 227       pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 228       IF_DEBUG(scheduler,
 229                fprintf(stderr, "schedule (task %ld): work now available\n",
 230                        pthread_self()););
 231     }
 232 #endif
 233
 234     /* grab a thread from the run queue
 235      */
 236     t = POP_RUN_QUEUE();
 237
 238     /* grab a capability
 239      */
 240 #ifdef SMP
 241     cap = free_capabilities;
 242     free_capabilities = cap->link;
 243     n_free_capabilities--;
 244 #else
 245     cap = &MainRegTable;
 246 #endif
 247
 248     cap->rCurrentTSO = t;
 249
 250     /* set the context_switch flag
 251      */
 252     if (run_queue_hd == END_TSO_QUEUE)
 253       context_switch = 0;
 254     else
 255       context_switch = 1;
 256
 257     RELEASE_LOCK(&sched_mutex);
 258
 259 #ifdef SMP
 260     IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): running thread %d\n", pthread_self(),t->id));
 261 #else
 262     IF_DEBUG(scheduler,fprintf(stderr,"schedule: running thread %d\n",t->id));
 263 #endif
 264
 265     /* Run the current thread
 266      */
 267     switch (cap->rCurrentTSO->whatNext) {
 268     case ThreadKilled:
 269     case ThreadComplete:
 270       /* Thread already finished, return to scheduler. */
 271       ret = ThreadFinished;
 272       break;
 273     case ThreadEnterGHC:
 274       ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
 275       break;
 276     case ThreadRunGHC:
 277       ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
 278       break;
 279     case ThreadEnterHugs:
 280 #ifdef INTERPRETER
 281       {
 282          StgClosure* c;
 283          IF_DEBUG(scheduler,belch("schedule: entering Hugs"));
 284          c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
 285          cap->rCurrentTSO->sp += 1;
 286          ret = enter(cap,c);
 287          break;
 288       }
 289 #else
 290       barf("Panic: entered a BCO but no bytecode interpreter in this build");
 291 #endif
 292     default:
 293       barf("schedule: invalid whatNext field");
 294     }
 295
 296     /* Costs for the scheduler are assigned to CCS_SYSTEM */
 297 #ifdef PROFILING
 298     CCCS = CCS_SYSTEM;
 299 #endif
 300
 301     ACQUIRE_LOCK(&sched_mutex);
 302
 303 #ifdef SMP
 304     IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): ", pthread_self()););
 305 #else
 306     IF_DEBUG(scheduler,fprintf(stderr,"schedule: "););
 307 #endif
 308     t = cap->rCurrentTSO;
 309
 310     switch (ret) {
 311     case HeapOverflow:
 312       /* make all the running tasks block on a condition variable,
 313        * maybe set context_switch and wait till they all pile in,
 314        * then have them wait on a GC condition variable.
 315        */
 316       IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
 317       threadPaused(t);
 318
 319       ready_to_gc = rtsTrue;
 320       context_switch = 1;               /* stop other threads ASAP */
 321       PUSH_ON_RUN_QUEUE(t);
 322       break;
 323
 324     case StackOverflow:
 325       /* just adjust the stack for this thread, then pop it back
 326        * on the run queue.
 327        */
 328       IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
 329       threadPaused(t);
 330       {
 331         StgMainThread *m;
 332         /* enlarge the stack */
 333         StgTSO *new_t = threadStackOverflow(t);
 334
 335         /* This TSO has moved, so update any pointers to it from the
 336          * main thread stack.  It better not be on any other queues...
 337          * (it shouldn't be)
 338          */
 339         for (m = main_threads; m != NULL; m = m->link) {
 340           if (m->tso == t) {
 341             m->tso = new_t;
 342           }
 343         }
 344         PUSH_ON_RUN_QUEUE(new_t);
 345       }
 346       break;
 347
 348     case ThreadYielding:
 349       /* put the thread back on the run queue.  Then, if we're ready to
 350        * GC, check whether this is the last task to stop.  If so, wake
 351        * up the GC thread.  getThread will block during a GC until the
 352        * GC is finished.
 353        */
 354       IF_DEBUG(scheduler,
 355                if (t->whatNext == ThreadEnterHugs) {
 356                  /* ToDo: or maybe a timer expired when we were in Hugs?
 357                   * or maybe someone hit ctrl-C
 358                   */
 359                  belch("thread %ld stopped to switch to Hugs", t->id);
 360                } else {
 361                  belch("thread %ld stopped, yielding", t->id);
 362                }
 363                );
 364       threadPaused(t);
 365       APPEND_TO_RUN_QUEUE(t);
 366       break;
 367
 368     case ThreadBlocked:
 369       /* don't need to do anything.  Either the thread is blocked on
 370        * I/O, in which case we'll have called addToBlockedQueue
 371        * previously, or it's blocked on an MVar or Blackhole, in which
 372        * case it'll be on the relevant queue already.
 373        */
 374       IF_DEBUG(scheduler,
 375                fprintf(stderr, "thread %d stopped, ", t->id);
 376                printThreadBlockage(t);
 377                fprintf(stderr, "\n"));
 378       threadPaused(t);
 379       break;
 380
 381     case ThreadFinished:
 382       /* Need to check whether this was a main thread, and if so, signal
 383        * the task that started it with the return value.  If we have no
 384        * more main threads, we probably need to stop all the tasks until
 385        * we get a new one.
 386        */
 387       IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
 388       t->whatNext = ThreadComplete;
 389       break;
 390
 391     default:
 392       barf("doneThread: invalid thread return code");
 393     }
 394
 395 #ifdef SMP
 396     cap->link = free_capabilities;
 397     free_capabilities = cap;
 398     n_free_capabilities++;
 399 #endif
 400
 401 #ifdef SMP
 402     if (ready_to_gc && n_free_capabilities == RtsFlags.ConcFlags.nNodes) {
 403 #else
 404     if (ready_to_gc) {
 405 #endif
 406       /* everybody back, start the GC.
 407        * Could do it in this thread, or signal a condition var
 408        * to do it in another thread.  Either way, we need to
 409        * broadcast on gc_pending_cond afterward.
 410        */
 411 #ifdef SMP
 412       IF_DEBUG(scheduler,belch("schedule (task %ld): doing GC", pthread_self()));
 413 #endif
 414       GarbageCollect(GetRoots);
 415       ready_to_gc = rtsFalse;
 416 #ifdef SMP
 417       pthread_cond_broadcast(&gc_pending_cond);
 418 #endif
 419     }
 420
 421     /* Go through the list of main threads and wake up any
 422      * clients whose computations have finished.  ToDo: this
 423      * should be done more efficiently without a linear scan
 424      * of the main threads list, somehow...
 425      */
 426 #ifdef SMP
 427     {
 428       StgMainThread *m, **prev;
 429       prev = &main_threads;
 430       for (m = main_threads; m != NULL; m = m->link) {
 431         if (m->tso->whatNext == ThreadComplete) {
 432           if (m->ret) {
 433             *(m->ret) = (StgClosure *)m->tso->sp[0];
 434           }
 435           *prev = m->link;
 436           m->stat = Success;
 437           pthread_cond_broadcast(&m->wakeup);
 438         }
 439         if (m->tso->whatNext == ThreadKilled) {
 440           *prev = m->link;
 441           m->stat = Killed;
 442           pthread_cond_broadcast(&m->wakeup);
 443         }
 444       }
 445     }
 446 #else
 447     /* If our main thread has finished or been killed, return.
 448      * If we were re-entered as a result of a _ccall_gc, then
 449      * pop the blocked thread off the ccalling_threads stack back
 450      * into CurrentTSO.
 451      */
 452     {
 453       StgMainThread *m = main_threads;
 454       if (m->tso->whatNext == ThreadComplete
 455           || m->tso->whatNext == ThreadKilled) {
 456         main_threads = main_threads->link;
 457         if (m->tso->whatNext == ThreadComplete) {
 458           /* we finished successfully, fill in the return value */
 459           if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
 460           m->stat = Success;
 461           return;
 462         } else {
 463           m->stat = Killed;
 464           return;
 465         }
 466       }
 467     }
 468 #endif
 469
 470   } /* end of while(1) */
 471 }
 472
 473 /* -----------------------------------------------------------------------------
 474  * Suspending & resuming Haskell threads.
 475  *
 476  * When making a "safe" call to C (aka _ccall_GC), the task gives back
 477  * its capability before calling the C function.  This allows another
 478  * task to pick up the capability and carry on running Haskell
 479  * threads.  It also means that if the C call blocks, it won't lock
 480  * the whole system.
 481  *
 482  * The Haskell thread making the C call is put to sleep for the
 483  * duration of the call, on the susepended_ccalling_threads queue.  We
 484  * give out a token to the task, which it can use to resume the thread
 485  * on return from the C function.
 486  * -------------------------------------------------------------------------- */
 487
 488 StgInt
 489 suspendThread( Capability *cap )
 490 {
 491   nat tok;
 492
 493   ACQUIRE_LOCK(&sched_mutex);
 494
 495 #ifdef SMP
 496   IF_DEBUG(scheduler,
 497            fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n",
 498                    pthread_self(), cap->rCurrentTSO->id));
 499 #else
 500   IF_DEBUG(scheduler,
 501            fprintf(stderr, "schedule: thread %d did a _ccall_gc\n",
 502                    cap->rCurrentTSO->id));
 503 #endif
 504
 505   threadPaused(cap->rCurrentTSO);
 506   cap->rCurrentTSO->link = suspended_ccalling_threads;
 507   suspended_ccalling_threads = cap->rCurrentTSO;
 508
 509   /* Use the thread ID as the token; it should be unique */
 510   tok = cap->rCurrentTSO->id;
 511
 512 #ifdef SMP
 513   cap->link = free_capabilities;
 514   free_capabilities = cap;
 515   n_free_capabilities++;
 516 #endif
 517
 518   RELEASE_LOCK(&sched_mutex);
 519   return tok;
 520 }
 521
 522 Capability *
 523 resumeThread( StgInt tok )
 524 {
 525   StgTSO *tso, **prev;
 526   Capability *cap;
 527
 528   ACQUIRE_LOCK(&sched_mutex);
 529
 530   prev = &suspended_ccalling_threads;
 531   for (tso = suspended_ccalling_threads;
 532        tso != END_TSO_QUEUE;
 533        prev = &tso->link, tso = tso->link) {
 534     if (tso->id == (StgThreadID)tok) {
 535       *prev = tso->link;
 536       break;
 537     }
 538   }
 539   if (tso == END_TSO_QUEUE) {
 540     barf("resumeThread: thread not found");
 541   }
 542
 543 #ifdef SMP
 544   while (free_capabilities == NULL) {
 545     IF_DEBUG(scheduler,
 546              fprintf(stderr,"schedule (task %ld): waiting to resume\n",
 547                      pthread_self()));
 548     pthread_cond_wait(&thread_ready_cond, &sched_mutex);
 549     IF_DEBUG(scheduler,fprintf(stderr,
 550                                "schedule (task %ld): resuming thread %d\n",
 551                                pthread_self(), tso->id));
 552   }
 553   cap = free_capabilities;
 554   free_capabilities = cap->link;
 555   n_free_capabilities--;
 556 #else
 557   cap = &MainRegTable;
 558 #endif
 559
 560   cap->rCurrentTSO = tso;
 561
 562   RELEASE_LOCK(&sched_mutex);
 563   return cap;
 564 }
 565
 566 /* -----------------------------------------------------------------------------
 567  * Static functions
 568  * -------------------------------------------------------------------------- */
 569 static void unblockThread(StgTSO *tso);
 570
 571 /* -----------------------------------------------------------------------------
 572  * Comparing Thread ids.
 573  *
 574  * This is used from STG land in the implementation of the
 575  * instances of Eq/Ord for ThreadIds.
 576  * -------------------------------------------------------------------------- */
 577
 578 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
 579 {
 580   StgThreadID id1 = tso1->id;
 581   StgThreadID id2 = tso2->id;
 582
 583   if (id1 < id2) return (-1);
 584   if (id1 > id2) return 1;
 585   return 0;
 586 }
 587
 588 /* -----------------------------------------------------------------------------
 589    Create a new thread.
 590
 591    The new thread starts with the given stack size.  Before the
 592    scheduler can run, however, this thread needs to have a closure
 593    (and possibly some arguments) pushed on its stack.  See
 594    pushClosure() in Schedule.h.
 595
 596    createGenThread() and createIOThread() (in SchedAPI.h) are
 597    convenient packaged versions of this function.
 598    -------------------------------------------------------------------------- */
 599
 600 StgTSO *
 601 createThread(nat stack_size)
 602 {
 603   StgTSO *tso;
 604
 605   /* catch ridiculously small stack sizes */
 606   if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
 607     stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
 608   }
 609
 610   tso = (StgTSO *)allocate(stack_size);
 611   TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
 612
 613   initThread(tso, stack_size - TSO_STRUCT_SIZEW);
 614   return tso;
 615 }
 616
 617 void
 618 initThread(StgTSO *tso, nat stack_size)
 619 {
 620   SET_INFO(tso,&TSO_info);
 621   tso->whatNext     = ThreadEnterGHC;
 622
 623   /* tso->id needs to be unique.  For now we use a heavyweight mutex to
 624          protect the increment operation on next_thread_id.
 625          In future, we could use an atomic increment instead.
 626   */
 627
 628   ACQUIRE_LOCK(&sched_mutex);
 629   tso->id = next_thread_id++;
 630   RELEASE_LOCK(&sched_mutex);
 631
 632   tso->why_blocked  = NotBlocked;
 633
 634   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 635   tso->stack_size   = stack_size;
 636   tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
 637                               - TSO_STRUCT_SIZEW;
 638   tso->sp           = (P_)&(tso->stack) + stack_size;
 639
 640 #ifdef PROFILING
 641   tso->prof.CCCS = CCS_MAIN;
 642 #endif
 643
 644   /* put a stop frame on the stack */
 645   tso->sp -= sizeofW(StgStopFrame);
 646   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
 647   tso->su = (StgUpdateFrame*)tso->sp;
 648
 649   IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words",
 650                            tso->id, tso->stack_size));
 651
 652 }
 653
 654
 655 /* -----------------------------------------------------------------------------
 656  * scheduleThread()
 657  *
 658  * scheduleThread puts a thread on the head of the runnable queue.
 659  * This will usually be done immediately after a thread is created.
 660  * The caller of scheduleThread must create the thread using e.g.
 661  * createThread and push an appropriate closure
 662  * on this thread's stack before the scheduler is invoked.
 663  * -------------------------------------------------------------------------- */
 664
 665 void
 666 scheduleThread(StgTSO *tso)
 667 {
 668   ACQUIRE_LOCK(&sched_mutex);
 669
 670   /* Put the new thread on the head of the runnable queue.  The caller
 671    * better push an appropriate closure on this thread's stack
 672    * beforehand.  In the SMP case, the thread may start running as
 673    * soon as we release the scheduler lock below.
 674    */
 675   PUSH_ON_RUN_QUEUE(tso);
 676   THREAD_RUNNABLE();
 677
 678   IF_DEBUG(scheduler,printTSO(tso));
 679   RELEASE_LOCK(&sched_mutex);
 680 }
 681
 682
 683 /* -----------------------------------------------------------------------------
 684  * startTasks()
 685  *
 686  * Start up Posix threads to run each of the scheduler tasks.
 687  * I believe the task ids are not needed in the system as defined.
 688   * KH @ 25/10/99
 689  * -------------------------------------------------------------------------- */
 690
 691 #ifdef SMP
 692 static void *
 693 taskStart( void *arg STG_UNUSED )
 694 {
 695   schedule();
 696   return NULL;
 697 }
 698 #endif
 699
 700 /* -----------------------------------------------------------------------------
 701  * initScheduler()
 702  *
 703  * Initialise the scheduler.  This resets all the queues - if the
 704  * queues contained any threads, they'll be garbage collected at the
 705  * next pass.
 706  *
 707  * This now calls startTasks(), so should only be called once!  KH @ 25/10/99
 708  * -------------------------------------------------------------------------- */
 709
 710 #ifdef SMP
 711 static void
 712 term_handler(int sig STG_UNUSED)
 713 {
 714   nat i;
 715   pthread_t me = pthread_self();
 716
 717   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 718     if (task_ids[i].id == me) {
 719       task_ids[i].mut_time = usertime() - task_ids[i].gc_time;
 720       if (task_ids[i].mut_time < 0.0) {
 721         task_ids[i].mut_time = 0.0;
 722       }
 723     }
 724   }
 725   ACQUIRE_LOCK(&term_mutex);
 726   await_death--;
 727   RELEASE_LOCK(&term_mutex);
 728   pthread_exit(NULL);
 729 }
 730 #endif
 731
 732 void initScheduler(void)
 733 {
 734   run_queue_hd      = END_TSO_QUEUE;
 735   run_queue_tl      = END_TSO_QUEUE;
 736   blocked_queue_hd  = END_TSO_QUEUE;
 737   blocked_queue_tl  = END_TSO_QUEUE;
 738
 739   suspended_ccalling_threads  = END_TSO_QUEUE;
 740
 741   main_threads = NULL;
 742
 743   context_switch = 0;
 744   interrupted    = 0;
 745
 746   enteredCAFs = END_CAF_LIST;
 747
 748   /* Install the SIGHUP handler */
 749 #ifdef SMP
 750   {
 751     struct sigaction action,oact;
 752
 753     action.sa_handler = term_handler;
 754     sigemptyset(&action.sa_mask);
 755     action.sa_flags = 0;
 756     if (sigaction(SIGTERM, &action, &oact) != 0) {
 757       barf("can't install TERM handler");
 758     }
 759   }
 760 #endif
 761
 762 #ifdef SMP
 763   /* Allocate N Capabilities */
 764   {
 765     nat i;
 766     Capability *cap, *prev;
 767     cap  = NULL;
 768     prev = NULL;
 769     for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 770       cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
 771       cap->link = prev;
 772       prev = cap;
 773     }
 774     free_capabilities = cap;
 775     n_free_capabilities = RtsFlags.ConcFlags.nNodes;
 776   }
 777   IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
 778                              n_free_capabilities););
 779 #endif
 780 }
 781
 782 #ifdef SMP
 783 void
 784 startTasks( void )
 785 {
 786   nat i;
 787   int r;
 788   pthread_t tid;
 789
 790   /* make some space for saving all the thread ids */
 791   task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
 792                             "initScheduler:task_ids");
 793
 794   /* and create all the threads */
 795   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 796     r = pthread_create(&tid,NULL,taskStart,NULL);
 797     if (r != 0) {
 798       barf("startTasks: Can't create new Posix thread");
 799     }
 800     task_ids[i].id = tid;
 801     IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
 802   }
 803 }
 804 #endif
 805
 806 void
 807 exitScheduler( void )
 808 {
 809 #ifdef SMP
 810   nat i;
 811
 812   /* Don't want to use pthread_cancel, since we'd have to install
 813    * these silly exception handlers (pthread_cleanup_{push,pop}) around
 814    * all our locks.
 815    */
 816 #if 0
 817   /* Cancel all our tasks */
 818   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 819     pthread_cancel(task_ids[i].id);
 820   }
 821
 822   /* Wait for all the tasks to terminate */
 823   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 824     IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n",
 825                                task_ids[i].id));
 826     pthread_join(task_ids[i].id, NULL);
 827   }
 828 #endif
 829
 830   /* Send 'em all a SIGHUP.  That should shut 'em up.
 831    */
 832   await_death = RtsFlags.ConcFlags.nNodes;
 833   for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
 834     pthread_kill(task_ids[i].id,SIGTERM);
 835   }
 836   while (await_death > 0) {
 837     sched_yield();
 838   }
 839 #endif
 840 }
 841
 842 /* -----------------------------------------------------------------------------
 843    Managing the per-task allocation areas.
 844
 845    Each capability comes with an allocation area.  These are
 846    fixed-length block lists into which allocation can be done.
 847
 848    ToDo: no support for two-space collection at the moment???
 849    -------------------------------------------------------------------------- */
 850
 851 /* -----------------------------------------------------------------------------
 852  * waitThread is the external interface for running a new computataion
 853  * and waiting for the result.
 854  *
 855  * In the non-SMP case, we create a new main thread, push it on the
 856  * main-thread stack, and invoke the scheduler to run it.  The
 857  * scheduler will return when the top main thread on the stack has
 858  * completed or died, and fill in the necessary fields of the
 859  * main_thread structure.
 860  *
 861  * In the SMP case, we create a main thread as before, but we then
 862  * create a new condition variable and sleep on it.  When our new
 863  * main thread has completed, we'll be woken up and the status/result
 864  * will be in the main_thread struct.
 865  * -------------------------------------------------------------------------- */
 866
 867 SchedulerStatus
 868 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 869 {
 870   StgMainThread *m;
 871   SchedulerStatus stat;
 872
 873   ACQUIRE_LOCK(&sched_mutex);
 874
 875   m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
 876
 877   m->tso = tso;
 878   m->ret = ret;
 879   m->stat = NoStatus;
 880 #ifdef SMP
 881   pthread_cond_init(&m->wakeup, NULL);
 882 #endif
 883
 884   m->link = main_threads;
 885   main_threads = m;
 886
 887 #ifdef SMP
 888   pthread_cond_wait(&m->wakeup, &sched_mutex);
 889 #else
 890   schedule();
 891 #endif
 892
 893   stat = m->stat;
 894   ASSERT(stat != NoStatus);
 895
 896 #ifdef SMP
 897   pthread_cond_destroy(&m->wakeup);
 898 #endif
 899   free(m);
 900
 901   RELEASE_LOCK(&sched_mutex);
 902   return stat;
 903 }
 904
 905
 906 #if 0
 907 SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 908 {
 909   StgTSO *t;
 910   StgThreadReturnCode ret;
 911   StgTSO **MainTSO;
 912   rtsBool in_ccall_gc;
 913
 914   /* Return value is NULL by default, it is only filled in if the
 915    * main thread completes successfully.
 916    */
 917   if (ret_val) { *ret_val = NULL; }
 918
 919   /* Save away a pointer to the main thread so that we can keep track
 920    * of it should a garbage collection happen.  We keep a stack of
 921    * main threads in order to support scheduler re-entry.  We can't
 922    * use the normal TSO linkage for this stack, because the main TSO
 923    * may need to be linked onto other queues.
 924    */
 925   main_threads[next_main_thread] = main;
 926   MainTSO = &main_threads[next_main_thread];
 927   next_main_thread++;
 928   IF_DEBUG(scheduler,
 929            fprintf(stderr, "Scheduler entered: nesting = %d\n",
 930                    next_main_thread););
 931
 932   /* Are we being re-entered?
 933    */
 934   if (CurrentTSO != NULL) {
 935     /* This happens when a _ccall_gc from Haskell ends up re-entering
 936      * the scheduler.
 937      *
 938      * Block the current thread (put it on the ccalling_queue) and
 939      * continue executing.  The calling thread better have stashed
 940      * away its state properly and left its stack with a proper stack
 941      * frame on the top.
 942      */
 943     threadPaused(CurrentTSO);
 944     CurrentTSO->link = ccalling_threads;
 945     ccalling_threads = CurrentTSO;
 946     in_ccall_gc = rtsTrue;
 947     IF_DEBUG(scheduler,
 948              fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
 949                      CurrentTSO->id););
 950   } else {
 951     in_ccall_gc = rtsFalse;
 952   }
 953
 954   /* Take a thread from the run queue.
 955    */
 956   t = POP_RUN_QUEUE();
 957
 958   while (t != END_TSO_QUEUE) {
 959     CurrentTSO = t;
 960
 961     /* If we have more threads on the run queue, set up a context
 962      * switch at some point in the future.
 963      */
 964     if (run_queue_hd != END_TSO_QUEUE || blocked_queue_hd != END_TSO_QUEUE) {
 965       context_switch = 1;
 966     } else {
 967       context_switch = 0;
 968     }
 969     IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
 970
 971     /* Be friendly to the storage manager: we're about to *run* this
 972      * thread, so we better make sure the TSO is mutable.
 973      */
 974     if (t->mut_link == NULL) {
 975       recordMutable((StgMutClosure *)t);
 976     }
 977
 978     /* Run the current thread */
 979     switch (t->whatNext) {
 980     case ThreadKilled:
 981     case ThreadComplete:
 982       /* thread already killed.  Drop it and carry on. */
 983       goto next_thread;
 984     case ThreadEnterGHC:
 985       ret = StgRun((StgFunPtr) stg_enterStackTop);
 986       break;
 987     case ThreadRunGHC:
 988       ret = StgRun((StgFunPtr) stg_returnToStackTop);
 989       break;
 990     case ThreadEnterHugs:
 991 #ifdef INTERPRETER
 992       {
 993           IF_DEBUG(scheduler,belch("entering Hugs"));
 994           LoadThreadState();
 995           /* CHECK_SENSIBLE_REGS(); */
 996           {
 997               StgClosure* c = (StgClosure *)Sp[0];
 998               Sp += 1;
 999               ret = enter(c);
1000           }
1001           SaveThreadState();
1002           break;
1003       }
1004 #else
1005       barf("Panic: entered a BCO but no bytecode interpreter in this build");
1006 #endif
1007     default:
1008       barf("schedule: invalid whatNext field");
1009     }
1010
1011     /* We may have garbage collected while running the thread
1012      * (eg. something nefarious like _ccall_GC_ performGC), and hence
1013      * CurrentTSO may have moved.  Update t to reflect this.
1014      */
1015     t = CurrentTSO;
1016     CurrentTSO = NULL;
1017
1018     /* Costs for the scheduler are assigned to CCS_SYSTEM */
1019 #ifdef PROFILING
1020     CCCS = CCS_SYSTEM;
1021 #endif
1022
1023     switch (ret) {
1024
1025     case HeapOverflow:
1026       IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
1027       threadPaused(t);
1028       PUSH_ON_RUN_QUEUE(t);
1029       GarbageCollect(GetRoots);
1030       break;
1031
1032     case StackOverflow:
1033       IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
1034       {
1035         nat i;
1036         /* enlarge the stack */
1037         StgTSO *new_t = threadStackOverflow(t);
1038
1039         /* This TSO has moved, so update any pointers to it from the
1040          * main thread stack.  It better not be on any other queues...
1041          * (it shouldn't be)
1042          */
1043         for (i = 0; i < next_main_thread; i++) {
1044           if (main_threads[i] == t) {
1045             main_threads[i] = new_t;
1046           }
1047         }
1048         t = new_t;
1049       }
1050       PUSH_ON_RUN_QUEUE(t);
1051       break;
1052
1053     case ThreadYielding:
1054       IF_DEBUG(scheduler,
1055                if (t->whatNext == ThreadEnterHugs) {
1056                    /* ToDo: or maybe a timer expired when we were in Hugs?
1057                     * or maybe someone hit ctrl-C
1058                     */
1059                    belch("Thread %ld stopped to switch to Hugs\n", t->id);
1060                } else {
1061                    belch("Thread %ld stopped, timer expired\n", t->id);
1062                }
1063                );
1064       threadPaused(t);
1065       if (interrupted) {
1066           IF_DEBUG(scheduler,belch("Scheduler interrupted - returning"));
1067           deleteThread(t);
1068           while (run_queue_hd != END_TSO_QUEUE) {
1069               run_queue_hd = t->link;
1070               deleteThread(t);
1071           }
1072           run_queue_tl = END_TSO_QUEUE;
1073           /* ToDo: should I do the same with blocked queues? */
1074           return Interrupted;
1075       }
1076
1077       /* Put the thread back on the run queue, at the end.
1078        * t->link is already set to END_TSO_QUEUE.
1079        */
1080       APPEND_TO_RUN_QUEUE(t);
1081       break;
1082
1083     case ThreadBlocked:
1084       IF_DEBUG(scheduler,
1085                fprintf(stderr, "Thread %d stopped, ", t->id);
1086                printThreadBlockage(t);
1087                fprintf(stderr, "\n"));
1088       threadPaused(t);
1089       /* assume the thread has put itself on some blocked queue
1090        * somewhere.
1091        */
1092       break;
1093
1094     case ThreadFinished:
1095       IF_DEBUG(scheduler,fprintf(stderr,"thread %ld finished\n", t->id));
1096       t->whatNext = ThreadComplete;
1097       break;
1098
1099     default:
1100       barf("schedule: invalid thread return code");
1101     }
1102
1103     /* check for signals each time around the scheduler */
1104 #ifndef __MINGW32__
1105     if (signals_pending()) {
1106       start_signal_handlers();
1107     }
1108 #endif
1109     /* If our main thread has finished or been killed, return.
1110      * If we were re-entered as a result of a _ccall_gc, then
1111      * pop the blocked thread off the ccalling_threads stack back
1112      * into CurrentTSO.
1113      */
1114     if ((*MainTSO)->whatNext == ThreadComplete
1115         || (*MainTSO)->whatNext == ThreadKilled) {
1116       next_main_thread--;
1117       if (in_ccall_gc) {
1118         CurrentTSO = ccalling_threads;
1119         ccalling_threads = ccalling_threads->link;
1120         /* remember to stub the link field of CurrentTSO */
1121         CurrentTSO->link = END_TSO_QUEUE;
1122       }
1123       if ((*MainTSO)->whatNext == ThreadComplete) {
1124         /* we finished successfully, fill in the return value */
1125         if (ret_val) { *ret_val = (StgClosure *)(*MainTSO)->sp[0]; };
1126         return Success;
1127       } else {
1128         return Killed;
1129       }
1130     }
1131
1132   next_thread:
1133     /* Checked whether any waiting threads need to be woken up.
1134      * If the run queue is empty, we can wait indefinitely for
1135      * something to happen.
1136      */
1137     if (blocked_queue_hd != END_TSO_QUEUE) {
1138       awaitEvent(run_queue_hd == END_TSO_QUEUE);
1139     }
1140
1141     t = POP_RUN_QUEUE();
1142   }
1143
1144   /* If we got to here, then we ran out of threads to run, but the
1145    * main thread hasn't finished yet.  It must be blocked on an MVar
1146    * or a black hole somewhere, so we return deadlock.
1147    */
1148   return Deadlock;
1149 }
1150 #endif
1151
1152 /* -----------------------------------------------------------------------------
1153    Debugging: why is a thread blocked
1154    -------------------------------------------------------------------------- */
1155
1156 #ifdef DEBUG
1157 void printThreadBlockage(StgTSO *tso)
1158 {
1159   switch (tso->why_blocked) {
1160   case BlockedOnRead:
1161     fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
1162     break;
1163   case BlockedOnWrite:
1164     fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
1165     break;
1166   case BlockedOnDelay:
1167     fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
1168     break;
1169   case BlockedOnMVar:
1170     fprintf(stderr,"blocked on an MVar");
1171     break;
1172   case BlockedOnBlackHole:
1173     fprintf(stderr,"blocked on a black hole");
1174     break;
1175   case NotBlocked:
1176     fprintf(stderr,"not blocked");
1177     break;
1178   }
1179 }
1180 #endif
1181
1182 /* -----------------------------------------------------------------------------
1183    Where are the roots that we know about?
1184
1185         - all the threads on the runnable queue
1186         - all the threads on the blocked queue
1187         - all the thread currently executing a _ccall_GC
1188         - all the "main threads"
1189
1190    -------------------------------------------------------------------------- */
1191
1192 /* This has to be protected either by the scheduler monitor, or by the
1193         garbage collection monitor (probably the latter).
1194         KH @ 25/10/99
1195 */
1196
1197 static void GetRoots(void)
1198 {
1199   StgMainThread *m;
1200
1201   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1202   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1203
1204   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1205   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1206
1207   for (m = main_threads; m != NULL; m = m->link) {
1208     m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1209   }
1210   suspended_ccalling_threads =
1211     (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1212 }
1213
1214 /* -----------------------------------------------------------------------------
1215    performGC
1216
1217    This is the interface to the garbage collector from Haskell land.
1218    We provide this so that external C code can allocate and garbage
1219    collect when called from Haskell via _ccall_GC.
1220
1221    It might be useful to provide an interface whereby the programmer
1222    can specify more roots (ToDo).
1223
1224    This needs to be protected by the GC condition variable above.  KH.
1225    -------------------------------------------------------------------------- */
1226
1227 void (*extra_roots)(void);
1228
1229 void
1230 performGC(void)
1231 {
1232   GarbageCollect(GetRoots);
1233 }
1234
1235 static void
1236 AllRoots(void)
1237 {
1238   GetRoots();                   /* the scheduler's roots */
1239   extra_roots();                /* the user's roots */
1240 }
1241
1242 void
1243 performGCWithRoots(void (*get_roots)(void))
1244 {
1245   extra_roots = get_roots;
1246
1247   GarbageCollect(AllRoots);
1248 }
1249
1250 /* -----------------------------------------------------------------------------
1251    Stack overflow
1252
1253    If the thread has reached its maximum stack size,
1254    then bomb out.  Otherwise relocate the TSO into a larger chunk of
1255    memory and adjust its stack size appropriately.
1256    -------------------------------------------------------------------------- */
1257
1258 static StgTSO *
1259 threadStackOverflow(StgTSO *tso)
1260 {
1261   nat new_stack_size, new_tso_size, diff, stack_words;
1262   StgPtr new_sp;
1263   StgTSO *dest;
1264
1265   if (tso->stack_size >= tso->max_stack_size) {
1266 #if 0
1267     /* If we're debugging, just print out the top of the stack */
1268     printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1269                                      tso->sp+64));
1270 #endif
1271 #ifdef INTERPRETER
1272     fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1273     exit(1);
1274 #else
1275     /* Send this thread the StackOverflow exception */
1276     raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1277 #endif
1278     return tso;
1279   }
1280
1281   /* Try to double the current stack size.  If that takes us over the
1282    * maximum stack size for this thread, then use the maximum instead.
1283    * Finally round up so the TSO ends up as a whole number of blocks.
1284    */
1285   new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1286   new_tso_size   = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1287                                        TSO_STRUCT_SIZE)/sizeof(W_);
1288   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
1289   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1290
1291   IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1292
1293   dest = (StgTSO *)allocate(new_tso_size);
1294   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1295
1296   /* copy the TSO block and the old stack into the new area */
1297   memcpy(dest,tso,TSO_STRUCT_SIZE);
1298   stack_words = tso->stack + tso->stack_size - tso->sp;
1299   new_sp = (P_)dest + new_tso_size - stack_words;
1300   memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1301
1302   /* relocate the stack pointers... */
1303   diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1304   dest->su    = (StgUpdateFrame *) ((P_)dest->su + diff);
1305   dest->sp    = new_sp;
1306   dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1307   dest->stack_size = new_stack_size;
1308
1309   /* and relocate the update frame list */
1310   relocate_TSO(tso, dest);
1311
1312   /* Mark the old one as dead so we don't try to scavenge it during
1313    * garbage collection (the TSO will likely be on a mutables list in
1314    * some generation, but it'll get collected soon enough).  It's
1315    * important to set the sp and su values to just beyond the end of
1316    * the stack, so we don't attempt to scavenge any part of the dead
1317    * TSO's stack.
1318    */
1319   tso->whatNext = ThreadKilled;
1320   tso->sp = (P_)&(tso->stack[tso->stack_size]);
1321   tso->su = (StgUpdateFrame *)tso->sp;
1322   tso->why_blocked = NotBlocked;
1323   dest->mut_link = NULL;
1324
1325   IF_DEBUG(sanity,checkTSO(tso));
1326 #if 0
1327   IF_DEBUG(scheduler,printTSO(dest));
1328 #endif
1329
1330 #if 0
1331   /* This will no longer work: KH */
1332   if (tso == MainTSO) { /* hack */
1333       MainTSO = dest;
1334   }
1335 #endif
1336   return dest;
1337 }
1338
1339 /* -----------------------------------------------------------------------------
1340    Wake up a queue that was blocked on some resource.
1341    -------------------------------------------------------------------------- */
1342
1343 static StgTSO *
1344 unblockOneLocked(StgTSO *tso)
1345 {
1346   StgTSO *next;
1347
1348   ASSERT(get_itbl(tso)->type == TSO);
1349   ASSERT(tso->why_blocked != NotBlocked);
1350   tso->why_blocked = NotBlocked;
1351   next = tso->link;
1352   PUSH_ON_RUN_QUEUE(tso);
1353   THREAD_RUNNABLE();
1354 #ifdef SMP
1355   IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld",
1356                            pthread_self(), tso->id));
1357 #else
1358   IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
1359 #endif
1360   return next;
1361 }
1362
1363 inline StgTSO *
1364 unblockOne(StgTSO *tso)
1365 {
1366   ACQUIRE_LOCK(&sched_mutex);
1367   tso = unblockOneLocked(tso);
1368   RELEASE_LOCK(&sched_mutex);
1369   return tso;
1370 }
1371
1372 void
1373 awakenBlockedQueue(StgTSO *tso)
1374 {
1375   ACQUIRE_LOCK(&sched_mutex);
1376   while (tso != END_TSO_QUEUE) {
1377     tso = unblockOneLocked(tso);
1378   }
1379   RELEASE_LOCK(&sched_mutex);
1380 }
1381
1382 /* -----------------------------------------------------------------------------
1383    Interrupt execution
1384    - usually called inside a signal handler so it mustn't do anything fancy.
1385    -------------------------------------------------------------------------- */
1386
1387 void
1388 interruptStgRts(void)
1389 {
1390     interrupted    = 1;
1391     context_switch = 1;
1392 }
1393
1394 /* -----------------------------------------------------------------------------
1395    Unblock a thread
1396
1397    This is for use when we raise an exception in another thread, which
1398    may be blocked.
1399    -------------------------------------------------------------------------- */
1400
1401 static void
1402 unblockThread(StgTSO *tso)
1403 {
1404   StgTSO *t, **last;
1405
1406   ACQUIRE_LOCK(&sched_mutex);
1407   switch (tso->why_blocked) {
1408
1409   case NotBlocked:
1410     return;  /* not blocked */
1411
1412   case BlockedOnMVar:
1413     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
1414     {
1415       StgTSO *last_tso = END_TSO_QUEUE;
1416       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
1417
1418       last = &mvar->head;
1419       for (t = mvar->head; t != END_TSO_QUEUE;
1420            last = &t->link, last_tso = t, t = t->link) {
1421         if (t == tso) {
1422           *last = tso->link;
1423           if (mvar->tail == tso) {
1424             mvar->tail = last_tso;
1425           }
1426           goto done;
1427         }
1428       }
1429       barf("unblockThread (MVAR): TSO not found");
1430     }
1431
1432   case BlockedOnBlackHole:
1433     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
1434     {
1435       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
1436
1437       last = &bq->blocking_queue;
1438       for (t = bq->blocking_queue; t != END_TSO_QUEUE;
1439            last = &t->link, t = t->link) {
1440         if (t == tso) {
1441           *last = tso->link;
1442           goto done;
1443         }
1444       }
1445       barf("unblockThread (BLACKHOLE): TSO not found");
1446     }
1447
1448   case BlockedOnDelay:
1449   case BlockedOnRead:
1450   case BlockedOnWrite:
1451     {
1452       last = &blocked_queue_hd;
1453       for (t = blocked_queue_hd; t != END_TSO_QUEUE;
1454            last = &t->link, t = t->link) {
1455         if (t == tso) {
1456           *last = tso->link;
1457           if (blocked_queue_tl == t) {
1458             blocked_queue_tl = tso->link;
1459           }
1460           goto done;
1461         }
1462       }
1463       barf("unblockThread (I/O): TSO not found");
1464     }
1465
1466   default:
1467     barf("unblockThread");
1468   }
1469
1470  done:
1471   tso->link = END_TSO_QUEUE;
1472   tso->why_blocked = NotBlocked;
1473   tso->block_info.closure = NULL;
1474   PUSH_ON_RUN_QUEUE(tso);
1475   RELEASE_LOCK(&sched_mutex);
1476 }
1477
1478 /* -----------------------------------------------------------------------------
1479  * raiseAsync()
1480  *
1481  * The following function implements the magic for raising an
1482  * asynchronous exception in an existing thread.
1483  *
1484  * We first remove the thread from any queue on which it might be
1485  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
1486  *
1487  * We strip the stack down to the innermost CATCH_FRAME, building
1488  * thunks in the heap for all the active computations, so they can
1489  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
1490  * an application of the handler to the exception, and push it on
1491  * the top of the stack.
1492  *
1493  * How exactly do we save all the active computations?  We create an
1494  * AP_UPD for every UpdateFrame on the stack.  Entering one of these
1495  * AP_UPDs pushes everything from the corresponding update frame
1496  * upwards onto the stack.  (Actually, it pushes everything up to the
1497  * next update frame plus a pointer to the next AP_UPD object.
1498  * Entering the next AP_UPD object pushes more onto the stack until we
1499  * reach the last AP_UPD object - at which point the stack should look
1500  * exactly as it did when we killed the TSO and we can continue
1501  * execution by entering the closure on top of the stack.
1502  *
1503  * We can also kill a thread entirely - this happens if either (a) the
1504  * exception passed to raiseAsync is NULL, or (b) there's no
1505  * CATCH_FRAME on the stack.  In either case, we strip the entire
1506  * stack and replace the thread with a zombie.
1507  *
1508  * -------------------------------------------------------------------------- */
1509
1510 void
1511 deleteThread(StgTSO *tso)
1512 {
1513   raiseAsync(tso,NULL);
1514 }
1515
1516 void
1517 raiseAsync(StgTSO *tso, StgClosure *exception)
1518 {
1519   StgUpdateFrame* su = tso->su;
1520   StgPtr          sp = tso->sp;
1521
1522   /* Thread already dead? */
1523   if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
1524     return;
1525   }
1526
1527   IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
1528
1529   /* Remove it from any blocking queues */
1530   unblockThread(tso);
1531
1532   /* The stack freezing code assumes there's a closure pointer on
1533    * the top of the stack.  This isn't always the case with compiled
1534    * code, so we have to push a dummy closure on the top which just
1535    * returns to the next return address on the stack.
1536    */
1537   if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
1538     *(--sp) = (W_)&dummy_ret_closure;
1539   }
1540
1541   while (1) {
1542     int words = ((P_)su - (P_)sp) - 1;
1543     nat i;
1544     StgAP_UPD * ap;
1545
1546     /* If we find a CATCH_FRAME, and we've got an exception to raise,
1547      * then build PAP(handler,exception), and leave it on top of
1548      * the stack ready to enter.
1549      */
1550     if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
1551       StgCatchFrame *cf = (StgCatchFrame *)su;
1552       /* we've got an exception to raise, so let's pass it to the
1553        * handler in this frame.
1554        */
1555       ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
1556       TICK_ALLOC_UPD_PAP(2,0);
1557       SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
1558
1559       ap->n_args = 1;
1560       ap->fun = cf->handler;
1561       ap->payload[0] = (P_)exception;
1562
1563       /* sp currently points to the word above the CATCH_FRAME on the
1564        * stack.  Replace the CATCH_FRAME with a pointer to the new handler
1565        * application.
1566        */
1567       sp += sizeofW(StgCatchFrame);
1568       sp[0] = (W_)ap;
1569       tso->su = cf->link;
1570       tso->sp = sp;
1571       tso->whatNext = ThreadEnterGHC;
1572       return;
1573     }
1574
1575     /* First build an AP_UPD consisting of the stack chunk above the
1576      * current update frame, with the top word on the stack as the
1577      * fun field.
1578      */
1579     ap = (StgAP_UPD *)allocate(AP_sizeW(words));
1580
1581     ASSERT(words >= 0);
1582
1583     ap->n_args = words;
1584     ap->fun    = (StgClosure *)sp[0];
1585     sp++;
1586     for(i=0; i < (nat)words; ++i) {
1587       ap->payload[i] = (P_)*sp++;
1588     }
1589
1590     switch (get_itbl(su)->type) {
1591
1592     case UPDATE_FRAME:
1593       {
1594         SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
1595         TICK_ALLOC_UP_THK(words+1,0);
1596
1597         IF_DEBUG(scheduler,
1598                  fprintf(stderr,  "schedule: Updating ");
1599                  printPtr((P_)su->updatee);
1600                  fprintf(stderr,  " with ");
1601                  printObj((StgClosure *)ap);
1602                  );
1603
1604         /* Replace the updatee with an indirection - happily
1605          * this will also wake up any threads currently
1606          * waiting on the result.
1607          */
1608         UPD_IND(su->updatee,ap);  /* revert the black hole */
1609         su = su->link;
1610         sp += sizeofW(StgUpdateFrame) -1;
1611         sp[0] = (W_)ap; /* push onto stack */
1612         break;
1613       }
1614
1615     case CATCH_FRAME:
1616       {
1617         StgCatchFrame *cf = (StgCatchFrame *)su;
1618         StgClosure* o;
1619
1620         /* We want a PAP, not an AP_UPD.  Fortunately, the
1621          * layout's the same.
1622          */
1623         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1624         TICK_ALLOC_UPD_PAP(words+1,0);
1625
1626         /* now build o = FUN(catch,ap,handler) */
1627         o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
1628         TICK_ALLOC_FUN(2,0);
1629         SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
1630         o->payload[0] = (StgClosure *)ap;
1631         o->payload[1] = cf->handler;
1632
1633         IF_DEBUG(scheduler,
1634                  fprintf(stderr,  "schedule: Built ");
1635                  printObj((StgClosure *)o);
1636                  );
1637
1638         /* pop the old handler and put o on the stack */
1639         su = cf->link;
1640         sp += sizeofW(StgCatchFrame) - 1;
1641         sp[0] = (W_)o;
1642         break;
1643       }
1644
1645     case SEQ_FRAME:
1646       {
1647         StgSeqFrame *sf = (StgSeqFrame *)su;
1648         StgClosure* o;
1649
1650         SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1651         TICK_ALLOC_UPD_PAP(words+1,0);
1652
1653         /* now build o = FUN(seq,ap) */
1654         o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1655         TICK_ALLOC_SE_THK(1,0);
1656         SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
1657         payloadCPtr(o,0) = (StgClosure *)ap;
1658
1659         IF_DEBUG(scheduler,
1660                  fprintf(stderr,  "schedule: Built ");
1661                  printObj((StgClosure *)o);
1662                  );
1663
1664         /* pop the old handler and put o on the stack */
1665         su = sf->link;
1666         sp += sizeofW(StgSeqFrame) - 1;
1667         sp[0] = (W_)o;
1668         break;
1669       }
1670
1671     case STOP_FRAME:
1672       /* We've stripped the entire stack, the thread is now dead. */
1673       sp += sizeofW(StgStopFrame) - 1;
1674       sp[0] = (W_)exception;    /* save the exception */
1675       tso->whatNext = ThreadKilled;
1676       tso->su = (StgUpdateFrame *)(sp+1);
1677       tso->sp = sp;
1678       return;
1679
1680     default:
1681       barf("raiseAsync");
1682     }
1683   }
1684   barf("raiseAsync");
1685 }
1686