1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file implements nice Scheme level threads on top of the gastly
25 #include "libguile/_scm.h"
32 #include "libguile/validate.h"
33 #include "libguile/root.h"
34 #include "libguile/eval.h"
35 #include "libguile/async.h"
36 #include "libguile/ports.h"
37 #include "libguile/threads.h"
38 #include "libguile/dynwind.h"
39 #include "libguile/iselect.h"
46 return scm_cons (SCM_EOL
, SCM_EOL
);
50 enqueue (SCM q
, SCM t
)
52 SCM c
= scm_cons (t
, SCM_EOL
);
53 if (SCM_NULLP (SCM_CDR (q
)))
56 SCM_SETCDR (SCM_CAR (q
), c
);
62 remqueue (SCM q
, SCM c
)
65 for (p
= SCM_CDR (q
); !SCM_NULLP (p
); p
= SCM_CDR (p
))
69 if (SCM_EQ_P (c
, SCM_CAR (q
)))
70 SCM_SETCAR (q
, SCM_CDR (c
));
71 SCM_SETCDR (prev
, SCM_CDR (c
));
87 SCM_SETCDR (q
, SCM_CDR (c
));
88 if (SCM_NULLP (SCM_CDR (q
)))
89 SCM_SETCAR (q
, SCM_EOL
);
96 #define THREAD_INITIALIZED_P(t) (t->base != NULL)
102 scm_t_cond sleep_cond
;
103 struct scm_thread
*next_waiting
;
105 /* This mutex represents this threads right to access the heap.
106 That right can temporarily be taken away by the GC. */
107 scm_t_mutex heap_mutex
;
108 int clear_freelists_p
; /* set if GC was done while thread was asleep */
110 scm_root_state
*root
;
116 /* For keeping track of the stack and registers. */
124 make_thread (SCM creation_protects
)
128 z
= scm_make_smob (scm_tc16_thread
);
129 t
= SCM_THREAD_DATA (z
);
131 t
->result
= creation_protects
;
133 scm_i_plugin_cond_init (&t
->sleep_cond
, 0);
134 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
135 t
->clear_freelists_p
= 0;
141 init_thread_creatant (SCM thread
,
144 scm_thread
*t
= SCM_THREAD_DATA (thread
);
145 t
->thread
= scm_thread_self ();
151 thread_mark (SCM obj
)
153 scm_thread
*t
= SCM_THREAD_DATA (obj
);
154 scm_gc_mark (t
->result
);
155 return t
->root
->handle
; /* mark root-state of this thread */
159 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
161 scm_thread
*t
= SCM_THREAD_DATA (exp
);
162 scm_puts ("#<thread ", port
);
163 scm_intprint ((unsigned long)t
->thread
, 10, port
);
164 scm_puts (" (", port
);
165 scm_intprint ((unsigned long)t
, 16, port
);
166 scm_puts (")>", port
);
171 thread_free (SCM obj
)
173 scm_thread
*t
= SCM_THREAD_DATA (obj
);
176 scm_gc_free (t
, sizeof (*t
), "thread");
182 #define cur_thread (SCM_CURRENT_THREAD->handle)
183 scm_t_key scm_i_thread_key
;
184 scm_t_key scm_i_root_state_key
;
187 scm_i_set_thread_data (void *data
)
189 scm_thread
*t
= SCM_CURRENT_THREAD
;
190 scm_setspecific (scm_i_root_state_key
, data
);
191 t
->root
= (scm_root_state
*)data
;
195 resume (scm_thread
*t
)
198 if (t
->clear_freelists_p
)
200 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
201 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
202 t
->clear_freelists_p
= 0;
207 scm_i_enter_guile (scm_thread
*t
)
209 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
216 scm_thread
*c
= SCM_CURRENT_THREAD
;
218 /* record top of stack for the GC */
219 c
->top
= SCM_STACK_PTR (&c
);
220 /* save registers. */
221 SCM_FLUSH_REGISTER_WINDOWS
;
230 scm_thread
*t
= suspend ();
231 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
235 /* Put the current thread to sleep until it is explicitely unblocked.
241 scm_thread
*t
= suspend ();
242 err
= scm_i_plugin_cond_wait (&t
->sleep_cond
, &t
->heap_mutex
);
247 /* Put the current thread to sleep until it is explicitely unblocked
248 or until a signal arrives or until time AT (absolute time) is
249 reached. Return 0 when it has been unblocked; errno otherwise.
252 timed_block (const scm_t_timespec
*at
)
255 scm_thread
*t
= suspend ();
256 err
= scm_i_plugin_cond_timedwait (&t
->sleep_cond
, &t
->heap_mutex
, at
);
261 /* Unblock a sleeping thread.
264 unblock (scm_thread
*t
)
266 scm_i_plugin_cond_signal (&t
->sleep_cond
);
269 /*** Thread creation */
271 static scm_t_mutex thread_admin_mutex
;
272 static SCM all_threads
;
273 static int thread_count
;
275 typedef struct launch_data
{
278 scm_t_catch_body body
;
280 scm_t_catch_handler handler
;
285 body_bootstrip (launch_data
* data
)
287 /* First save the new root continuation */
288 data
->rootcont
= scm_root
->rootcont
;
289 return (data
->body
) (data
->body_data
);
293 handler_bootstrip (launch_data
* data
, SCM tag
, SCM throw_args
)
295 scm_root
->rootcont
= data
->rootcont
;
296 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
300 really_launch (SCM_STACKITEM
*base
, launch_data
*data
)
304 thread
= data
->thread
;
305 t
= SCM_THREAD_DATA (thread
);
306 SCM_FREELIST_CREATE (scm_i_freelist
);
307 SCM_FREELIST_CREATE (scm_i_freelist2
);
308 scm_setspecific (scm_i_thread_key
, t
);
309 scm_setspecific (scm_i_root_state_key
, t
->root
);
310 scm_i_plugin_mutex_lock (&t
->heap_mutex
); /* ensure that we "own" the heap */
311 init_thread_creatant (thread
, base
); /* must own the heap */
313 data
->rootcont
= SCM_BOOL_F
;
315 scm_internal_cwdr ((scm_t_catch_body
) body_bootstrip
,
317 (scm_t_catch_handler
) handler_bootstrip
,
319 scm_i_leave_guile (); /* release the heap */
322 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
323 all_threads
= scm_delq_x (thread
, all_threads
);
326 /* detach before unlocking in order to not become joined when detached */
327 scm_thread_detach (t
->thread
);
328 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
332 launch_thread (void *p
)
334 really_launch (SCM_STACK_PTR (&p
), (launch_data
*) p
);
339 create_thread (scm_t_catch_body body
, void *body_data
,
340 scm_t_catch_handler handler
, void *handler_data
,
345 /* Make new thread. The first thing the new thread will do is to
346 lock guile_mutex. Thus, we can safely complete its
347 initialization after creating it. While the new thread starts,
348 all its data is protected via all_threads.
358 /* Allocate thread locals. */
359 root
= scm_make_root (scm_root
->handle
);
360 data
= scm_malloc (sizeof (launch_data
));
363 thread
= make_thread (protects
);
364 data
->thread
= thread
;
366 data
->body_data
= body_data
;
367 data
->handler
= handler
;
368 data
->handler_data
= handler_data
;
369 t
= SCM_THREAD_DATA (thread
);
370 /* must initialize root state pointer before the thread is linked
372 t
->root
= SCM_ROOT_STATE (root
);
373 /* disconnect from parent, to prevent remembering dead threads */
374 t
->root
->parent
= SCM_BOOL_F
;
375 /* start with an empty dynwind chain */
376 t
->root
->dynwinds
= SCM_EOL
;
378 /* In order to avoid the need of synchronization between parent
379 and child thread, we need to insert the child into all_threads
382 SCM new_threads
= scm_cons (thread
, SCM_BOOL_F
); /* could cause GC */
383 scm_thread
*parent
= scm_i_leave_guile (); /* to prevent deadlock */
384 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
385 SCM_SETCDR (new_threads
, all_threads
);
386 all_threads
= new_threads
;
388 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
390 scm_remember_upto_here_1 (root
);
392 scm_i_enter_guile (parent
);
395 err
= scm_i_plugin_thread_create (&th
, 0, launch_thread
, (void *) data
);
398 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
399 all_threads
= scm_delq_x (thread
, all_threads
);
400 ((scm_thread
*) SCM_THREAD_DATA(thread
))->exited
= 1;
402 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
408 scm_syserror ("create-thread");
415 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 2, 0, 0,
416 (SCM thunk
, SCM handler
),
417 "Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
418 "returning a new thread object representing the thread. "
419 "If an error occurs during evaluation, call error-thunk, passing it an "
420 "error code describing the condition. "
421 "If this happens, the error-thunk is called outside the scope of the new "
422 "root -- it is called in the same dynamic context in which "
423 "with-new-thread was evaluated, but not in the callers thread. "
424 "All the evaluation rules for dynamic roots apply to threads.")
425 #define FUNC_NAME s_scm_call_with_new_thread
427 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
428 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)), handler
, SCM_ARG2
,
431 return create_thread ((scm_t_catch_body
) scm_call_0
, thunk
,
432 (scm_t_catch_handler
) scm_apply_1
, handler
,
433 scm_cons (thunk
, handler
));
437 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
439 "Move the calling thread to the end of the scheduling queue.")
440 #define FUNC_NAME s_scm_yield
442 return SCM_BOOL (scm_thread_yield
);
446 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
448 "Suspend execution of the calling thread until the target @var{thread} "
449 "terminates, unless the target @var{thread} has already terminated. ")
450 #define FUNC_NAME s_scm_join_thread
455 SCM_VALIDATE_THREAD (1, thread
);
456 if (SCM_EQ_P (cur_thread
, thread
))
457 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
459 t
= SCM_THREAD_DATA (thread
);
463 c
= scm_i_leave_guile ();
464 while (!THREAD_INITIALIZED_P (t
))
465 scm_i_plugin_thread_yield ();
466 scm_thread_join (t
->thread
, 0);
467 scm_i_enter_guile (c
);
470 t
->result
= SCM_BOOL_F
;
477 /* We implement our own mutex type since we want them to be 'fair', we
478 want to do fancy things while waiting for them (like running
479 asyncs) and we want to support waiting on many things at once.
480 Also, we might add things that are nice for debugging.
483 typedef struct fair_mutex
{
484 /* the thread currently owning the mutex, or SCM_BOOL_F. */
488 /* how much the owner owns us. */
490 /* the threads waiting for this mutex. */
495 fair_mutex_mark (SCM mx
)
497 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
498 scm_gc_mark (m
->owner
);
502 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
504 "Create a new fair mutex object. ")
505 #define FUNC_NAME s_scm_make_fair_mutex
507 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
508 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
509 scm_i_plugin_mutex_init (&m
->lock
, &scm_i_plugin_mutex
);
511 m
->owner
= SCM_BOOL_F
;
513 m
->waiting
= make_queue ();
519 fair_mutex_lock (fair_mutex
*m
)
521 scm_i_plugin_mutex_lock (&m
->lock
);
523 /* Need to wait if another thread is just temporarily unlocking.
524 This is happens very seldom and only when the other thread is
525 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
531 if (m
->owner
== SCM_BOOL_F
)
532 m
->owner
= cur_thread
;
533 else if (m
->owner
== cur_thread
)
539 SCM c
= enqueue (m
->waiting
, cur_thread
);
541 /* Note: It's important that m->lock is never locked for
542 any longer amount of time since that could prevent GC */
543 scm_i_plugin_mutex_unlock (&m
->lock
);
545 if (m
->owner
== cur_thread
)
547 scm_i_plugin_mutex_lock (&m
->lock
);
548 remqueue (m
->waiting
, c
);
549 scm_i_plugin_mutex_unlock (&m
->lock
);
553 scm_i_plugin_mutex_lock (&m
->lock
);
556 scm_i_plugin_mutex_unlock (&m
->lock
);
561 fair_mutex_trylock (fair_mutex
*m
)
563 scm_i_plugin_mutex_lock (&m
->lock
);
564 if (m
->owner
== SCM_BOOL_F
)
565 m
->owner
= cur_thread
;
566 else if (m
->owner
== cur_thread
)
570 scm_i_plugin_mutex_unlock (&m
->lock
);
573 scm_i_plugin_mutex_unlock (&m
->lock
);
578 fair_mutex_unlock (fair_mutex
*m
)
580 scm_i_plugin_mutex_lock (&m
->lock
);
581 if (m
->owner
!= cur_thread
)
583 scm_i_plugin_mutex_unlock (&m
->lock
);
586 else if (m
->level
> 0)
590 SCM next
= dequeue (m
->waiting
);
591 if (!SCM_FALSEP (next
))
594 unblock (SCM_THREAD_DATA (next
));
597 m
->owner
= SCM_BOOL_F
;
599 scm_i_plugin_mutex_unlock (&m
->lock
);
603 /*** Fair condition variables */
605 /* Like mutexes, we implement our own condition variables using the
609 typedef struct fair_cond
{
611 /* the threads waiting for this condition. */
616 fair_cond_mark (SCM cv
)
618 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
622 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
624 "Make a new fair condition variable.")
625 #define FUNC_NAME s_scm_make_fair_condition_variable
627 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
628 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
629 scm_i_plugin_mutex_init (&c
->lock
, 0);
630 c
->waiting
= make_queue ();
636 fair_cond_timedwait (fair_cond
*c
,
638 const scm_t_timespec
*waittime
)
641 scm_i_plugin_mutex_lock (&c
->lock
);
645 enqueue (c
->waiting
, cur_thread
);
646 scm_i_plugin_mutex_unlock (&c
->lock
);
647 fair_mutex_unlock (m
); /*fixme* - not thread safe */
648 if (waittime
== NULL
)
651 err
= timed_block (waittime
);
655 /* XXX - check whether we have been signalled. */
662 fair_cond_signal (fair_cond
*c
)
665 scm_i_plugin_mutex_lock (&c
->lock
);
666 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
667 unblock (SCM_THREAD_DATA (th
));
668 scm_i_plugin_mutex_unlock (&c
->lock
);
673 fair_cond_broadcast (fair_cond
*c
)
676 scm_i_plugin_mutex_lock (&c
->lock
);
677 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
678 unblock (SCM_THREAD_DATA (th
));
679 scm_i_plugin_mutex_unlock (&c
->lock
);
685 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
687 "Create a new mutex object. ")
688 #define FUNC_NAME s_scm_make_mutex
690 SCM mx
= scm_make_smob (scm_tc16_mutex
);
691 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), &scm_i_plugin_mutex
);
696 /*fixme* change documentation */
697 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
699 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
700 "blocks until the mutex becomes available. The function returns when "
701 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
702 "a thread already owns will succeed right away and will not block the "
703 "thread. That is, Guile's mutexes are @emph{recursive}. ")
704 #define FUNC_NAME s_scm_lock_mutex
707 SCM_VALIDATE_MUTEX (1, mx
);
709 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
710 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
713 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
714 err
= scm_mutex_lock (m
);
726 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
728 "Try to lock @var{mutex}. If the mutex is already locked by someone "
729 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
730 #define FUNC_NAME s_scm_try_mutex
733 SCM_VALIDATE_MUTEX (1, mx
);
735 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
736 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
739 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
740 err
= scm_mutex_trylock (m
);
756 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
758 "Unlocks @var{mutex} if the calling thread owns the lock on "
759 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
760 "thread results in undefined behaviour. Once a mutex has been unlocked, "
761 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
762 "lock. Every call to @code{lock-mutex} by this thread must be matched "
763 "with a call to @code{unlock-mutex}. Only the last call to "
764 "@code{unlock-mutex} will actually unlock the mutex. ")
765 #define FUNC_NAME s_scm_unlock_mutex
768 SCM_VALIDATE_MUTEX (1, mx
);
770 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
772 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
775 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
776 if (m
->owner
!= cur_thread
)
778 if (m
->owner
== SCM_BOOL_F
)
779 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
781 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
787 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
788 err
= scm_mutex_unlock (m
);
800 /*** Condition variables */
802 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
804 "Make a new condition variable.")
805 #define FUNC_NAME s_scm_make_condition_variable
807 SCM cv
= scm_make_smob (scm_tc16_condvar
);
808 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
813 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
814 (SCM cv
, SCM mx
, SCM t
),
815 "Wait until @var{cond-var} has been signalled. While waiting, "
816 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
817 "is locked again when this function returns. When @var{time} is given, "
818 "it specifies a point in time where the waiting should be aborted. It "
819 "can be either a integer as returned by @code{current-time} or a pair "
820 "as returned by @code{gettimeofday}. When the waiting is aborted the "
821 "mutex is locked and @code{#f} is returned. When the condition "
822 "variable is in fact signalled, the mutex is also locked and @code{#t} "
824 #define FUNC_NAME s_scm_timed_wait_condition_variable
826 scm_t_timespec waittime
;
829 SCM_VALIDATE_CONDVAR (1, cv
);
830 SCM_VALIDATE_MUTEX (2, mx
);
831 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
832 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
833 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
834 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
835 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
842 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
843 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
844 waittime
.tv_nsec
*= 1000;
848 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
849 waittime
.tv_nsec
= 0;
853 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
854 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
856 SCM_UNBNDP (t
) ? NULL
: &waittime
);
859 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
860 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
862 err
= scm_cond_wait (c
, m
);
864 err
= scm_cond_timedwait (c
, m
, &waittime
);
869 if (err
== ETIMEDOUT
)
878 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
880 "Wake up one thread that is waiting for @var{cv}")
881 #define FUNC_NAME s_scm_signal_condition_variable
883 SCM_VALIDATE_CONDVAR (1, cv
);
884 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
885 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
888 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
895 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
897 "Wake up all threads that are waiting for @var{cv}. ")
898 #define FUNC_NAME s_scm_broadcast_condition_variable
900 SCM_VALIDATE_CONDVAR (1, cv
);
901 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
902 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
905 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
906 scm_cond_broadcast (c
);
912 /*** Marking stacks */
914 /* XXX - what to do with this? Do we need to handle this for blocked
918 # define SCM_MARK_BACKING_STORE() do { \
920 SCM_STACKITEM * top, * bot; \
922 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
923 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
924 / sizeof (SCM_STACKITEM))); \
925 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
926 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
927 scm_mark_locations (bot, top - bot); } while (0)
929 # define SCM_MARK_BACKING_STORE()
933 scm_threads_mark_stacks (void)
936 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
938 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
939 if (!THREAD_INITIALIZED_P (t
))
941 /* Not fully initialized yet. */
948 if (t
->thread
!= scm_thread_self ())
952 /* stack_len is long rather than sizet in order to guarantee
953 that &stack_len is long aligned */
954 #if SCM_STACK_GROWS_UP
955 stack_len
= SCM_STACK_PTR (&t
) - t
->base
;
957 /* Protect from the C stack. This must be the first marking
958 * done because it provides information about what objects
959 * are "in-use" by the C code. "in-use" objects are those
960 * for which the information about length and base address must
961 * remain usable. This requirement is stricter than a liveness
962 * requirement -- in particular, it constrains the implementation
965 SCM_FLUSH_REGISTER_WINDOWS
;
966 /* This assumes that all registers are saved into the jmp_buf */
967 setjmp (scm_save_regs_gc_mark
);
968 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
969 ((size_t) sizeof scm_save_regs_gc_mark
970 / sizeof (SCM_STACKITEM
)));
972 scm_mark_locations (((size_t) t
->base
,
975 stack_len
= t
->base
- SCM_STACK_PTR (&t
);
977 /* Protect from the C stack. This must be the first marking
978 * done because it provides information about what objects
979 * are "in-use" by the C code. "in-use" objects are those
980 * for which the information about length and base address must
981 * remain usable. This requirement is stricter than a liveness
982 * requirement -- in particular, it constrains the implementation
985 SCM_FLUSH_REGISTER_WINDOWS
;
986 /* This assumes that all registers are saved into the jmp_buf */
987 setjmp (scm_save_regs_gc_mark
);
988 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
989 ((size_t) sizeof scm_save_regs_gc_mark
990 / sizeof (SCM_STACKITEM
)));
992 scm_mark_locations (SCM_STACK_PTR (&t
), stack_len
);
997 /* Suspended thread */
998 #if SCM_STACK_GROWS_UP
999 long stack_len
= t
->top
- t
->base
;
1000 scm_mark_locations (t
->base
, stack_len
);
1002 long stack_len
= t
->base
- t
->top
;
1003 scm_mark_locations (t
->top
, stack_len
);
1005 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1006 ((size_t) sizeof(t
->regs
)
1007 / sizeof (SCM_STACKITEM
)));
1015 scm_internal_select (int nfds
,
1016 SELECT_TYPE
*readfds
,
1017 SELECT_TYPE
*writefds
,
1018 SELECT_TYPE
*exceptfds
,
1019 struct timeval
*timeout
)
1022 scm_thread
*c
= scm_i_leave_guile ();
1023 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1025 scm_i_enter_guile (c
);
1031 /* Low-level C API */
1034 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1035 scm_t_catch_handler handler
, void *handler_data
)
1037 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1041 scm_mutex_lock (scm_t_mutex
*m
)
1043 scm_thread
*t
= scm_i_leave_guile ();
1044 int res
= scm_i_plugin_mutex_lock (m
);
1045 scm_i_enter_guile (t
);
1050 scm_make_rec_mutex ()
1052 scm_t_rec_mutex
*m
= scm_malloc (sizeof (scm_t_rec_mutex
));
1053 scm_i_plugin_rec_mutex_init (m
, &scm_i_plugin_rec_mutex
);
1058 scm_rec_mutex_free (scm_t_rec_mutex
*m
)
1060 scm_i_plugin_rec_mutex_destroy (m
);
1065 scm_rec_mutex_lock (scm_t_rec_mutex
*m
)
1067 scm_thread
*t
= scm_i_leave_guile ();
1068 int res
= scm_i_plugin_rec_mutex_lock (m
);
1069 scm_i_enter_guile (t
);
1074 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1076 scm_thread
*t
= scm_i_leave_guile ();
1077 scm_i_plugin_cond_wait (c
, m
);
1078 scm_i_enter_guile (t
);
1083 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
, const scm_t_timespec
*wt
)
1085 scm_thread
*t
= scm_i_leave_guile ();
1086 int res
= scm_i_plugin_cond_timedwait (c
, m
, wt
);
1087 scm_i_enter_guile (t
);
1094 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1100 scm_i_leave_guile ();
1104 scm_thread_usleep (unsigned long usecs
)
1107 tv
.tv_usec
= usecs
% 1000000;
1108 tv
.tv_sec
= usecs
/ 1000000;
1109 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1110 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1114 scm_thread_sleep (unsigned long secs
)
1119 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1125 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1127 "Return the thread that called this function.")
1128 #define FUNC_NAME s_scm_current_thread
1134 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1136 "Return a list of all threads.")
1137 #define FUNC_NAME s_scm_all_threads
1139 return scm_list_copy (all_threads
);
1144 scm_i_thread_root (SCM thread
)
1146 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1149 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1151 "Return @code{#t} iff @var{thread} has exited.\n")
1152 #define FUNC_NAME s_scm_thread_exited_p
1154 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1159 scm_c_thread_exited_p (SCM thread
)
1160 #define FUNC_NAME s_scm_thread_exited_p
1163 SCM_VALIDATE_THREAD (1, thread
);
1164 t
= SCM_THREAD_DATA (thread
);
1169 static scm_t_cond wake_up_cond
;
1170 int scm_i_thread_go_to_sleep
;
1171 static int gc_section_count
= 0;
1172 static int threads_initialized_p
= 0;
1175 scm_i_thread_put_to_sleep ()
1177 if (threads_initialized_p
&& !gc_section_count
++)
1180 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1181 threads
= all_threads
;
1182 /* Signal all threads to go to sleep */
1183 scm_i_thread_go_to_sleep
= 1;
1184 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1185 if (SCM_CAR (threads
) != cur_thread
)
1187 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1188 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1190 scm_i_thread_go_to_sleep
= 0;
1195 scm_i_thread_invalidate_freelists ()
1197 /* Don't need to lock thread_admin_mutex here since we are single threaded */
1198 SCM threads
= all_threads
;
1199 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1200 if (SCM_CAR (threads
) != cur_thread
)
1202 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1203 t
->clear_freelists_p
= 1;
1208 scm_i_thread_wake_up ()
1210 if (threads_initialized_p
&& !--gc_section_count
)
1213 threads
= all_threads
;
1214 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1215 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1216 if (SCM_CAR (threads
) != cur_thread
)
1218 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1219 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1221 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1226 scm_i_thread_sleep_for_gc ()
1230 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1234 scm_t_mutex scm_i_critical_section_mutex
;
1235 scm_t_rec_mutex scm_i_defer_mutex
;
1237 #if SCM_USE_PTHREAD_THREADS
1238 # include "libguile/pthread-threads.c"
1240 #include "libguile/threads-plugin.c"
1242 /*** Initialization */
1245 scm_threads_prehistory ()
1248 #if SCM_USE_PTHREAD_THREADS
1249 /* Must be called before any initialization of a mutex. */
1250 scm_init_pthread_threads ();
1252 scm_i_plugin_mutex_init (&thread_admin_mutex
, &scm_i_plugin_mutex
);
1253 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1254 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, &scm_i_plugin_mutex
);
1256 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1257 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1258 scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex
, &scm_i_plugin_rec_mutex
);
1259 /* Allocate a fake thread object to be used during bootup. */
1260 t
= malloc (sizeof (scm_thread
));
1262 t
->clear_freelists_p
= 0;
1263 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
1264 scm_setspecific (scm_i_thread_key
, t
);
1265 scm_i_enter_guile (t
);
1268 scm_t_bits scm_tc16_thread
;
1269 scm_t_bits scm_tc16_future
;
1270 scm_t_bits scm_tc16_mutex
;
1271 scm_t_bits scm_tc16_fair_mutex
;
1272 scm_t_bits scm_tc16_condvar
;
1273 scm_t_bits scm_tc16_fair_condvar
;
1276 scm_init_threads (SCM_STACKITEM
*base
)
1279 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1280 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1281 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1282 sizeof (fair_mutex
));
1283 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1284 sizeof (scm_t_cond
));
1285 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1286 sizeof (fair_cond
));
1288 thread
= make_thread (SCM_BOOL_F
);
1289 /* Replace initial fake thread with a real thread object */
1290 free (SCM_CURRENT_THREAD
);
1291 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1292 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1294 /* root is set later from init.c */
1295 init_thread_creatant (thread
, base
);
1297 scm_gc_register_root (&all_threads
);
1298 all_threads
= scm_cons (thread
, SCM_EOL
);
1300 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1301 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1302 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1304 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1306 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1308 threads_initialized_p
= 1;
1312 scm_init_thread_procs ()
1314 #include "libguile/threads.x"