ghc/rts/Schedule.c

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