1 /* -----------------------------------------------------------------------------
2 * $Id: Schedule.c,v 1.35 1999/11/19 12:39:49 simonmar Exp $
4 * (c) The GHC Team, 1998-1999
8 * ---------------------------------------------------------------------------*/
10 /* Version with scheduler monitor support for SMPs.
12 This design provides a high-level API to create and schedule threads etc.
13 as documented in the SMP design document.
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
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).
25 In a non-SMP build, there is one global capability, namely MainRegTable.
36 #include "StgStartup.h"
40 #include "StgMiscClosures.h"
42 #include "Evaluator.h"
46 #include "Profiling.h"
52 * These are the threads which clients have requested that we run.
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.
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.
62 * Main threads information is kept in a linked list:
64 typedef struct StgMainThread_ {
69 pthread_cond_t wakeup;
71 struct StgMainThread_ *link;
75 * Locks required: sched_mutex.
77 static StgMainThread *main_threads;
80 * Locks required: sched_mutex.
82 StgTSO *run_queue_hd, *run_queue_tl;
83 StgTSO *blocked_queue_hd, *blocked_queue_tl;
85 /* Threads suspended in _ccall_GC.
86 * Locks required: sched_mutex.
88 static StgTSO *suspended_ccalling_threads;
90 static void GetRoots(void);
91 static StgTSO *threadStackOverflow(StgTSO *tso);
93 /* KH: The following two flags are shared memory locations. There is no need
94 to lock them, since they are only unset at the end of a scheduler
98 /* flag set by signal handler to precipitate a context switch */
100 /* if this flag is set as well, give up execution */
101 static nat interrupted;
103 /* Next thread ID to allocate.
104 * Locks required: sched_mutex
106 StgThreadID next_thread_id = 1;
109 * Pointers to the state of the current thread.
110 * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
111 * thread. If CurrentTSO == NULL, then we're at the scheduler level.
114 /* The smallest stack size that makes any sense is:
115 * RESERVED_STACK_WORDS (so we can get back from the stack overflow)
116 * + sizeofW(StgStopFrame) (the stg_stop_thread_info frame)
117 * + 1 (the realworld token for an IO thread)
118 * + 1 (the closure to enter)
120 * A thread with this stack will bomb immediately with a stack
121 * overflow, which will increase its stack size.
124 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
126 /* Free capability list.
127 * Locks required: sched_mutex.
130 Capability *free_capabilities; /* Available capabilities for running threads */
131 nat n_free_capabilities; /* total number of available capabilities */
133 Capability MainRegTable; /* for non-SMP, we have one global capability */
138 /* All our current task ids, saved in case we need to kill them later.
144 void addToBlockedQueue ( StgTSO *tso );
146 static void schedule ( void );
147 static void initThread ( StgTSO *tso, nat stack_size );
148 void interruptStgRts ( void );
151 pthread_mutex_t sched_mutex = PTHREAD_MUTEX_INITIALIZER;
152 pthread_mutex_t term_mutex = PTHREAD_MUTEX_INITIALIZER;
153 pthread_cond_t thread_ready_cond = PTHREAD_COND_INITIALIZER;
154 pthread_cond_t gc_pending_cond = PTHREAD_COND_INITIALIZER;
159 /* -----------------------------------------------------------------------------
160 Main scheduling loop.
162 We use round-robin scheduling, each thread returning to the
163 scheduler loop when one of these conditions is detected:
166 * timer expires (thread yields)
171 Locking notes: we acquire the scheduler lock once at the beginning
172 of the scheduler loop, and release it when
174 * running a thread, or
175 * waiting for work, or
176 * waiting for a GC to complete.
178 -------------------------------------------------------------------------- */
185 StgThreadReturnCode ret;
187 ACQUIRE_LOCK(&sched_mutex);
191 /* If we're interrupted (the user pressed ^C, or some other
192 * termination condition occurred), kill all the currently running
196 IF_DEBUG(scheduler,belch("schedule: interrupted"));
197 for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
200 for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
203 run_queue_hd = run_queue_tl = END_TSO_QUEUE;
204 blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
207 /* Go through the list of main threads and wake up any
208 * clients whose computations have finished. ToDo: this
209 * should be done more efficiently without a linear scan
210 * of the main threads list, somehow...
214 StgMainThread *m, **prev;
215 prev = &main_threads;
216 for (m = main_threads; m != NULL; m = m->link) {
217 if (m->tso->whatNext == ThreadComplete) {
219 *(m->ret) = (StgClosure *)m->tso->sp[0];
223 pthread_cond_broadcast(&m->wakeup);
225 if (m->tso->whatNext == ThreadKilled) {
228 pthread_cond_broadcast(&m->wakeup);
233 /* If our main thread has finished or been killed, return.
236 StgMainThread *m = main_threads;
237 if (m->tso->whatNext == ThreadComplete
238 || m->tso->whatNext == ThreadKilled) {
239 main_threads = main_threads->link;
240 if (m->tso->whatNext == ThreadComplete) {
241 /* we finished successfully, fill in the return value */
242 if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
253 /* Check whether any waiting threads need to be woken up. If the
254 * run queue is empty, and there are no other tasks running, we
255 * can wait indefinitely for something to happen.
256 * ToDo: what if another client comes along & requests another
259 if (blocked_queue_hd != END_TSO_QUEUE) {
261 (run_queue_hd == END_TSO_QUEUE)
263 && (n_free_capabilities == RtsFlags.ConcFlags.nNodes)
268 /* check for signals each time around the scheduler */
270 if (signals_pending()) {
271 start_signal_handlers();
275 /* Detect deadlock: when we have no threads to run, there are
276 * no threads waiting on I/O or sleeping, and all the other
277 * tasks are waiting for work, we must have a deadlock. Inform
278 * all the main threads.
281 if (blocked_queue_hd == END_TSO_QUEUE
282 && run_queue_hd == END_TSO_QUEUE
283 && (n_free_capabilities == RtsFlags.ConcFlags.nNodes)
286 for (m = main_threads; m != NULL; m = m->link) {
289 pthread_cond_broadcast(&m->wakeup);
294 if (blocked_queue_hd == END_TSO_QUEUE
295 && run_queue_hd == END_TSO_QUEUE) {
296 StgMainThread *m = main_threads;
299 main_threads = m->link;
305 /* If there's a GC pending, don't do anything until it has
309 IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): waiting for GC\n",
311 pthread_cond_wait(&gc_pending_cond, &sched_mutex);
314 /* block until we've got a thread on the run queue and a free
317 while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
319 fprintf(stderr, "schedule (task %ld): waiting for work\n",
321 pthread_cond_wait(&thread_ready_cond, &sched_mutex);
323 fprintf(stderr, "schedule (task %ld): work now available\n",
328 /* grab a thread from the run queue
335 cap = free_capabilities;
336 free_capabilities = cap->link;
337 n_free_capabilities--;
342 cap->rCurrentTSO = t;
344 /* set the context_switch flag
346 if (run_queue_hd == END_TSO_QUEUE)
351 RELEASE_LOCK(&sched_mutex);
354 IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): running thread %d\n", pthread_self(),t->id));
356 IF_DEBUG(scheduler,fprintf(stderr,"schedule: running thread %d\n",t->id));
359 /* Run the current thread
361 switch (cap->rCurrentTSO->whatNext) {
364 /* Thread already finished, return to scheduler. */
365 ret = ThreadFinished;
368 ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
371 ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
373 case ThreadEnterHugs:
377 IF_DEBUG(scheduler,belch("schedule: entering Hugs"));
378 c = (StgClosure *)(cap->rCurrentTSO->sp[0]);
379 cap->rCurrentTSO->sp += 1;
384 barf("Panic: entered a BCO but no bytecode interpreter in this build");
387 barf("schedule: invalid whatNext field");
390 /* Costs for the scheduler are assigned to CCS_SYSTEM */
395 ACQUIRE_LOCK(&sched_mutex);
398 IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): ", pthread_self()););
400 IF_DEBUG(scheduler,fprintf(stderr,"schedule: "););
402 t = cap->rCurrentTSO;
406 /* make all the running tasks block on a condition variable,
407 * maybe set context_switch and wait till they all pile in,
408 * then have them wait on a GC condition variable.
410 IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
413 ready_to_gc = rtsTrue;
414 context_switch = 1; /* stop other threads ASAP */
415 PUSH_ON_RUN_QUEUE(t);
419 /* just adjust the stack for this thread, then pop it back
422 IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
426 /* enlarge the stack */
427 StgTSO *new_t = threadStackOverflow(t);
429 /* This TSO has moved, so update any pointers to it from the
430 * main thread stack. It better not be on any other queues...
433 for (m = main_threads; m != NULL; m = m->link) {
438 PUSH_ON_RUN_QUEUE(new_t);
443 /* put the thread back on the run queue. Then, if we're ready to
444 * GC, check whether this is the last task to stop. If so, wake
445 * up the GC thread. getThread will block during a GC until the
449 if (t->whatNext == ThreadEnterHugs) {
450 /* ToDo: or maybe a timer expired when we were in Hugs?
451 * or maybe someone hit ctrl-C
453 belch("thread %ld stopped to switch to Hugs", t->id);
455 belch("thread %ld stopped, yielding", t->id);
459 APPEND_TO_RUN_QUEUE(t);
463 /* don't need to do anything. Either the thread is blocked on
464 * I/O, in which case we'll have called addToBlockedQueue
465 * previously, or it's blocked on an MVar or Blackhole, in which
466 * case it'll be on the relevant queue already.
469 fprintf(stderr, "thread %d stopped, ", t->id);
470 printThreadBlockage(t);
471 fprintf(stderr, "\n"));
476 /* Need to check whether this was a main thread, and if so, signal
477 * the task that started it with the return value. If we have no
478 * more main threads, we probably need to stop all the tasks until
481 IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
482 t->whatNext = ThreadComplete;
486 barf("doneThread: invalid thread return code");
490 cap->link = free_capabilities;
491 free_capabilities = cap;
492 n_free_capabilities++;
496 if (ready_to_gc && n_free_capabilities == RtsFlags.ConcFlags.nNodes) {
500 /* everybody back, start the GC.
501 * Could do it in this thread, or signal a condition var
502 * to do it in another thread. Either way, we need to
503 * broadcast on gc_pending_cond afterward.
506 IF_DEBUG(scheduler,belch("schedule (task %ld): doing GC", pthread_self()));
508 GarbageCollect(GetRoots);
509 ready_to_gc = rtsFalse;
511 pthread_cond_broadcast(&gc_pending_cond);
514 } /* end of while(1) */
518 /* A hack for Hugs concurrency support. Needs sanitisation (?) */
519 void deleteAllThreads ( void )
522 IF_DEBUG(scheduler,belch("deleteAllThreads()"));
523 for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) {
526 for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) {
529 run_queue_hd = run_queue_tl = END_TSO_QUEUE;
530 blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE;
534 /* -----------------------------------------------------------------------------
535 * Suspending & resuming Haskell threads.
537 * When making a "safe" call to C (aka _ccall_GC), the task gives back
538 * its capability before calling the C function. This allows another
539 * task to pick up the capability and carry on running Haskell
540 * threads. It also means that if the C call blocks, it won't lock
543 * The Haskell thread making the C call is put to sleep for the
544 * duration of the call, on the susepended_ccalling_threads queue. We
545 * give out a token to the task, which it can use to resume the thread
546 * on return from the C function.
547 * -------------------------------------------------------------------------- */
550 suspendThread( Capability *cap )
554 ACQUIRE_LOCK(&sched_mutex);
558 fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n",
559 pthread_self(), cap->rCurrentTSO->id));
562 fprintf(stderr, "schedule: thread %d did a _ccall_gc\n",
563 cap->rCurrentTSO->id));
566 threadPaused(cap->rCurrentTSO);
567 cap->rCurrentTSO->link = suspended_ccalling_threads;
568 suspended_ccalling_threads = cap->rCurrentTSO;
570 /* Use the thread ID as the token; it should be unique */
571 tok = cap->rCurrentTSO->id;
574 cap->link = free_capabilities;
575 free_capabilities = cap;
576 n_free_capabilities++;
579 RELEASE_LOCK(&sched_mutex);
584 resumeThread( StgInt tok )
589 ACQUIRE_LOCK(&sched_mutex);
591 prev = &suspended_ccalling_threads;
592 for (tso = suspended_ccalling_threads;
593 tso != END_TSO_QUEUE;
594 prev = &tso->link, tso = tso->link) {
595 if (tso->id == (StgThreadID)tok) {
600 if (tso == END_TSO_QUEUE) {
601 barf("resumeThread: thread not found");
605 while (free_capabilities == NULL) {
607 fprintf(stderr,"schedule (task %ld): waiting to resume\n",
609 pthread_cond_wait(&thread_ready_cond, &sched_mutex);
610 IF_DEBUG(scheduler,fprintf(stderr,
611 "schedule (task %ld): resuming thread %d\n",
612 pthread_self(), tso->id));
614 cap = free_capabilities;
615 free_capabilities = cap->link;
616 n_free_capabilities--;
621 cap->rCurrentTSO = tso;
623 RELEASE_LOCK(&sched_mutex);
627 /* -----------------------------------------------------------------------------
629 * -------------------------------------------------------------------------- */
630 static void unblockThread(StgTSO *tso);
632 /* -----------------------------------------------------------------------------
633 * Comparing Thread ids.
635 * This is used from STG land in the implementation of the
636 * instances of Eq/Ord for ThreadIds.
637 * -------------------------------------------------------------------------- */
639 int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
641 StgThreadID id1 = tso1->id;
642 StgThreadID id2 = tso2->id;
644 if (id1 < id2) return (-1);
645 if (id1 > id2) return 1;
649 /* -----------------------------------------------------------------------------
652 The new thread starts with the given stack size. Before the
653 scheduler can run, however, this thread needs to have a closure
654 (and possibly some arguments) pushed on its stack. See
655 pushClosure() in Schedule.h.
657 createGenThread() and createIOThread() (in SchedAPI.h) are
658 convenient packaged versions of this function.
659 -------------------------------------------------------------------------- */
662 createThread(nat stack_size)
666 /* catch ridiculously small stack sizes */
667 if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
668 stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
671 tso = (StgTSO *)allocate(stack_size);
672 TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
674 initThread(tso, stack_size - TSO_STRUCT_SIZEW);
679 initThread(StgTSO *tso, nat stack_size)
681 SET_HDR(tso, &TSO_info, CCS_MAIN);
682 tso->whatNext = ThreadEnterGHC;
684 /* tso->id needs to be unique. For now we use a heavyweight mutex to
685 protect the increment operation on next_thread_id.
686 In future, we could use an atomic increment instead.
689 ACQUIRE_LOCK(&sched_mutex);
690 tso->id = next_thread_id++;
691 RELEASE_LOCK(&sched_mutex);
693 tso->why_blocked = NotBlocked;
695 tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
696 tso->stack_size = stack_size;
697 tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
699 tso->sp = (P_)&(tso->stack) + stack_size;
702 tso->prof.CCCS = CCS_MAIN;
705 /* put a stop frame on the stack */
706 tso->sp -= sizeofW(StgStopFrame);
707 SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
708 tso->su = (StgUpdateFrame*)tso->sp;
710 IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words",
711 tso->id, tso->stack_size));
716 /* -----------------------------------------------------------------------------
719 * scheduleThread puts a thread on the head of the runnable queue.
720 * This will usually be done immediately after a thread is created.
721 * The caller of scheduleThread must create the thread using e.g.
722 * createThread and push an appropriate closure
723 * on this thread's stack before the scheduler is invoked.
724 * -------------------------------------------------------------------------- */
727 scheduleThread(StgTSO *tso)
729 ACQUIRE_LOCK(&sched_mutex);
731 /* Put the new thread on the head of the runnable queue. The caller
732 * better push an appropriate closure on this thread's stack
733 * beforehand. In the SMP case, the thread may start running as
734 * soon as we release the scheduler lock below.
736 PUSH_ON_RUN_QUEUE(tso);
739 IF_DEBUG(scheduler,printTSO(tso));
740 RELEASE_LOCK(&sched_mutex);
744 /* -----------------------------------------------------------------------------
747 * Start up Posix threads to run each of the scheduler tasks.
748 * I believe the task ids are not needed in the system as defined.
750 * -------------------------------------------------------------------------- */
754 taskStart( void *arg STG_UNUSED )
761 /* -----------------------------------------------------------------------------
764 * Initialise the scheduler. This resets all the queues - if the
765 * queues contained any threads, they'll be garbage collected at the
768 * This now calls startTasks(), so should only be called once! KH @ 25/10/99
769 * -------------------------------------------------------------------------- */
773 term_handler(int sig STG_UNUSED)
776 ACQUIRE_LOCK(&term_mutex);
778 RELEASE_LOCK(&term_mutex);
783 void initScheduler(void)
785 run_queue_hd = END_TSO_QUEUE;
786 run_queue_tl = END_TSO_QUEUE;
787 blocked_queue_hd = END_TSO_QUEUE;
788 blocked_queue_tl = END_TSO_QUEUE;
790 suspended_ccalling_threads = END_TSO_QUEUE;
797 enteredCAFs = END_CAF_LIST;
799 /* Install the SIGHUP handler */
802 struct sigaction action,oact;
804 action.sa_handler = term_handler;
805 sigemptyset(&action.sa_mask);
807 if (sigaction(SIGTERM, &action, &oact) != 0) {
808 barf("can't install TERM handler");
814 /* Allocate N Capabilities */
817 Capability *cap, *prev;
820 for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
821 cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
825 free_capabilities = cap;
826 n_free_capabilities = RtsFlags.ConcFlags.nNodes;
828 IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
829 n_free_capabilities););
841 /* make some space for saving all the thread ids */
842 task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
843 "initScheduler:task_ids");
845 /* and create all the threads */
846 for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
847 r = pthread_create(&tid,NULL,taskStart,NULL);
849 barf("startTasks: Can't create new Posix thread");
851 task_ids[i].id = tid;
852 task_ids[i].mut_time = 0.0;
853 task_ids[i].mut_etime = 0.0;
854 task_ids[i].gc_time = 0.0;
855 task_ids[i].gc_etime = 0.0;
856 task_ids[i].elapsedtimestart = elapsedtime();
857 IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
863 exitScheduler( void )
868 /* Don't want to use pthread_cancel, since we'd have to install
869 * these silly exception handlers (pthread_cleanup_{push,pop}) around
873 /* Cancel all our tasks */
874 for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
875 pthread_cancel(task_ids[i].id);
878 /* Wait for all the tasks to terminate */
879 for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
880 IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n",
882 pthread_join(task_ids[i].id, NULL);
886 /* Send 'em all a SIGHUP. That should shut 'em up.
888 await_death = RtsFlags.ConcFlags.nNodes;
889 for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
890 pthread_kill(task_ids[i].id,SIGTERM);
892 while (await_death > 0) {
898 /* -----------------------------------------------------------------------------
899 Managing the per-task allocation areas.
901 Each capability comes with an allocation area. These are
902 fixed-length block lists into which allocation can be done.
904 ToDo: no support for two-space collection at the moment???
905 -------------------------------------------------------------------------- */
907 /* -----------------------------------------------------------------------------
908 * waitThread is the external interface for running a new computataion
909 * and waiting for the result.
911 * In the non-SMP case, we create a new main thread, push it on the
912 * main-thread stack, and invoke the scheduler to run it. The
913 * scheduler will return when the top main thread on the stack has
914 * completed or died, and fill in the necessary fields of the
915 * main_thread structure.
917 * In the SMP case, we create a main thread as before, but we then
918 * create a new condition variable and sleep on it. When our new
919 * main thread has completed, we'll be woken up and the status/result
920 * will be in the main_thread struct.
921 * -------------------------------------------------------------------------- */
924 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
927 SchedulerStatus stat;
929 ACQUIRE_LOCK(&sched_mutex);
931 m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
937 pthread_cond_init(&m->wakeup, NULL);
940 m->link = main_threads;
943 IF_DEBUG(scheduler, fprintf(stderr, "schedule: new main thread (%d)\n",
948 pthread_cond_wait(&m->wakeup, &sched_mutex);
949 } while (m->stat == NoStatus);
952 ASSERT(m->stat != NoStatus);
958 pthread_cond_destroy(&m->wakeup);
962 RELEASE_LOCK(&sched_mutex);
966 /* -----------------------------------------------------------------------------
967 Debugging: why is a thread blocked
968 -------------------------------------------------------------------------- */
971 void printThreadBlockage(StgTSO *tso)
973 switch (tso->why_blocked) {
975 fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
978 fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
981 fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
984 fprintf(stderr,"blocked on an MVar");
986 case BlockedOnBlackHole:
987 fprintf(stderr,"blocked on a black hole");
990 fprintf(stderr,"not blocked");
996 /* -----------------------------------------------------------------------------
997 Where are the roots that we know about?
999 - all the threads on the runnable queue
1000 - all the threads on the blocked queue
1001 - all the thread currently executing a _ccall_GC
1002 - all the "main threads"
1004 -------------------------------------------------------------------------- */
1006 /* This has to be protected either by the scheduler monitor, or by the
1007 garbage collection monitor (probably the latter).
1011 static void GetRoots(void)
1015 run_queue_hd = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
1016 run_queue_tl = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
1018 blocked_queue_hd = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
1019 blocked_queue_tl = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
1021 for (m = main_threads; m != NULL; m = m->link) {
1022 m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
1024 suspended_ccalling_threads =
1025 (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
1028 /* -----------------------------------------------------------------------------
1031 This is the interface to the garbage collector from Haskell land.
1032 We provide this so that external C code can allocate and garbage
1033 collect when called from Haskell via _ccall_GC.
1035 It might be useful to provide an interface whereby the programmer
1036 can specify more roots (ToDo).
1038 This needs to be protected by the GC condition variable above. KH.
1039 -------------------------------------------------------------------------- */
1041 void (*extra_roots)(void);
1046 GarbageCollect(GetRoots);
1052 GetRoots(); /* the scheduler's roots */
1053 extra_roots(); /* the user's roots */
1057 performGCWithRoots(void (*get_roots)(void))
1059 extra_roots = get_roots;
1061 GarbageCollect(AllRoots);
1064 /* -----------------------------------------------------------------------------
1067 If the thread has reached its maximum stack size,
1068 then bomb out. Otherwise relocate the TSO into a larger chunk of
1069 memory and adjust its stack size appropriately.
1070 -------------------------------------------------------------------------- */
1073 threadStackOverflow(StgTSO *tso)
1075 nat new_stack_size, new_tso_size, diff, stack_words;
1079 if (tso->stack_size >= tso->max_stack_size) {
1081 /* If we're debugging, just print out the top of the stack */
1082 printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
1086 fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
1089 /* Send this thread the StackOverflow exception */
1090 raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
1095 /* Try to double the current stack size. If that takes us over the
1096 * maximum stack size for this thread, then use the maximum instead.
1097 * Finally round up so the TSO ends up as a whole number of blocks.
1099 new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
1100 new_tso_size = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
1101 TSO_STRUCT_SIZE)/sizeof(W_);
1102 new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */
1103 new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
1105 IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
1107 dest = (StgTSO *)allocate(new_tso_size);
1108 TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
1110 /* copy the TSO block and the old stack into the new area */
1111 memcpy(dest,tso,TSO_STRUCT_SIZE);
1112 stack_words = tso->stack + tso->stack_size - tso->sp;
1113 new_sp = (P_)dest + new_tso_size - stack_words;
1114 memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
1116 /* relocate the stack pointers... */
1117 diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
1118 dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
1120 dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
1121 dest->stack_size = new_stack_size;
1123 /* and relocate the update frame list */
1124 relocate_TSO(tso, dest);
1126 /* Mark the old one as dead so we don't try to scavenge it during
1127 * garbage collection (the TSO will likely be on a mutables list in
1128 * some generation, but it'll get collected soon enough). It's
1129 * important to set the sp and su values to just beyond the end of
1130 * the stack, so we don't attempt to scavenge any part of the dead
1133 tso->whatNext = ThreadKilled;
1134 tso->sp = (P_)&(tso->stack[tso->stack_size]);
1135 tso->su = (StgUpdateFrame *)tso->sp;
1136 tso->why_blocked = NotBlocked;
1137 dest->mut_link = NULL;
1139 IF_DEBUG(sanity,checkTSO(tso));
1141 IF_DEBUG(scheduler,printTSO(dest));
1145 /* This will no longer work: KH */
1146 if (tso == MainTSO) { /* hack */
1153 /* -----------------------------------------------------------------------------
1154 Wake up a queue that was blocked on some resource.
1155 -------------------------------------------------------------------------- */
1158 unblockOneLocked(StgTSO *tso)
1162 ASSERT(get_itbl(tso)->type == TSO);
1163 ASSERT(tso->why_blocked != NotBlocked);
1164 tso->why_blocked = NotBlocked;
1166 PUSH_ON_RUN_QUEUE(tso);
1169 IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld",
1170 pthread_self(), tso->id));
1172 IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
1178 unblockOne(StgTSO *tso)
1180 ACQUIRE_LOCK(&sched_mutex);
1181 tso = unblockOneLocked(tso);
1182 RELEASE_LOCK(&sched_mutex);
1187 awakenBlockedQueue(StgTSO *tso)
1189 ACQUIRE_LOCK(&sched_mutex);
1190 while (tso != END_TSO_QUEUE) {
1191 tso = unblockOneLocked(tso);
1193 RELEASE_LOCK(&sched_mutex);
1196 /* -----------------------------------------------------------------------------
1198 - usually called inside a signal handler so it mustn't do anything fancy.
1199 -------------------------------------------------------------------------- */
1202 interruptStgRts(void)
1208 /* -----------------------------------------------------------------------------
1211 This is for use when we raise an exception in another thread, which
1213 -------------------------------------------------------------------------- */
1216 unblockThread(StgTSO *tso)
1220 ACQUIRE_LOCK(&sched_mutex);
1221 switch (tso->why_blocked) {
1224 return; /* not blocked */
1227 ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
1229 StgTSO *last_tso = END_TSO_QUEUE;
1230 StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
1233 for (t = mvar->head; t != END_TSO_QUEUE;
1234 last = &t->link, last_tso = t, t = t->link) {
1237 if (mvar->tail == tso) {
1238 mvar->tail = last_tso;
1243 barf("unblockThread (MVAR): TSO not found");
1246 case BlockedOnBlackHole:
1247 ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
1249 StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
1251 last = &bq->blocking_queue;
1252 for (t = bq->blocking_queue; t != END_TSO_QUEUE;
1253 last = &t->link, t = t->link) {
1259 barf("unblockThread (BLACKHOLE): TSO not found");
1262 case BlockedOnDelay:
1264 case BlockedOnWrite:
1266 StgTSO *prev = NULL;
1267 for (t = blocked_queue_hd; t != END_TSO_QUEUE;
1268 prev = t, t = t->link) {
1271 blocked_queue_hd = t->link;
1272 if (blocked_queue_tl == t) {
1273 blocked_queue_tl = END_TSO_QUEUE;
1276 prev->link = t->link;
1277 if (blocked_queue_tl == t) {
1278 blocked_queue_tl = prev;
1284 barf("unblockThread (I/O): TSO not found");
1288 barf("unblockThread");
1292 tso->link = END_TSO_QUEUE;
1293 tso->why_blocked = NotBlocked;
1294 tso->block_info.closure = NULL;
1295 PUSH_ON_RUN_QUEUE(tso);
1296 RELEASE_LOCK(&sched_mutex);
1299 /* -----------------------------------------------------------------------------
1302 * The following function implements the magic for raising an
1303 * asynchronous exception in an existing thread.
1305 * We first remove the thread from any queue on which it might be
1306 * blocked. The possible blockages are MVARs and BLACKHOLE_BQs.
1308 * We strip the stack down to the innermost CATCH_FRAME, building
1309 * thunks in the heap for all the active computations, so they can
1310 * be restarted if necessary. When we reach a CATCH_FRAME, we build
1311 * an application of the handler to the exception, and push it on
1312 * the top of the stack.
1314 * How exactly do we save all the active computations? We create an
1315 * AP_UPD for every UpdateFrame on the stack. Entering one of these
1316 * AP_UPDs pushes everything from the corresponding update frame
1317 * upwards onto the stack. (Actually, it pushes everything up to the
1318 * next update frame plus a pointer to the next AP_UPD object.
1319 * Entering the next AP_UPD object pushes more onto the stack until we
1320 * reach the last AP_UPD object - at which point the stack should look
1321 * exactly as it did when we killed the TSO and we can continue
1322 * execution by entering the closure on top of the stack.
1324 * We can also kill a thread entirely - this happens if either (a) the
1325 * exception passed to raiseAsync is NULL, or (b) there's no
1326 * CATCH_FRAME on the stack. In either case, we strip the entire
1327 * stack and replace the thread with a zombie.
1329 * -------------------------------------------------------------------------- */
1332 deleteThread(StgTSO *tso)
1334 raiseAsync(tso,NULL);
1338 raiseAsync(StgTSO *tso, StgClosure *exception)
1340 StgUpdateFrame* su = tso->su;
1341 StgPtr sp = tso->sp;
1343 /* Thread already dead? */
1344 if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
1348 IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
1350 /* Remove it from any blocking queues */
1353 /* The stack freezing code assumes there's a closure pointer on
1354 * the top of the stack. This isn't always the case with compiled
1355 * code, so we have to push a dummy closure on the top which just
1356 * returns to the next return address on the stack.
1358 if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
1359 *(--sp) = (W_)&dummy_ret_closure;
1363 int words = ((P_)su - (P_)sp) - 1;
1367 /* If we find a CATCH_FRAME, and we've got an exception to raise,
1368 * then build PAP(handler,exception), and leave it on top of
1369 * the stack ready to enter.
1371 if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
1372 StgCatchFrame *cf = (StgCatchFrame *)su;
1373 /* we've got an exception to raise, so let's pass it to the
1374 * handler in this frame.
1376 ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
1377 TICK_ALLOC_UPD_PAP(2,0);
1378 SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
1381 ap->fun = cf->handler;
1382 ap->payload[0] = (P_)exception;
1384 /* sp currently points to the word above the CATCH_FRAME on the
1385 * stack. Replace the CATCH_FRAME with a pointer to the new handler
1388 sp += sizeofW(StgCatchFrame);
1392 tso->whatNext = ThreadEnterGHC;
1396 /* First build an AP_UPD consisting of the stack chunk above the
1397 * current update frame, with the top word on the stack as the
1400 ap = (StgAP_UPD *)allocate(AP_sizeW(words));
1405 ap->fun = (StgClosure *)sp[0];
1407 for(i=0; i < (nat)words; ++i) {
1408 ap->payload[i] = (P_)*sp++;
1411 switch (get_itbl(su)->type) {
1415 SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
1416 TICK_ALLOC_UP_THK(words+1,0);
1419 fprintf(stderr, "schedule: Updating ");
1420 printPtr((P_)su->updatee);
1421 fprintf(stderr, " with ");
1422 printObj((StgClosure *)ap);
1425 /* Replace the updatee with an indirection - happily
1426 * this will also wake up any threads currently
1427 * waiting on the result.
1429 UPD_IND_NOLOCK(su->updatee,ap); /* revert the black hole */
1431 sp += sizeofW(StgUpdateFrame) -1;
1432 sp[0] = (W_)ap; /* push onto stack */
1438 StgCatchFrame *cf = (StgCatchFrame *)su;
1441 /* We want a PAP, not an AP_UPD. Fortunately, the
1442 * layout's the same.
1444 SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1445 TICK_ALLOC_UPD_PAP(words+1,0);
1447 /* now build o = FUN(catch,ap,handler) */
1448 o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
1449 TICK_ALLOC_FUN(2,0);
1450 SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
1451 o->payload[0] = (StgClosure *)ap;
1452 o->payload[1] = cf->handler;
1455 fprintf(stderr, "schedule: Built ");
1456 printObj((StgClosure *)o);
1459 /* pop the old handler and put o on the stack */
1461 sp += sizeofW(StgCatchFrame) - 1;
1468 StgSeqFrame *sf = (StgSeqFrame *)su;
1471 SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
1472 TICK_ALLOC_UPD_PAP(words+1,0);
1474 /* now build o = FUN(seq,ap) */
1475 o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
1476 TICK_ALLOC_SE_THK(1,0);
1477 SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
1478 payloadCPtr(o,0) = (StgClosure *)ap;
1481 fprintf(stderr, "schedule: Built ");
1482 printObj((StgClosure *)o);
1485 /* pop the old handler and put o on the stack */
1487 sp += sizeofW(StgSeqFrame) - 1;
1493 /* We've stripped the entire stack, the thread is now dead. */
1494 sp += sizeofW(StgStopFrame) - 1;
1495 sp[0] = (W_)exception; /* save the exception */
1496 tso->whatNext = ThreadKilled;
1497 tso->su = (StgUpdateFrame *)(sp+1);