1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004 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"
36 #include "libguile/validate.h"
37 #include "libguile/root.h"
38 #include "libguile/eval.h"
39 #include "libguile/async.h"
40 #include "libguile/ports.h"
41 #include "libguile/threads.h"
42 #include "libguile/dynwind.h"
43 #include "libguile/iselect.h"
50 return scm_cons (SCM_EOL
, SCM_EOL
);
54 enqueue (SCM q
, SCM t
)
56 SCM c
= scm_cons (t
, SCM_EOL
);
57 if (SCM_NULLP (SCM_CDR (q
)))
60 SCM_SETCDR (SCM_CAR (q
), c
);
66 remqueue (SCM q
, SCM c
)
69 for (p
= SCM_CDR (q
); !SCM_NULLP (p
); p
= SCM_CDR (p
))
73 if (SCM_EQ_P (c
, SCM_CAR (q
)))
74 SCM_SETCAR (q
, SCM_CDR (c
));
75 SCM_SETCDR (prev
, SCM_CDR (c
));
91 SCM_SETCDR (q
, SCM_CDR (c
));
92 if (SCM_NULLP (SCM_CDR (q
)))
93 SCM_SETCAR (q
, SCM_EOL
);
100 #define THREAD_INITIALIZED_P(t) (t->base != NULL)
106 scm_t_cond sleep_cond
;
107 struct scm_thread
*next_waiting
;
109 /* This mutex represents this threads right to access the heap.
110 That right can temporarily be taken away by the GC. */
111 scm_t_mutex heap_mutex
;
112 int clear_freelists_p
; /* set if GC was done while thread was asleep */
114 scm_root_state
*root
;
120 /* For keeping track of the stack and registers. */
128 make_thread (SCM creation_protects
)
132 z
= scm_make_smob (scm_tc16_thread
);
133 t
= SCM_THREAD_DATA (z
);
135 t
->result
= creation_protects
;
137 scm_i_plugin_cond_init (&t
->sleep_cond
, 0);
138 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
139 t
->clear_freelists_p
= 0;
145 init_thread_creatant (SCM thread
,
148 scm_thread
*t
= SCM_THREAD_DATA (thread
);
149 t
->thread
= scm_thread_self ();
155 thread_mark (SCM obj
)
157 scm_thread
*t
= SCM_THREAD_DATA (obj
);
158 scm_gc_mark (t
->result
);
159 return t
->root
->handle
; /* mark root-state of this thread */
163 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
165 scm_thread
*t
= SCM_THREAD_DATA (exp
);
166 scm_puts ("#<thread ", port
);
167 scm_intprint ((unsigned long)t
->thread
, 10, port
);
168 scm_puts (" (", port
);
169 scm_intprint ((unsigned long)t
, 16, port
);
170 scm_puts (")>", port
);
175 thread_free (SCM obj
)
177 scm_thread
*t
= SCM_THREAD_DATA (obj
);
180 scm_gc_free (t
, sizeof (*t
), "thread");
186 #define cur_thread (SCM_CURRENT_THREAD->handle)
187 scm_t_key scm_i_thread_key
;
188 scm_t_key scm_i_root_state_key
;
191 scm_i_set_thread_data (void *data
)
193 scm_thread
*t
= SCM_CURRENT_THREAD
;
194 scm_setspecific (scm_i_root_state_key
, data
);
195 t
->root
= (scm_root_state
*)data
;
199 resume (scm_thread
*t
)
202 if (t
->clear_freelists_p
)
204 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
205 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
206 t
->clear_freelists_p
= 0;
211 scm_i_enter_guile (scm_thread
*t
)
213 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
220 scm_thread
*c
= SCM_CURRENT_THREAD
;
222 /* record top of stack for the GC */
223 c
->top
= SCM_STACK_PTR (&c
);
224 /* save registers. */
225 SCM_FLUSH_REGISTER_WINDOWS
;
234 scm_thread
*t
= suspend ();
235 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
239 /* Put the current thread to sleep until it is explicitely unblocked.
245 scm_thread
*t
= suspend ();
246 err
= scm_i_plugin_cond_wait (&t
->sleep_cond
, &t
->heap_mutex
);
251 /* Put the current thread to sleep until it is explicitely unblocked
252 or until a signal arrives or until time AT (absolute time) is
253 reached. Return 0 when it has been unblocked; errno otherwise.
256 timed_block (const scm_t_timespec
*at
)
259 scm_thread
*t
= suspend ();
260 err
= scm_i_plugin_cond_timedwait (&t
->sleep_cond
, &t
->heap_mutex
, at
);
265 /* Unblock a sleeping thread.
268 unblock (scm_thread
*t
)
270 scm_i_plugin_cond_signal (&t
->sleep_cond
);
273 /*** Thread creation */
275 static scm_t_mutex thread_admin_mutex
;
276 static SCM all_threads
;
277 static int thread_count
;
279 typedef struct launch_data
{
282 scm_t_catch_body body
;
284 scm_t_catch_handler handler
;
289 body_bootstrip (launch_data
* data
)
291 /* First save the new root continuation */
292 data
->rootcont
= scm_root
->rootcont
;
293 return (data
->body
) (data
->body_data
);
297 handler_bootstrip (launch_data
* data
, SCM tag
, SCM throw_args
)
299 scm_root
->rootcont
= data
->rootcont
;
300 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
304 really_launch (SCM_STACKITEM
*base
, launch_data
*data
)
308 thread
= data
->thread
;
309 t
= SCM_THREAD_DATA (thread
);
310 SCM_FREELIST_CREATE (scm_i_freelist
);
311 SCM_FREELIST_CREATE (scm_i_freelist2
);
312 scm_setspecific (scm_i_thread_key
, t
);
313 scm_setspecific (scm_i_root_state_key
, t
->root
);
314 scm_i_plugin_mutex_lock (&t
->heap_mutex
); /* ensure that we "own" the heap */
315 init_thread_creatant (thread
, base
); /* must own the heap */
317 data
->rootcont
= SCM_BOOL_F
;
319 scm_internal_cwdr ((scm_t_catch_body
) body_bootstrip
,
321 (scm_t_catch_handler
) handler_bootstrip
,
323 scm_i_leave_guile (); /* release the heap */
326 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
327 all_threads
= scm_delq_x (thread
, all_threads
);
330 /* detach before unlocking in order to not become joined when detached */
331 scm_thread_detach (t
->thread
);
332 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
336 launch_thread (void *p
)
338 really_launch (SCM_STACK_PTR (&p
), (launch_data
*) p
);
343 create_thread (scm_t_catch_body body
, void *body_data
,
344 scm_t_catch_handler handler
, void *handler_data
,
349 /* Make new thread. The first thing the new thread will do is to
350 lock guile_mutex. Thus, we can safely complete its
351 initialization after creating it. While the new thread starts,
352 all its data is protected via all_threads.
362 /* Allocate thread locals. */
363 root
= scm_make_root (scm_root
->handle
);
364 data
= scm_malloc (sizeof (launch_data
));
367 thread
= make_thread (protects
);
368 data
->thread
= thread
;
370 data
->body_data
= body_data
;
371 data
->handler
= handler
;
372 data
->handler_data
= handler_data
;
373 t
= SCM_THREAD_DATA (thread
);
374 /* must initialize root state pointer before the thread is linked
376 t
->root
= SCM_ROOT_STATE (root
);
377 /* disconnect from parent, to prevent remembering dead threads */
378 t
->root
->parent
= SCM_BOOL_F
;
379 /* start with an empty dynwind chain */
380 t
->root
->dynwinds
= SCM_EOL
;
382 /* In order to avoid the need of synchronization between parent
383 and child thread, we need to insert the child into all_threads
386 SCM new_threads
= scm_cons (thread
, SCM_BOOL_F
); /* could cause GC */
387 scm_thread
*parent
= scm_i_leave_guile (); /* to prevent deadlock */
388 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
389 SCM_SETCDR (new_threads
, all_threads
);
390 all_threads
= new_threads
;
392 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
394 scm_remember_upto_here_1 (root
);
396 scm_i_enter_guile (parent
);
399 err
= scm_i_plugin_thread_create (&th
, 0, launch_thread
, (void *) data
);
402 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
403 all_threads
= scm_delq_x (thread
, all_threads
);
404 ((scm_thread
*) SCM_THREAD_DATA(thread
))->exited
= 1;
406 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
412 scm_syserror ("create-thread");
419 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 2, 0, 0,
420 (SCM thunk
, SCM handler
),
421 "Evaluate @code{(@var{thunk})} in a new thread, and new dynamic context, "
422 "returning a new thread object representing the thread. "
423 "If an error occurs during evaluation, call error-thunk, passing it an "
424 "error code describing the condition. "
425 "If this happens, the error-thunk is called outside the scope of the new "
426 "root -- it is called in the same dynamic context in which "
427 "with-new-thread was evaluated, but not in the callers thread. "
428 "All the evaluation rules for dynamic roots apply to threads.")
429 #define FUNC_NAME s_scm_call_with_new_thread
431 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
432 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)), handler
, SCM_ARG2
,
435 return create_thread ((scm_t_catch_body
) scm_call_0
, thunk
,
436 (scm_t_catch_handler
) scm_apply_1
, handler
,
437 scm_cons (thunk
, handler
));
441 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
443 "Move the calling thread to the end of the scheduling queue.")
444 #define FUNC_NAME s_scm_yield
446 return SCM_BOOL (scm_thread_yield ());
450 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
452 "Suspend execution of the calling thread until the target @var{thread} "
453 "terminates, unless the target @var{thread} has already terminated. ")
454 #define FUNC_NAME s_scm_join_thread
459 SCM_VALIDATE_THREAD (1, thread
);
460 if (SCM_EQ_P (cur_thread
, thread
))
461 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
463 t
= SCM_THREAD_DATA (thread
);
467 c
= scm_i_leave_guile ();
468 while (!THREAD_INITIALIZED_P (t
))
469 scm_i_plugin_thread_yield ();
470 scm_thread_join (t
->thread
, 0);
471 scm_i_enter_guile (c
);
474 t
->result
= SCM_BOOL_F
;
481 /* We implement our own mutex type since we want them to be 'fair', we
482 want to do fancy things while waiting for them (like running
483 asyncs) and we want to support waiting on many things at once.
484 Also, we might add things that are nice for debugging.
487 typedef struct fair_mutex
{
488 /* the thread currently owning the mutex, or SCM_BOOL_F. */
492 /* how much the owner owns us. */
494 /* the threads waiting for this mutex. */
499 fair_mutex_mark (SCM mx
)
501 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
502 scm_gc_mark (m
->owner
);
506 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
508 "Create a new fair mutex object. ")
509 #define FUNC_NAME s_scm_make_fair_mutex
511 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
512 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
513 scm_i_plugin_mutex_init (&m
->lock
, &scm_i_plugin_mutex
);
515 m
->owner
= SCM_BOOL_F
;
517 m
->waiting
= make_queue ();
523 fair_mutex_lock (fair_mutex
*m
)
525 scm_i_plugin_mutex_lock (&m
->lock
);
527 /* Need to wait if another thread is just temporarily unlocking.
528 This is happens very seldom and only when the other thread is
529 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
535 if (m
->owner
== SCM_BOOL_F
)
536 m
->owner
= cur_thread
;
537 else if (m
->owner
== cur_thread
)
543 SCM c
= enqueue (m
->waiting
, cur_thread
);
545 /* Note: It's important that m->lock is never locked for
546 any longer amount of time since that could prevent GC */
547 scm_i_plugin_mutex_unlock (&m
->lock
);
549 if (m
->owner
== cur_thread
)
551 scm_i_plugin_mutex_lock (&m
->lock
);
552 remqueue (m
->waiting
, c
);
553 scm_i_plugin_mutex_unlock (&m
->lock
);
557 scm_i_plugin_mutex_lock (&m
->lock
);
560 scm_i_plugin_mutex_unlock (&m
->lock
);
565 fair_mutex_trylock (fair_mutex
*m
)
567 scm_i_plugin_mutex_lock (&m
->lock
);
568 if (m
->owner
== SCM_BOOL_F
)
569 m
->owner
= cur_thread
;
570 else if (m
->owner
== cur_thread
)
574 scm_i_plugin_mutex_unlock (&m
->lock
);
577 scm_i_plugin_mutex_unlock (&m
->lock
);
582 fair_mutex_unlock (fair_mutex
*m
)
584 scm_i_plugin_mutex_lock (&m
->lock
);
585 if (m
->owner
!= cur_thread
)
587 scm_i_plugin_mutex_unlock (&m
->lock
);
590 else if (m
->level
> 0)
594 SCM next
= dequeue (m
->waiting
);
595 if (!SCM_FALSEP (next
))
598 unblock (SCM_THREAD_DATA (next
));
601 m
->owner
= SCM_BOOL_F
;
603 scm_i_plugin_mutex_unlock (&m
->lock
);
607 /*** Fair condition variables */
609 /* Like mutexes, we implement our own condition variables using the
613 typedef struct fair_cond
{
615 /* the threads waiting for this condition. */
620 fair_cond_mark (SCM cv
)
622 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
626 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
628 "Make a new fair condition variable.")
629 #define FUNC_NAME s_scm_make_fair_condition_variable
631 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
632 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
633 scm_i_plugin_mutex_init (&c
->lock
, 0);
634 c
->waiting
= make_queue ();
640 fair_cond_timedwait (fair_cond
*c
,
642 const scm_t_timespec
*waittime
)
645 scm_i_plugin_mutex_lock (&c
->lock
);
649 enqueue (c
->waiting
, cur_thread
);
650 scm_i_plugin_mutex_unlock (&c
->lock
);
651 fair_mutex_unlock (m
); /*fixme* - not thread safe */
652 if (waittime
== NULL
)
655 err
= timed_block (waittime
);
659 /* XXX - check whether we have been signalled. */
666 fair_cond_signal (fair_cond
*c
)
669 scm_i_plugin_mutex_lock (&c
->lock
);
670 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
671 unblock (SCM_THREAD_DATA (th
));
672 scm_i_plugin_mutex_unlock (&c
->lock
);
677 fair_cond_broadcast (fair_cond
*c
)
680 scm_i_plugin_mutex_lock (&c
->lock
);
681 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
682 unblock (SCM_THREAD_DATA (th
));
683 scm_i_plugin_mutex_unlock (&c
->lock
);
689 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
691 "Create a new mutex object. ")
692 #define FUNC_NAME s_scm_make_mutex
694 SCM mx
= scm_make_smob (scm_tc16_mutex
);
695 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), &scm_i_plugin_mutex
);
700 /*fixme* change documentation */
701 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
703 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
704 "blocks until the mutex becomes available. The function returns when "
705 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
706 "a thread already owns will succeed right away and will not block the "
707 "thread. That is, Guile's mutexes are @emph{recursive}. ")
708 #define FUNC_NAME s_scm_lock_mutex
711 SCM_VALIDATE_MUTEX (1, mx
);
713 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
714 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
717 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
718 err
= scm_mutex_lock (m
);
730 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
732 "Try to lock @var{mutex}. If the mutex is already locked by someone "
733 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
734 #define FUNC_NAME s_scm_try_mutex
737 SCM_VALIDATE_MUTEX (1, mx
);
739 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
740 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
743 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
744 err
= scm_mutex_trylock (m
);
760 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
762 "Unlocks @var{mutex} if the calling thread owns the lock on "
763 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
764 "thread results in undefined behaviour. Once a mutex has been unlocked, "
765 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
766 "lock. Every call to @code{lock-mutex} by this thread must be matched "
767 "with a call to @code{unlock-mutex}. Only the last call to "
768 "@code{unlock-mutex} will actually unlock the mutex. ")
769 #define FUNC_NAME s_scm_unlock_mutex
772 SCM_VALIDATE_MUTEX (1, mx
);
774 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
776 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
779 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
780 if (m
->owner
!= cur_thread
)
782 if (m
->owner
== SCM_BOOL_F
)
783 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
785 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
791 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
792 err
= scm_mutex_unlock (m
);
804 /*** Condition variables */
806 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
808 "Make a new condition variable.")
809 #define FUNC_NAME s_scm_make_condition_variable
811 SCM cv
= scm_make_smob (scm_tc16_condvar
);
812 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
817 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
818 (SCM cv
, SCM mx
, SCM t
),
819 "Wait until @var{cond-var} has been signalled. While waiting, "
820 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
821 "is locked again when this function returns. When @var{time} is given, "
822 "it specifies a point in time where the waiting should be aborted. It "
823 "can be either a integer as returned by @code{current-time} or a pair "
824 "as returned by @code{gettimeofday}. When the waiting is aborted the "
825 "mutex is locked and @code{#f} is returned. When the condition "
826 "variable is in fact signalled, the mutex is also locked and @code{#t} "
828 #define FUNC_NAME s_scm_timed_wait_condition_variable
830 scm_t_timespec waittime
;
833 SCM_VALIDATE_CONDVAR (1, cv
);
834 SCM_VALIDATE_MUTEX (2, mx
);
835 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
836 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
837 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
838 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
839 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
846 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
847 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
848 waittime
.tv_nsec
*= 1000;
852 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
853 waittime
.tv_nsec
= 0;
857 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
858 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
860 SCM_UNBNDP (t
) ? NULL
: &waittime
);
863 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
864 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
866 err
= scm_cond_wait (c
, m
);
868 err
= scm_cond_timedwait (c
, m
, &waittime
);
873 if (err
== ETIMEDOUT
)
882 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
884 "Wake up one thread that is waiting for @var{cv}")
885 #define FUNC_NAME s_scm_signal_condition_variable
887 SCM_VALIDATE_CONDVAR (1, cv
);
888 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
889 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
892 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
899 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
901 "Wake up all threads that are waiting for @var{cv}. ")
902 #define FUNC_NAME s_scm_broadcast_condition_variable
904 SCM_VALIDATE_CONDVAR (1, cv
);
905 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
906 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
909 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
910 scm_cond_broadcast (c
);
916 /*** Marking stacks */
918 /* XXX - what to do with this? Do we need to handle this for blocked
922 # define SCM_MARK_BACKING_STORE() do { \
924 SCM_STACKITEM * top, * bot; \
926 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
927 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
928 / sizeof (SCM_STACKITEM))); \
929 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
930 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
931 scm_mark_locations (bot, top - bot); } while (0)
933 # define SCM_MARK_BACKING_STORE()
937 scm_threads_mark_stacks (void)
940 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
942 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
943 if (!THREAD_INITIALIZED_P (t
))
945 /* Not fully initialized yet. */
952 if (t
->thread
!= scm_thread_self ())
956 /* stack_len is long rather than size_t in order to guarantee
957 that &stack_len is long aligned */
958 #if SCM_STACK_GROWS_UP
959 stack_len
= SCM_STACK_PTR (&t
) - t
->base
;
961 /* Protect from the C stack. This must be the first marking
962 * done because it provides information about what objects
963 * are "in-use" by the C code. "in-use" objects are those
964 * for which the information about length and base address must
965 * remain usable. This requirement is stricter than a liveness
966 * requirement -- in particular, it constrains the implementation
969 SCM_FLUSH_REGISTER_WINDOWS
;
970 /* This assumes that all registers are saved into the jmp_buf */
971 setjmp (scm_save_regs_gc_mark
);
972 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
973 ((size_t) sizeof scm_save_regs_gc_mark
974 / sizeof (SCM_STACKITEM
)));
976 scm_mark_locations (((size_t) t
->base
,
977 (size_t) stack_len
));
979 stack_len
= t
->base
- SCM_STACK_PTR (&t
);
981 /* Protect from the C stack. This must be the first marking
982 * done because it provides information about what objects
983 * are "in-use" by the C code. "in-use" objects are those
984 * for which the information about length and base address must
985 * remain usable. This requirement is stricter than a liveness
986 * requirement -- in particular, it constrains the implementation
989 SCM_FLUSH_REGISTER_WINDOWS
;
990 /* This assumes that all registers are saved into the jmp_buf */
991 setjmp (scm_save_regs_gc_mark
);
992 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
993 ((size_t) sizeof scm_save_regs_gc_mark
994 / sizeof (SCM_STACKITEM
)));
996 scm_mark_locations (SCM_STACK_PTR (&t
), stack_len
);
1001 /* Suspended thread */
1002 #if SCM_STACK_GROWS_UP
1003 long stack_len
= t
->top
- t
->base
;
1004 scm_mark_locations (t
->base
, stack_len
);
1006 long stack_len
= t
->base
- t
->top
;
1007 scm_mark_locations (t
->top
, stack_len
);
1009 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1010 ((size_t) sizeof(t
->regs
)
1011 / sizeof (SCM_STACKITEM
)));
1019 scm_internal_select (int nfds
,
1020 SELECT_TYPE
*readfds
,
1021 SELECT_TYPE
*writefds
,
1022 SELECT_TYPE
*exceptfds
,
1023 struct timeval
*timeout
)
1026 scm_thread
*c
= scm_i_leave_guile ();
1027 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1029 scm_i_enter_guile (c
);
1035 /* Low-level C API */
1038 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1039 scm_t_catch_handler handler
, void *handler_data
)
1041 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1045 scm_c_scm2thread (SCM thread
)
1047 return SCM_THREAD_DATA (thread
)->thread
;
1051 scm_mutex_lock (scm_t_mutex
*m
)
1053 scm_thread
*t
= scm_i_leave_guile ();
1054 int res
= scm_i_plugin_mutex_lock (m
);
1055 scm_i_enter_guile (t
);
1060 scm_make_rec_mutex ()
1062 scm_t_rec_mutex
*m
= scm_malloc (sizeof (scm_t_rec_mutex
));
1063 scm_i_plugin_rec_mutex_init (m
, &scm_i_plugin_rec_mutex
);
1068 scm_rec_mutex_free (scm_t_rec_mutex
*m
)
1070 scm_i_plugin_rec_mutex_destroy (m
);
1075 scm_rec_mutex_lock (scm_t_rec_mutex
*m
)
1077 scm_thread
*t
= scm_i_leave_guile ();
1078 int res
= scm_i_plugin_rec_mutex_lock (m
);
1079 scm_i_enter_guile (t
);
1084 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1086 scm_thread
*t
= scm_i_leave_guile ();
1087 scm_i_plugin_cond_wait (c
, m
);
1088 scm_i_enter_guile (t
);
1093 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
, const scm_t_timespec
*wt
)
1095 scm_thread
*t
= scm_i_leave_guile ();
1096 int res
= scm_i_plugin_cond_timedwait (c
, m
, wt
);
1097 scm_i_enter_guile (t
);
1102 scm_getspecific (scm_t_key k
)
1104 return scm_i_plugin_getspecific (k
);
1108 scm_setspecific (scm_t_key k
, void *s
)
1110 return scm_i_plugin_setspecific (k
, s
);
1116 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1122 scm_i_leave_guile ();
1126 scm_thread_usleep (unsigned long usecs
)
1129 tv
.tv_usec
= usecs
% 1000000;
1130 tv
.tv_sec
= usecs
/ 1000000;
1131 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1132 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1136 scm_thread_sleep (unsigned long secs
)
1141 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1147 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1149 "Return the thread that called this function.")
1150 #define FUNC_NAME s_scm_current_thread
1156 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1158 "Return a list of all threads.")
1159 #define FUNC_NAME s_scm_all_threads
1161 return scm_list_copy (all_threads
);
1166 scm_i_thread_root (SCM thread
)
1168 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1171 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1173 "Return @code{#t} iff @var{thread} has exited.\n")
1174 #define FUNC_NAME s_scm_thread_exited_p
1176 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1181 scm_c_thread_exited_p (SCM thread
)
1182 #define FUNC_NAME s_scm_thread_exited_p
1185 SCM_VALIDATE_THREAD (1, thread
);
1186 t
= SCM_THREAD_DATA (thread
);
1191 static scm_t_cond wake_up_cond
;
1192 int scm_i_thread_go_to_sleep
;
1193 static int gc_section_count
= 0;
1194 static int threads_initialized_p
= 0;
1197 scm_i_thread_put_to_sleep ()
1199 if (threads_initialized_p
&& !gc_section_count
++)
1202 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1203 threads
= all_threads
;
1204 /* Signal all threads to go to sleep */
1205 scm_i_thread_go_to_sleep
= 1;
1206 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1207 if (SCM_CAR (threads
) != cur_thread
)
1209 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1210 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1212 scm_i_thread_go_to_sleep
= 0;
1217 scm_i_thread_invalidate_freelists ()
1219 /* Don't need to lock thread_admin_mutex here since we are single threaded */
1220 SCM threads
= all_threads
;
1221 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1222 if (SCM_CAR (threads
) != cur_thread
)
1224 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1225 t
->clear_freelists_p
= 1;
1230 scm_i_thread_wake_up ()
1232 if (threads_initialized_p
&& !--gc_section_count
)
1235 threads
= all_threads
;
1236 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1237 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1238 if (SCM_CAR (threads
) != cur_thread
)
1240 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1241 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1243 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1248 scm_i_thread_sleep_for_gc ()
1252 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1256 scm_t_mutex scm_i_critical_section_mutex
;
1257 scm_t_rec_mutex scm_i_defer_mutex
;
1259 #if SCM_USE_PTHREAD_THREADS
1260 # include "libguile/pthread-threads.c"
1262 #include "libguile/threads-plugin.c"
1264 /*** Initialization */
1267 scm_threads_prehistory ()
1270 #if SCM_USE_PTHREAD_THREADS
1271 /* Must be called before any initialization of a mutex. */
1272 scm_init_pthread_threads ();
1274 scm_i_plugin_mutex_init (&thread_admin_mutex
, &scm_i_plugin_mutex
);
1275 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1276 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, &scm_i_plugin_mutex
);
1278 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1279 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1280 scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex
, &scm_i_plugin_rec_mutex
);
1281 /* Allocate a fake thread object to be used during bootup. */
1282 t
= malloc (sizeof (scm_thread
));
1284 t
->clear_freelists_p
= 0;
1285 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
1286 scm_setspecific (scm_i_thread_key
, t
);
1287 scm_i_enter_guile (t
);
1290 scm_t_bits scm_tc16_thread
;
1291 scm_t_bits scm_tc16_future
;
1292 scm_t_bits scm_tc16_mutex
;
1293 scm_t_bits scm_tc16_fair_mutex
;
1294 scm_t_bits scm_tc16_condvar
;
1295 scm_t_bits scm_tc16_fair_condvar
;
1298 scm_init_threads (SCM_STACKITEM
*base
)
1301 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1302 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1303 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1304 sizeof (fair_mutex
));
1305 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1306 sizeof (scm_t_cond
));
1307 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1308 sizeof (fair_cond
));
1310 thread
= make_thread (SCM_BOOL_F
);
1311 /* Replace initial fake thread with a real thread object */
1312 free (SCM_CURRENT_THREAD
);
1313 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1314 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1316 /* root is set later from init.c */
1317 init_thread_creatant (thread
, base
);
1319 scm_gc_register_root (&all_threads
);
1320 all_threads
= scm_cons (thread
, SCM_EOL
);
1322 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1323 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1324 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1326 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1328 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1330 threads_initialized_p
= 1;
1334 scm_init_thread_procs ()
1336 #include "libguile/threads.x"