1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
45 /* This file implements nice Scheme level threads on top of the gastly
54 #include "libguile/_scm.h"
55 #include "libguile/validate.h"
56 #include "libguile/root.h"
57 #include "libguile/eval.h"
58 #include "libguile/async.h"
59 #include "libguile/ports.h"
60 #include "libguile/threads.h"
61 #include "libguile/dynwind.h"
62 #include "libguile/iselect.h"
69 return scm_cons (SCM_EOL
, SCM_EOL
);
73 enqueue (SCM q
, SCM t
)
75 SCM c
= scm_cons (t
, SCM_EOL
);
76 if (SCM_NULLP (SCM_CDR (q
)))
79 SCM_SETCDR (SCM_CAR (q
), c
);
85 remqueue (SCM q
, SCM c
)
88 for (p
= SCM_CDR (q
); !SCM_NULLP (p
); p
= SCM_CDR (p
))
92 if (SCM_EQ_P (c
, SCM_CAR (q
)))
93 SCM_SETCAR (q
, SCM_CDR (c
));
94 SCM_SETCDR (prev
, SCM_CDR (c
));
110 SCM_SETCDR (q
, SCM_CDR (c
));
111 if (SCM_NULLP (SCM_CDR (q
)))
112 SCM_SETCAR (q
, SCM_EOL
);
119 #define THREAD_INITIALIZED_P(t) (t->base != NULL)
125 scm_t_cond sleep_cond
;
126 struct scm_thread
*next_waiting
;
128 /* This mutex represents this threads right to access the heap.
129 That right can temporarily be taken away by the GC. */
130 scm_t_mutex heap_mutex
;
131 int clear_freelists_p
; /* set if GC was done while thread was asleep */
133 scm_root_state
*root
;
141 /* For keeping track of the stack and registers. */
149 make_thread (SCM creation_protects
)
153 z
= scm_make_smob (scm_tc16_thread
);
154 t
= SCM_THREAD_DATA (z
);
156 t
->result
= creation_protects
;
158 t
->joining_threads
= make_queue ();
159 scm_i_plugin_cond_init (&t
->sleep_cond
, 0);
160 scm_i_plugin_mutex_init (&t
->heap_mutex
, 0);
161 t
->clear_freelists_p
= 0;
167 init_thread_creatant (SCM thread
,
170 scm_thread
*t
= SCM_THREAD_DATA (thread
);
171 t
->thread
= scm_thread_self ();
177 thread_mark (SCM obj
)
179 scm_thread
*t
= SCM_THREAD_DATA (obj
);
180 scm_gc_mark (t
->result
);
181 scm_gc_mark (t
->joining_threads
);
182 return t
->root
->handle
; /* mark root-state of this thread */
186 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
188 scm_thread
*t
= SCM_THREAD_DATA (exp
);
189 scm_puts ("#<thread ", port
);
190 scm_intprint ((unsigned long)t
, 16, port
);
191 scm_putc ('>', port
);
196 thread_free (SCM obj
)
198 scm_thread
*t
= SCM_THREAD_DATA (obj
);
201 scm_gc_free (t
, sizeof (*t
), "thread");
207 #define cur_thread (SCM_CURRENT_THREAD->handle)
208 scm_t_key scm_i_thread_key
;
209 scm_t_key scm_i_root_state_key
;
212 scm_i_set_thread_data (void *data
)
214 scm_thread
*t
= SCM_CURRENT_THREAD
;
215 scm_setspecific (scm_i_root_state_key
, data
);
216 t
->root
= (scm_root_state
*)data
;
220 resume (scm_thread
*t
)
223 if (t
->clear_freelists_p
)
225 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
226 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
227 t
->clear_freelists_p
= 0;
232 scm_i_enter_guile (scm_thread
*t
)
234 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
241 scm_thread
*c
= SCM_CURRENT_THREAD
;
243 /* record top of stack for the GC */
244 c
->top
= (SCM_STACKITEM
*)&c
;
245 /* save registers. */
246 SCM_FLUSH_REGISTER_WINDOWS
;
255 scm_thread
*t
= suspend ();
256 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
260 /* Put the current thread to sleep until it is explicitely unblocked.
266 scm_thread
*t
= suspend ();
267 err
= scm_i_plugin_cond_wait (&t
->sleep_cond
, &t
->heap_mutex
);
272 /* Put the current thread to sleep until it is explicitely unblocked
273 or until a signal arrives or until time AT (absolute time) is
274 reached. Return 0 when it has been unblocked; errno otherwise.
277 timed_block (const struct timespec
*at
)
280 scm_thread
*t
= suspend ();
281 err
= scm_i_plugin_cond_timedwait (&t
->sleep_cond
, &t
->heap_mutex
, at
);
286 /* Unblock a sleeping thread.
289 unblock (scm_thread
*t
)
291 scm_i_plugin_cond_signal (&t
->sleep_cond
);
294 /*** Thread creation */
296 static scm_t_mutex thread_admin_mutex
;
297 static SCM all_threads
;
298 static int thread_count
;
300 typedef struct launch_data
{
303 scm_t_catch_body body
;
305 scm_t_catch_handler handler
;
310 body_bootstrip (launch_data
* data
)
312 /* First save the new root continuation */
313 data
->rootcont
= scm_root
->rootcont
;
314 return (data
->body
) (data
->body_data
);
318 handler_bootstrip (launch_data
* data
, SCM tag
, SCM throw_args
)
320 scm_root
->rootcont
= data
->rootcont
;
321 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
325 really_launch (SCM_STACKITEM
*base
, launch_data
*data
)
329 thread
= data
->thread
;
330 t
= SCM_THREAD_DATA (thread
);
331 SCM_FREELIST_CREATE (scm_i_freelist
);
332 SCM_FREELIST_CREATE (scm_i_freelist2
);
333 scm_setspecific (scm_i_thread_key
, t
);
334 scm_setspecific (scm_i_root_state_key
, t
->root
);
335 scm_i_plugin_mutex_lock (&t
->heap_mutex
); /* ensure that we "own" the heap */
336 init_thread_creatant (thread
, base
); /* must own the heap */
338 data
->rootcont
= SCM_BOOL_F
;
340 scm_internal_cwdr ((scm_t_catch_body
) body_bootstrip
,
342 (scm_t_catch_handler
) handler_bootstrip
,
346 scm_thread_detach (t
->thread
);
347 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
348 all_threads
= scm_delq_x (thread
, all_threads
);
351 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
352 /* We're leaving with heap_mutex still locked. */
356 launch_thread (void *p
)
358 really_launch ((SCM_STACKITEM
*)&p
, (launch_data
*)p
);
363 create_thread (scm_t_catch_body body
, void *body_data
,
364 scm_t_catch_handler handler
, void *handler_data
,
369 /* Make new thread. The first thing the new thread will do is to
370 lock guile_mutex. Thus, we can safely complete its
371 initialization after creating it. While the new thread starts,
372 all its data is protected via all_threads.
377 SCM root
, old_winds
, new_threads
;
382 /* Unwind wind chain. */
383 old_winds
= scm_dynwinds
;
384 scm_dowinds (SCM_EOL
, scm_ilength (scm_root
->dynwinds
));
386 /* Allocate thread locals. */
387 root
= scm_make_root (scm_root
->handle
);
388 data
= scm_malloc (sizeof (launch_data
));
391 thread
= make_thread (protects
);
392 data
->thread
= thread
;
394 data
->body_data
= body_data
;
395 data
->handler
= handler
;
396 data
->handler_data
= handler_data
;
397 t
= SCM_THREAD_DATA (thread
);
398 /* must initialize root state pointer before the thread is linked
400 t
->root
= SCM_ROOT_STATE (root
);
402 /* In order to avoid the need of synchronization between parent
403 and child thread, we need to insert the child into all_threads
405 new_threads
= scm_cons (thread
, SCM_BOOL_F
); /* could cause GC */
406 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
407 SCM_SETCDR (new_threads
, all_threads
);
408 all_threads
= new_threads
;
410 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
412 err
= scm_i_plugin_thread_create (&th
, 0, launch_thread
, (void *) data
);
415 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
416 all_threads
= scm_delq_x (thread
, all_threads
);
417 ((scm_thread
*) SCM_THREAD_DATA(thread
))->exited
= 1;
419 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
422 /* Return to old dynamic context. */
423 scm_dowinds (old_winds
, - scm_ilength (old_winds
));
428 scm_syserror ("create-thread");
435 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 2, 0, 0,
436 (SCM thunk
, SCM handler
),
437 "Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
438 "returning a new thread object representing the thread. "
439 "If an error occurs during evaluation, call error-thunk, passing it an "
440 "error code describing the condition. "
441 "If this happens, the error-thunk is called outside the scope of the new "
442 "root -- it is called in the same dynamic context in which "
443 "with-new-thread was evaluated, but not in the callers thread. "
444 "All the evaluation rules for dynamic roots apply to threads.")
445 #define FUNC_NAME s_scm_call_with_new_thread
447 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
448 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)), handler
, SCM_ARG2
,
451 return create_thread ((scm_t_catch_body
) scm_call_0
, thunk
,
452 (scm_t_catch_handler
) scm_apply_1
, handler
,
453 scm_cons (thunk
, handler
));
457 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
459 "Suspend execution of the calling thread until the target @var{thread} "
460 "terminates, unless the target @var{thread} has already terminated. ")
461 #define FUNC_NAME s_scm_join_thread
466 SCM_VALIDATE_THREAD (1, thread
);
467 if (SCM_EQ_P (cur_thread
, thread
))
468 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
470 t
= SCM_THREAD_DATA (thread
);
473 scm_thread
*c
= scm_i_leave_guile ();
474 while (!THREAD_INITIALIZED_P (t
))
476 scm_thread_join (t
->thread
, 0);
477 scm_i_enter_guile (c
);
480 t
->result
= SCM_BOOL_F
;
487 /* We implement our own mutex type since we want them to be 'fair', we
488 want to do fancy things while waiting for them (like running
489 asyncs) and we want to support waiting on many things at once.
490 Also, we might add things that are nice for debugging.
493 typedef struct fair_mutex
{
494 /* the thread currently owning the mutex, or SCM_BOOL_F. */
498 /* how much the owner owns us. */
500 /* the threads waiting for this mutex. */
505 fair_mutex_mark (SCM mx
)
507 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
508 scm_gc_mark (m
->owner
);
512 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
514 "Create a new fair mutex object. ")
515 #define FUNC_NAME s_scm_make_fair_mutex
517 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
518 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
519 scm_i_plugin_mutex_init (&m
->lock
, 0);
521 m
->owner
= SCM_BOOL_F
;
523 m
->waiting
= make_queue ();
529 fair_mutex_lock (fair_mutex
*m
)
531 scm_i_plugin_mutex_lock (&m
->lock
);
533 /* Need to wait if another thread is just temporarily unlocking.
534 This is happens very seldom and only when the other thread is
535 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
541 if (m
->owner
== SCM_BOOL_F
)
542 m
->owner
= cur_thread
;
543 else if (m
->owner
== cur_thread
)
549 SCM c
= enqueue (m
->waiting
, cur_thread
);
551 /* Note: It's important that m->lock is never locked for
552 any longer amount of time since that could prevent GC */
553 scm_i_plugin_mutex_unlock (&m
->lock
);
555 if (m
->owner
== cur_thread
)
557 scm_i_plugin_mutex_lock (&m
->lock
);
558 remqueue (m
->waiting
, c
);
559 scm_i_plugin_mutex_unlock (&m
->lock
);
563 scm_i_plugin_mutex_lock (&m
->lock
);
566 scm_i_plugin_mutex_unlock (&m
->lock
);
571 fair_mutex_trylock (fair_mutex
*m
)
573 scm_i_plugin_mutex_lock (&m
->lock
);
574 if (m
->owner
== SCM_BOOL_F
)
575 m
->owner
= cur_thread
;
576 else if (m
->owner
== cur_thread
)
580 scm_i_plugin_mutex_unlock (&m
->lock
);
583 scm_i_plugin_mutex_unlock (&m
->lock
);
588 fair_mutex_unlock (fair_mutex
*m
)
590 scm_i_plugin_mutex_lock (&m
->lock
);
591 if (m
->owner
!= cur_thread
)
593 scm_i_plugin_mutex_unlock (&m
->lock
);
596 else if (m
->level
> 0)
600 SCM next
= dequeue (m
->waiting
);
601 if (!SCM_FALSEP (next
))
604 unblock (SCM_THREAD_DATA (next
));
607 m
->owner
= SCM_BOOL_F
;
609 scm_i_plugin_mutex_unlock (&m
->lock
);
613 /*** Fair condition variables */
615 /* Like mutexes, we implement our own condition variables using the
619 typedef struct fair_cond
{
621 /* the threads waiting for this condition. */
626 fair_cond_mark (SCM cv
)
628 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
632 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
634 "Make a new fair condition variable.")
635 #define FUNC_NAME s_scm_make_fair_condition_variable
637 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
638 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
639 scm_i_plugin_mutex_init (&c
->lock
, 0);
640 c
->waiting
= make_queue ();
646 fair_cond_timedwait (fair_cond
*c
,
648 const struct timespec
*waittime
)
651 scm_i_plugin_mutex_lock (&c
->lock
);
655 enqueue (c
->waiting
, cur_thread
);
656 scm_i_plugin_mutex_unlock (&c
->lock
);
657 fair_mutex_unlock (m
); /*fixme* - not thread safe */
658 if (waittime
== NULL
)
661 err
= timed_block (waittime
);
665 /* XXX - check whether we have been signalled. */
672 fair_cond_signal (fair_cond
*c
)
675 scm_i_plugin_mutex_lock (&c
->lock
);
676 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
677 unblock (SCM_THREAD_DATA (th
));
678 scm_i_plugin_mutex_unlock (&c
->lock
);
683 fair_cond_broadcast (fair_cond
*c
)
686 scm_i_plugin_mutex_lock (&c
->lock
);
687 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
688 unblock (SCM_THREAD_DATA (th
));
689 scm_i_plugin_mutex_unlock (&c
->lock
);
695 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
697 "Create a new mutex object. ")
698 #define FUNC_NAME s_scm_make_mutex
700 SCM mx
= scm_make_smob (scm_tc16_mutex
);
701 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), 0);
706 /*fixme* change documentation */
707 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
709 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
710 "blocks until the mutex becomes available. The function returns when "
711 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
712 "a thread already owns will succeed right away and will not block the "
713 "thread. That is, Guile's mutexes are @emph{recursive}. ")
714 #define FUNC_NAME s_scm_lock_mutex
717 SCM_VALIDATE_MUTEX (1, mx
);
719 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
720 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
723 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
724 scm_thread
*t
= scm_i_leave_guile ();
725 err
= scm_i_plugin_mutex_lock (m
);
726 scm_i_enter_guile (t
);
738 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
740 "Try to lock @var{mutex}. If the mutex is already locked by someone "
741 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
742 #define FUNC_NAME s_scm_try_mutex
745 SCM_VALIDATE_MUTEX (1, mx
);
747 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
748 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
751 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
752 scm_thread
*t
= scm_i_leave_guile ();
753 err
= scm_i_plugin_mutex_trylock (m
);
754 scm_i_enter_guile (t
);
770 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
772 "Unlocks @var{mutex} if the calling thread owns the lock on "
773 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
774 "thread results in undefined behaviour. Once a mutex has been unlocked, "
775 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
776 "lock. Every call to @code{lock-mutex} by this thread must be matched "
777 "with a call to @code{unlock-mutex}. Only the last call to "
778 "@code{unlock-mutex} will actually unlock the mutex. ")
779 #define FUNC_NAME s_scm_unlock_mutex
782 SCM_VALIDATE_MUTEX (1, mx
);
784 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
786 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
789 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
790 if (m
->owner
!= cur_thread
)
792 if (m
->owner
== SCM_BOOL_F
)
793 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
795 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
801 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
802 err
= scm_i_plugin_mutex_unlock (m
);
814 /*** Condition variables */
816 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
818 "Make a new condition variable.")
819 #define FUNC_NAME s_scm_make_condition_variable
821 SCM cv
= scm_make_smob (scm_tc16_condvar
);
822 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
827 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
828 (SCM cv
, SCM mx
, SCM t
),
829 "Wait until @var{cond-var} has been signalled. While waiting, "
830 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
831 "is locked again when this function returns. When @var{time} is given, "
832 "it specifies a point in time where the waiting should be aborted. It "
833 "can be either a integer as returned by @code{current-time} or a pair "
834 "as returned by @code{gettimeofday}. When the waiting is aborted the "
835 "mutex is locked and @code{#f} is returned. When the condition "
836 "variable is in fact signalled, the mutex is also locked and @code{#t} "
838 #define FUNC_NAME s_scm_timed_wait_condition_variable
840 struct timespec waittime
;
843 SCM_VALIDATE_CONDVAR (1, cv
);
844 SCM_VALIDATE_MUTEX (2, mx
);
845 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
846 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
847 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
848 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
849 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
856 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
857 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
858 waittime
.tv_nsec
*= 1000;
862 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
863 waittime
.tv_nsec
= 0;
867 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
868 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
870 SCM_UNBNDP (t
) ? NULL
: &waittime
);
873 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
874 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
875 scm_thread
*t
= scm_i_leave_guile ();
876 err
= scm_i_plugin_cond_wait (c
, m
);
877 scm_i_enter_guile (t
);
889 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
891 "Wake up one thread that is waiting for @var{cv}")
892 #define FUNC_NAME s_scm_signal_condition_variable
894 SCM_VALIDATE_CONDVAR (1, cv
);
895 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
896 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
899 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
900 scm_i_plugin_cond_signal (c
);
906 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
908 "Wake up all threads that are waiting for @var{cv}. ")
909 #define FUNC_NAME s_scm_broadcast_condition_variable
911 SCM_VALIDATE_CONDVAR (1, cv
);
912 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
913 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
916 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
917 scm_i_plugin_cond_broadcast (c
);
923 /*** Marking stacks */
925 /* XXX - what to do with this? Do we need to handle this for blocked
929 # define SCM_MARK_BACKING_STORE() do { \
931 SCM_STACKITEM * top, * bot; \
933 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
934 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
935 / sizeof (SCM_STACKITEM))); \
936 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
937 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
938 scm_mark_locations (bot, top - bot); } while (0)
940 # define SCM_MARK_BACKING_STORE()
944 scm_threads_mark_stacks (void)
947 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
949 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
950 if (!THREAD_INITIALIZED_P (t
))
952 /* Not fully initialized yet. */
959 if (t
->thread
!= scm_thread_self ())
963 /* stack_len is long rather than sizet in order to guarantee
964 that &stack_len is long aligned */
965 #ifdef STACK_GROWS_UP
966 stack_len
= ((SCM_STACKITEM
*) (&t
) -
967 (SCM_STACKITEM
*) thread
->base
);
969 /* Protect from the C stack. This must be the first marking
970 * done because it provides information about what objects
971 * are "in-use" by the C code. "in-use" objects are those
972 * for which the information about length and base address must
973 * remain usable. This requirement is stricter than a liveness
974 * requirement -- in particular, it constrains the implementation
977 SCM_FLUSH_REGISTER_WINDOWS
;
978 /* This assumes that all registers are saved into the jmp_buf */
979 setjmp (scm_save_regs_gc_mark
);
980 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
981 ((size_t) sizeof scm_save_regs_gc_mark
982 / sizeof (SCM_STACKITEM
)));
984 scm_mark_locations (((size_t) t
->base
,
987 stack_len
= ((SCM_STACKITEM
*) t
->base
-
988 (SCM_STACKITEM
*) (&t
));
990 /* Protect from the C stack. This must be the first marking
991 * done because it provides information about what objects
992 * are "in-use" by the C code. "in-use" objects are those
993 * for which the information about length and base address must
994 * remain usable. This requirement is stricter than a liveness
995 * requirement -- in particular, it constrains the implementation
998 SCM_FLUSH_REGISTER_WINDOWS
;
999 /* This assumes that all registers are saved into the jmp_buf */
1000 setjmp (scm_save_regs_gc_mark
);
1001 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1002 ((size_t) sizeof scm_save_regs_gc_mark
1003 / sizeof (SCM_STACKITEM
)));
1005 scm_mark_locations ((SCM_STACKITEM
*) &t
,
1011 /* Suspended thread */
1012 #ifdef STACK_GROWS_UP
1013 long stack_len
= t
->top
- t
->base
;
1014 scm_mark_locations (t
->base
, stack_len
);
1016 long stack_len
= t
->base
- t
->top
;
1017 scm_mark_locations (t
->top
, stack_len
);
1019 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1020 ((size_t) sizeof(t
->regs
)
1021 / sizeof (SCM_STACKITEM
)));
1029 scm_internal_select (int nfds
,
1030 SELECT_TYPE
*readfds
,
1031 SELECT_TYPE
*writefds
,
1032 SELECT_TYPE
*exceptfds
,
1033 struct timeval
*timeout
)
1036 scm_thread
*c
= scm_i_leave_guile ();
1037 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1039 scm_i_enter_guile (c
);
1045 /* Low-level C API */
1048 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1049 scm_t_catch_handler handler
, void *handler_data
)
1051 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1056 scm_mutex_lock (scm_t_mutex
*m
)
1058 scm_thread
*t
= scm_i_leave_guile ();
1059 int res
= scm_i_plugin_mutex_lock (m
);
1060 scm_i_enter_guile (t
);
1065 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1067 scm_thread
*t
= scm_i_leave_guile ();
1068 scm_i_plugin_cond_wait (c
, m
);
1069 scm_i_enter_guile (t
);
1074 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
)
1076 scm_thread
*t
= scm_i_leave_guile ();
1077 int res
= scm_i_plugin_cond_timedwait (c
, m
);
1078 scm_i_enter_guile (t
);
1086 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1092 scm_i_leave_guile ();
1096 scm_thread_usleep (unsigned long usecs
)
1099 tv
.tv_usec
= usecs
% 1000000;
1100 tv
.tv_sec
= usecs
/ 1000000;
1101 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1102 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1106 scm_thread_sleep (unsigned long secs
)
1111 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1117 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1119 "Return the thread that called this function.")
1120 #define FUNC_NAME s_scm_current_thread
1126 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1128 "Return a list of all threads.")
1129 #define FUNC_NAME s_scm_all_threads
1136 scm_i_thread_root (SCM thread
)
1138 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1141 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1143 "Return @code{#t} iff @var{thread} has exited.\n")
1144 #define FUNC_NAME s_scm_thread_exited_p
1146 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1151 scm_c_thread_exited_p (SCM thread
)
1152 #define FUNC_NAME s_scm_thread_exited_p
1155 SCM_VALIDATE_THREAD (1, thread
);
1156 t
= SCM_THREAD_DATA (thread
);
1161 static scm_t_cond wake_up_cond
;
1162 int scm_i_thread_go_to_sleep
;
1163 static scm_thread
*gc_thread
;
1164 static scm_t_mutex gc_section_mutex
;
1165 static scm_thread
*gc_section_owner
;
1166 static int gc_section_count
= 0;
1167 static int threads_initialized_p
= 0;
1170 scm_i_thread_put_to_sleep ()
1172 SCM_REC_CRITICAL_SECTION_START (gc_section
);
1173 if (threads_initialized_p
&& gc_section_count
== 1)
1175 SCM threads
= all_threads
;
1176 /* Signal all threads to go to sleep */
1177 scm_i_thread_go_to_sleep
= 1;
1178 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1179 if (SCM_CAR (threads
) != cur_thread
)
1181 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1182 t
->clear_freelists_p
= 1;
1183 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1185 gc_thread
= suspend ();
1186 scm_i_thread_go_to_sleep
= 0;
1191 scm_i_thread_wake_up ()
1193 if (threads_initialized_p
&& gc_section_count
== 1)
1195 SCM threads
= all_threads
;
1197 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1198 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1199 if (SCM_CAR (threads
) != cur_thread
)
1201 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1202 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1205 SCM_REC_CRITICAL_SECTION_END (gc_section
);
1209 scm_i_thread_sleep_for_gc ()
1213 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
1214 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
1215 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1216 t
->clear_freelists_p
= 0;
1217 t
->top
= NULL
; /* resume (t); but don't clear freelists */
1220 /* The mother of all recursive critical sections */
1221 scm_t_mutex scm_i_section_mutex
;
1223 scm_t_mutex scm_i_critical_section_mutex
;
1224 scm_t_mutex scm_i_defer_mutex
;
1225 int scm_i_defer_count
= 0;
1226 scm_thread
*scm_i_defer_owner
= 0;
1228 /*** Initialization */
1231 scm_threads_prehistory ()
1234 scm_i_plugin_mutex_init (&thread_admin_mutex
, 0);
1235 scm_i_plugin_mutex_init (&gc_section_mutex
, 0);
1236 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1237 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, 0);
1239 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1240 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1241 scm_i_plugin_mutex_init (&scm_i_defer_mutex
, 0);
1242 scm_i_plugin_mutex_init (&scm_i_section_mutex
, 0);
1243 /* Allocate a fake thread object to be used during bootup. */
1244 t
= malloc (sizeof (scm_thread
));
1246 t
->clear_freelists_p
= 0;
1247 scm_setspecific (scm_i_thread_key
, t
);
1250 scm_t_bits scm_tc16_thread
;
1251 scm_t_bits scm_tc16_mutex
;
1252 scm_t_bits scm_tc16_fair_mutex
;
1253 scm_t_bits scm_tc16_condvar
;
1254 scm_t_bits scm_tc16_fair_condvar
;
1257 scm_init_threads (SCM_STACKITEM
*base
)
1260 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1261 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1262 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1263 sizeof (fair_mutex
));
1264 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1265 sizeof (scm_t_cond
));
1266 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1267 sizeof (fair_cond
));
1269 thread
= make_thread (SCM_BOOL_F
);
1270 /* Replace initial fake thread with a real thread object */
1271 free (SCM_CURRENT_THREAD
);
1272 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1273 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1275 /* root is set later from init.c */
1276 init_thread_creatant (thread
, base
);
1278 scm_gc_register_root (&all_threads
);
1279 all_threads
= scm_cons (thread
, SCM_EOL
);
1281 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1282 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1283 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1285 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1287 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1289 threads_initialized_p
= 1;
1293 scm_init_thread_procs ()
1295 #include "libguile/threads.x"