ghc/rts/Schedule.c

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