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
,
344 scm_i_leave_guile (); /* release the heap */
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
);
353 scm_thread_detach (t
->thread
);
357 launch_thread (void *p
)
359 really_launch ((SCM_STACKITEM
*)&p
, (launch_data
*)p
);
364 create_thread (scm_t_catch_body body
, void *body_data
,
365 scm_t_catch_handler handler
, void *handler_data
,
370 /* Make new thread. The first thing the new thread will do is to
371 lock guile_mutex. Thus, we can safely complete its
372 initialization after creating it. While the new thread starts,
373 all its data is protected via all_threads.
383 /* Unwind wind chain. */
384 old_winds
= scm_dynwinds
;
385 scm_dowinds (SCM_EOL
, scm_ilength (scm_root
->dynwinds
));
387 /* Allocate thread locals. */
388 root
= scm_make_root (scm_root
->handle
);
389 data
= scm_malloc (sizeof (launch_data
));
392 thread
= make_thread (protects
);
393 data
->thread
= thread
;
395 data
->body_data
= body_data
;
396 data
->handler
= handler
;
397 data
->handler_data
= handler_data
;
398 t
= SCM_THREAD_DATA (thread
);
399 /* must initialize root state pointer before the thread is linked
401 t
->root
= SCM_ROOT_STATE (root
);
403 /* In order to avoid the need of synchronization between parent
404 and child thread, we need to insert the child into all_threads
407 SCM new_threads
= scm_cons (thread
, SCM_BOOL_F
); /* could cause GC */
408 scm_thread
*parent
= scm_i_leave_guile (); /* to prevent deadlock */
409 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
410 SCM_SETCDR (new_threads
, all_threads
);
411 all_threads
= new_threads
;
413 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
415 scm_remember_upto_here_1 (root
);
417 scm_i_enter_guile (parent
);
420 err
= scm_i_plugin_thread_create (&th
, 0, launch_thread
, (void *) data
);
423 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
424 all_threads
= scm_delq_x (thread
, all_threads
);
425 ((scm_thread
*) SCM_THREAD_DATA(thread
))->exited
= 1;
427 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
430 /* Return to old dynamic context. */
431 scm_dowinds (old_winds
, - scm_ilength (old_winds
));
436 scm_syserror ("create-thread");
443 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 2, 0, 0,
444 (SCM thunk
, SCM handler
),
445 "Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
446 "returning a new thread object representing the thread. "
447 "If an error occurs during evaluation, call error-thunk, passing it an "
448 "error code describing the condition. "
449 "If this happens, the error-thunk is called outside the scope of the new "
450 "root -- it is called in the same dynamic context in which "
451 "with-new-thread was evaluated, but not in the callers thread. "
452 "All the evaluation rules for dynamic roots apply to threads.")
453 #define FUNC_NAME s_scm_call_with_new_thread
455 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
456 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)), handler
, SCM_ARG2
,
459 return create_thread ((scm_t_catch_body
) scm_call_0
, thunk
,
460 (scm_t_catch_handler
) scm_apply_1
, handler
,
461 scm_cons (thunk
, handler
));
465 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
467 "Suspend execution of the calling thread until the target @var{thread} "
468 "terminates, unless the target @var{thread} has already terminated. ")
469 #define FUNC_NAME s_scm_join_thread
474 SCM_VALIDATE_THREAD (1, thread
);
475 if (SCM_EQ_P (cur_thread
, thread
))
476 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
478 t
= SCM_THREAD_DATA (thread
);
481 scm_thread
*c
= scm_i_leave_guile ();
482 while (!THREAD_INITIALIZED_P (t
))
484 scm_thread_join (t
->thread
, 0);
485 scm_i_enter_guile (c
);
488 t
->result
= SCM_BOOL_F
;
493 SCM
*scm_loc_sys_thread_handler
;
496 scm_i_make_future (SCM thunk
)
498 SCM_RETURN_NEWSMOB2 (scm_tc16_future
,
499 create_thread ((scm_t_catch_body
) scm_call_0
,
501 (scm_t_catch_handler
) scm_apply_1
,
502 *scm_loc_sys_thread_handler
,
504 *scm_loc_sys_thread_handler
)),
505 scm_make_rec_mutex ());
509 future_free (SCM future
)
511 scm_rec_mutex_free (SCM_FUTURE_MUTEX (future
));
516 future_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
518 int writingp
= SCM_WRITINGP (pstate
);
519 scm_puts ("#<future ", port
);
520 SCM_SET_WRITINGP (pstate
, 1);
521 scm_iprin1 (SCM_FUTURE_DATA (exp
), port
, pstate
);
522 SCM_SET_WRITINGP (pstate
, writingp
);
523 scm_putc ('>', port
);
527 SCM_DEFINE (scm_future_ref
, "future-ref", 1, 0, 0,
529 "If the future @var{x} has not been computed yet, compute and\n"
530 "return @var{x}, otherwise just return the previously computed\n"
532 #define FUNC_NAME s_scm_future_ref
534 SCM_VALIDATE_FUTURE (1, future
);
535 scm_rec_mutex_lock (SCM_FUTURE_MUTEX (future
));
536 if (!SCM_FUTURE_COMPUTED_P (future
))
538 SCM value
= scm_join_thread (SCM_FUTURE_DATA (future
));
539 if (!SCM_FUTURE_COMPUTED_P (future
))
541 SCM_SET_FUTURE_DATA (future
, value
);
542 SCM_SET_FUTURE_COMPUTED (future
);
545 scm_rec_mutex_unlock (SCM_FUTURE_MUTEX (future
));
546 return SCM_FUTURE_DATA (future
);
552 /* We implement our own mutex type since we want them to be 'fair', we
553 want to do fancy things while waiting for them (like running
554 asyncs) and we want to support waiting on many things at once.
555 Also, we might add things that are nice for debugging.
558 typedef struct fair_mutex
{
559 /* the thread currently owning the mutex, or SCM_BOOL_F. */
563 /* how much the owner owns us. */
565 /* the threads waiting for this mutex. */
570 fair_mutex_mark (SCM mx
)
572 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
573 scm_gc_mark (m
->owner
);
577 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
579 "Create a new fair mutex object. ")
580 #define FUNC_NAME s_scm_make_fair_mutex
582 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
583 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
584 scm_i_plugin_mutex_init (&m
->lock
, 0);
586 m
->owner
= SCM_BOOL_F
;
588 m
->waiting
= make_queue ();
594 fair_mutex_lock (fair_mutex
*m
)
596 scm_i_plugin_mutex_lock (&m
->lock
);
598 /* Need to wait if another thread is just temporarily unlocking.
599 This is happens very seldom and only when the other thread is
600 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
606 if (m
->owner
== SCM_BOOL_F
)
607 m
->owner
= cur_thread
;
608 else if (m
->owner
== cur_thread
)
614 SCM c
= enqueue (m
->waiting
, cur_thread
);
616 /* Note: It's important that m->lock is never locked for
617 any longer amount of time since that could prevent GC */
618 scm_i_plugin_mutex_unlock (&m
->lock
);
620 if (m
->owner
== cur_thread
)
622 scm_i_plugin_mutex_lock (&m
->lock
);
623 remqueue (m
->waiting
, c
);
624 scm_i_plugin_mutex_unlock (&m
->lock
);
628 scm_i_plugin_mutex_lock (&m
->lock
);
631 scm_i_plugin_mutex_unlock (&m
->lock
);
636 fair_mutex_trylock (fair_mutex
*m
)
638 scm_i_plugin_mutex_lock (&m
->lock
);
639 if (m
->owner
== SCM_BOOL_F
)
640 m
->owner
= cur_thread
;
641 else if (m
->owner
== cur_thread
)
645 scm_i_plugin_mutex_unlock (&m
->lock
);
648 scm_i_plugin_mutex_unlock (&m
->lock
);
653 fair_mutex_unlock (fair_mutex
*m
)
655 scm_i_plugin_mutex_lock (&m
->lock
);
656 if (m
->owner
!= cur_thread
)
658 scm_i_plugin_mutex_unlock (&m
->lock
);
661 else if (m
->level
> 0)
665 SCM next
= dequeue (m
->waiting
);
666 if (!SCM_FALSEP (next
))
669 unblock (SCM_THREAD_DATA (next
));
672 m
->owner
= SCM_BOOL_F
;
674 scm_i_plugin_mutex_unlock (&m
->lock
);
678 /*** Fair condition variables */
680 /* Like mutexes, we implement our own condition variables using the
684 typedef struct fair_cond
{
686 /* the threads waiting for this condition. */
691 fair_cond_mark (SCM cv
)
693 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
697 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
699 "Make a new fair condition variable.")
700 #define FUNC_NAME s_scm_make_fair_condition_variable
702 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
703 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
704 scm_i_plugin_mutex_init (&c
->lock
, 0);
705 c
->waiting
= make_queue ();
711 fair_cond_timedwait (fair_cond
*c
,
713 const struct timespec
*waittime
)
716 scm_i_plugin_mutex_lock (&c
->lock
);
720 enqueue (c
->waiting
, cur_thread
);
721 scm_i_plugin_mutex_unlock (&c
->lock
);
722 fair_mutex_unlock (m
); /*fixme* - not thread safe */
723 if (waittime
== NULL
)
726 err
= timed_block (waittime
);
730 /* XXX - check whether we have been signalled. */
737 fair_cond_signal (fair_cond
*c
)
740 scm_i_plugin_mutex_lock (&c
->lock
);
741 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
742 unblock (SCM_THREAD_DATA (th
));
743 scm_i_plugin_mutex_unlock (&c
->lock
);
748 fair_cond_broadcast (fair_cond
*c
)
751 scm_i_plugin_mutex_lock (&c
->lock
);
752 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
753 unblock (SCM_THREAD_DATA (th
));
754 scm_i_plugin_mutex_unlock (&c
->lock
);
760 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
762 "Create a new mutex object. ")
763 #define FUNC_NAME s_scm_make_mutex
765 SCM mx
= scm_make_smob (scm_tc16_mutex
);
766 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), 0);
771 /*fixme* change documentation */
772 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
774 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
775 "blocks until the mutex becomes available. The function returns when "
776 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
777 "a thread already owns will succeed right away and will not block the "
778 "thread. That is, Guile's mutexes are @emph{recursive}. ")
779 #define FUNC_NAME s_scm_lock_mutex
782 SCM_VALIDATE_MUTEX (1, mx
);
784 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
785 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
788 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
789 scm_thread
*t
= scm_i_leave_guile ();
790 err
= scm_i_plugin_mutex_lock (m
);
791 scm_i_enter_guile (t
);
803 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
805 "Try to lock @var{mutex}. If the mutex is already locked by someone "
806 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
807 #define FUNC_NAME s_scm_try_mutex
810 SCM_VALIDATE_MUTEX (1, mx
);
812 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
813 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
816 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
817 scm_thread
*t
= scm_i_leave_guile ();
818 err
= scm_i_plugin_mutex_trylock (m
);
819 scm_i_enter_guile (t
);
835 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
837 "Unlocks @var{mutex} if the calling thread owns the lock on "
838 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
839 "thread results in undefined behaviour. Once a mutex has been unlocked, "
840 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
841 "lock. Every call to @code{lock-mutex} by this thread must be matched "
842 "with a call to @code{unlock-mutex}. Only the last call to "
843 "@code{unlock-mutex} will actually unlock the mutex. ")
844 #define FUNC_NAME s_scm_unlock_mutex
847 SCM_VALIDATE_MUTEX (1, mx
);
849 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
851 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
854 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
855 if (m
->owner
!= cur_thread
)
857 if (m
->owner
== SCM_BOOL_F
)
858 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
860 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
866 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
867 err
= scm_i_plugin_mutex_unlock (m
);
879 /*** Condition variables */
881 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
883 "Make a new condition variable.")
884 #define FUNC_NAME s_scm_make_condition_variable
886 SCM cv
= scm_make_smob (scm_tc16_condvar
);
887 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
892 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
893 (SCM cv
, SCM mx
, SCM t
),
894 "Wait until @var{cond-var} has been signalled. While waiting, "
895 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
896 "is locked again when this function returns. When @var{time} is given, "
897 "it specifies a point in time where the waiting should be aborted. It "
898 "can be either a integer as returned by @code{current-time} or a pair "
899 "as returned by @code{gettimeofday}. When the waiting is aborted the "
900 "mutex is locked and @code{#f} is returned. When the condition "
901 "variable is in fact signalled, the mutex is also locked and @code{#t} "
903 #define FUNC_NAME s_scm_timed_wait_condition_variable
905 struct timespec waittime
;
908 SCM_VALIDATE_CONDVAR (1, cv
);
909 SCM_VALIDATE_MUTEX (2, mx
);
910 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
911 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
912 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
913 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
914 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
921 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
922 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
923 waittime
.tv_nsec
*= 1000;
927 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
928 waittime
.tv_nsec
= 0;
932 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
933 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
935 SCM_UNBNDP (t
) ? NULL
: &waittime
);
938 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
939 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
940 scm_thread
*t
= scm_i_leave_guile ();
941 err
= scm_i_plugin_cond_wait (c
, m
);
942 scm_i_enter_guile (t
);
954 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
956 "Wake up one thread that is waiting for @var{cv}")
957 #define FUNC_NAME s_scm_signal_condition_variable
959 SCM_VALIDATE_CONDVAR (1, cv
);
960 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
961 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
964 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
965 scm_i_plugin_cond_signal (c
);
971 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
973 "Wake up all threads that are waiting for @var{cv}. ")
974 #define FUNC_NAME s_scm_broadcast_condition_variable
976 SCM_VALIDATE_CONDVAR (1, cv
);
977 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
978 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
981 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
982 scm_i_plugin_cond_broadcast (c
);
988 /*** Marking stacks */
990 /* XXX - what to do with this? Do we need to handle this for blocked
994 # define SCM_MARK_BACKING_STORE() do { \
996 SCM_STACKITEM * top, * bot; \
998 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
999 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1000 / sizeof (SCM_STACKITEM))); \
1001 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1002 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1003 scm_mark_locations (bot, top - bot); } while (0)
1005 # define SCM_MARK_BACKING_STORE()
1009 scm_threads_mark_stacks (void)
1012 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
1014 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
1015 if (!THREAD_INITIALIZED_P (t
))
1017 /* Not fully initialized yet. */
1024 if (t
->thread
!= scm_thread_self ())
1028 /* stack_len is long rather than sizet in order to guarantee
1029 that &stack_len is long aligned */
1030 #ifdef STACK_GROWS_UP
1031 stack_len
= ((SCM_STACKITEM
*) (&t
) -
1032 (SCM_STACKITEM
*) thread
->base
);
1034 /* Protect from the C stack. This must be the first marking
1035 * done because it provides information about what objects
1036 * are "in-use" by the C code. "in-use" objects are those
1037 * for which the information about length and base address must
1038 * remain usable. This requirement is stricter than a liveness
1039 * requirement -- in particular, it constrains the implementation
1042 SCM_FLUSH_REGISTER_WINDOWS
;
1043 /* This assumes that all registers are saved into the jmp_buf */
1044 setjmp (scm_save_regs_gc_mark
);
1045 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1046 ((size_t) sizeof scm_save_regs_gc_mark
1047 / sizeof (SCM_STACKITEM
)));
1049 scm_mark_locations (((size_t) t
->base
,
1050 (sizet
) stack_len
));
1052 stack_len
= ((SCM_STACKITEM
*) t
->base
-
1053 (SCM_STACKITEM
*) (&t
));
1055 /* Protect from the C stack. This must be the first marking
1056 * done because it provides information about what objects
1057 * are "in-use" by the C code. "in-use" objects are those
1058 * for which the information about length and base address must
1059 * remain usable. This requirement is stricter than a liveness
1060 * requirement -- in particular, it constrains the implementation
1063 SCM_FLUSH_REGISTER_WINDOWS
;
1064 /* This assumes that all registers are saved into the jmp_buf */
1065 setjmp (scm_save_regs_gc_mark
);
1066 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1067 ((size_t) sizeof scm_save_regs_gc_mark
1068 / sizeof (SCM_STACKITEM
)));
1070 scm_mark_locations ((SCM_STACKITEM
*) &t
,
1076 /* Suspended thread */
1077 #ifdef STACK_GROWS_UP
1078 long stack_len
= t
->top
- t
->base
;
1079 scm_mark_locations (t
->base
, stack_len
);
1081 long stack_len
= t
->base
- t
->top
;
1082 scm_mark_locations (t
->top
, stack_len
);
1084 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1085 ((size_t) sizeof(t
->regs
)
1086 / sizeof (SCM_STACKITEM
)));
1094 scm_internal_select (int nfds
,
1095 SELECT_TYPE
*readfds
,
1096 SELECT_TYPE
*writefds
,
1097 SELECT_TYPE
*exceptfds
,
1098 struct timeval
*timeout
)
1101 scm_thread
*c
= scm_i_leave_guile ();
1102 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1104 scm_i_enter_guile (c
);
1110 /* Low-level C API */
1113 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1114 scm_t_catch_handler handler
, void *handler_data
)
1116 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1120 scm_mutex_lock (scm_t_mutex
*m
)
1122 scm_thread
*t
= scm_i_leave_guile ();
1123 int res
= scm_i_plugin_mutex_lock (m
);
1124 scm_i_enter_guile (t
);
1129 scm_make_rec_mutex ()
1131 scm_t_rec_mutex
*m
= scm_malloc (sizeof (scm_t_rec_mutex
));
1132 scm_i_plugin_rec_mutex_init (m
, &scm_i_plugin_rec_mutex
);
1137 scm_rec_mutex_free (scm_t_rec_mutex
*m
)
1139 scm_i_plugin_rec_mutex_destroy (m
);
1144 scm_rec_mutex_lock (scm_t_rec_mutex
*m
)
1146 scm_thread
*t
= scm_i_leave_guile ();
1147 int res
= scm_i_plugin_rec_mutex_lock (m
);
1148 scm_i_enter_guile (t
);
1153 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1155 scm_thread
*t
= scm_i_leave_guile ();
1156 scm_i_plugin_cond_wait (c
, m
);
1157 scm_i_enter_guile (t
);
1162 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
, const struct timespec
*wt
)
1164 scm_thread
*t
= scm_i_leave_guile ();
1165 int res
= scm_i_plugin_cond_timedwait (c
, m
, wt
);
1166 scm_i_enter_guile (t
);
1173 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1179 scm_i_leave_guile ();
1183 scm_thread_usleep (unsigned long usecs
)
1186 tv
.tv_usec
= usecs
% 1000000;
1187 tv
.tv_sec
= usecs
/ 1000000;
1188 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1189 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1193 scm_thread_sleep (unsigned long secs
)
1198 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1204 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1206 "Return the thread that called this function.")
1207 #define FUNC_NAME s_scm_current_thread
1213 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1215 "Return a list of all threads.")
1216 #define FUNC_NAME s_scm_all_threads
1223 scm_i_thread_root (SCM thread
)
1225 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1228 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1230 "Return @code{#t} iff @var{thread} has exited.\n")
1231 #define FUNC_NAME s_scm_thread_exited_p
1233 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1238 scm_c_thread_exited_p (SCM thread
)
1239 #define FUNC_NAME s_scm_thread_exited_p
1242 SCM_VALIDATE_THREAD (1, thread
);
1243 t
= SCM_THREAD_DATA (thread
);
1248 static scm_t_cond wake_up_cond
;
1249 int scm_i_thread_go_to_sleep
;
1250 static scm_t_rec_mutex gc_section_mutex
;
1251 static int gc_section_count
= 0;
1252 static int threads_initialized_p
= 0;
1255 scm_i_thread_put_to_sleep ()
1257 scm_rec_mutex_lock (&gc_section_mutex
);
1258 if (threads_initialized_p
&& !gc_section_count
++)
1261 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1262 threads
= all_threads
;
1263 /* Signal all threads to go to sleep */
1264 scm_i_thread_go_to_sleep
= 1;
1265 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1266 if (SCM_CAR (threads
) != cur_thread
)
1268 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1269 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1271 scm_i_thread_go_to_sleep
= 0;
1272 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1277 scm_i_thread_invalidate_freelists ()
1279 /* Don't need to lock thread_admin_mutex here since we are sinle threaded */
1280 SCM threads
= all_threads
;
1281 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1282 if (SCM_CAR (threads
) != cur_thread
)
1284 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1285 t
->clear_freelists_p
= 1;
1290 scm_i_thread_wake_up ()
1292 if (threads_initialized_p
&& !--gc_section_count
)
1295 /* Need to lock since woken threads can die and be deleted from list */
1296 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1297 threads
= all_threads
;
1298 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1299 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1300 if (SCM_CAR (threads
) != cur_thread
)
1302 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1303 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1305 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1307 scm_rec_mutex_unlock (&gc_section_mutex
);
1311 scm_i_thread_sleep_for_gc ()
1315 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1319 scm_t_mutex scm_i_critical_section_mutex
;
1320 scm_t_rec_mutex scm_i_defer_mutex
;
1322 #ifdef USE_PTHREAD_THREADS
1323 #include "libguile/pthread-threads.c"
1326 /*** Initialization */
1329 scm_threads_prehistory ()
1332 scm_i_plugin_mutex_init (&thread_admin_mutex
, &scm_i_plugin_mutex
);
1333 scm_i_plugin_rec_mutex_init (&gc_section_mutex
, &scm_i_plugin_rec_mutex
);
1334 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1335 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, &scm_i_plugin_mutex
);
1337 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1338 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1339 scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex
, &scm_i_plugin_rec_mutex
);
1340 /* Allocate a fake thread object to be used during bootup. */
1341 t
= malloc (sizeof (scm_thread
));
1343 t
->clear_freelists_p
= 0;
1344 scm_setspecific (scm_i_thread_key
, t
);
1345 #ifdef USE_PTHREAD_THREADS
1346 scm_init_pthread_threads ();
1350 scm_t_bits scm_tc16_thread
;
1351 scm_t_bits scm_tc16_future
;
1352 scm_t_bits scm_tc16_mutex
;
1353 scm_t_bits scm_tc16_fair_mutex
;
1354 scm_t_bits scm_tc16_condvar
;
1355 scm_t_bits scm_tc16_fair_condvar
;
1358 scm_init_threads (SCM_STACKITEM
*base
)
1361 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1362 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1363 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1364 sizeof (fair_mutex
));
1365 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1366 sizeof (scm_t_cond
));
1367 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1368 sizeof (fair_cond
));
1370 thread
= make_thread (SCM_BOOL_F
);
1371 /* Replace initial fake thread with a real thread object */
1372 free (SCM_CURRENT_THREAD
);
1373 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1374 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1376 /* root is set later from init.c */
1377 init_thread_creatant (thread
, base
);
1379 scm_gc_register_root (&all_threads
);
1380 all_threads
= scm_cons (thread
, SCM_EOL
);
1382 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1383 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1384 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1386 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1388 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1390 scm_tc16_future
= scm_make_smob_type ("future", 0);
1391 scm_set_smob_mark (scm_tc16_future
, scm_markcdr
);
1392 scm_set_smob_free (scm_tc16_future
, future_free
);
1393 scm_set_smob_print (scm_tc16_future
, future_print
);
1395 threads_initialized_p
= 1;
1399 scm_init_thread_procs ()
1401 scm_loc_sys_thread_handler
1402 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F
));
1403 #include "libguile/threads.x"