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
;
139 /* For keeping track of the stack and registers. */
147 make_thread (SCM creation_protects
)
151 z
= scm_make_smob (scm_tc16_thread
);
152 t
= SCM_THREAD_DATA (z
);
154 t
->result
= creation_protects
;
156 scm_i_plugin_cond_init (&t
->sleep_cond
, 0);
157 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
158 t
->clear_freelists_p
= 0;
164 init_thread_creatant (SCM thread
,
167 scm_thread
*t
= SCM_THREAD_DATA (thread
);
168 t
->thread
= scm_thread_self ();
174 thread_mark (SCM obj
)
176 scm_thread
*t
= SCM_THREAD_DATA (obj
);
177 scm_gc_mark (t
->result
);
178 return t
->root
->handle
; /* mark root-state of this thread */
182 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
184 scm_thread
*t
= SCM_THREAD_DATA (exp
);
185 scm_puts ("#<thread ", port
);
186 scm_intprint ((unsigned long)t
->thread
, 10, port
);
187 scm_puts (" (", port
);
188 scm_intprint ((unsigned long)t
, 16, port
);
189 scm_puts (")>", port
);
194 thread_free (SCM obj
)
196 scm_thread
*t
= SCM_THREAD_DATA (obj
);
199 scm_gc_free (t
, sizeof (*t
), "thread");
205 #define cur_thread (SCM_CURRENT_THREAD->handle)
206 scm_t_key scm_i_thread_key
;
207 scm_t_key scm_i_root_state_key
;
210 scm_i_set_thread_data (void *data
)
212 scm_thread
*t
= SCM_CURRENT_THREAD
;
213 scm_setspecific (scm_i_root_state_key
, data
);
214 t
->root
= (scm_root_state
*)data
;
218 resume (scm_thread
*t
)
221 if (t
->clear_freelists_p
)
223 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
224 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
225 t
->clear_freelists_p
= 0;
230 scm_i_enter_guile (scm_thread
*t
)
232 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
239 scm_thread
*c
= SCM_CURRENT_THREAD
;
241 /* record top of stack for the GC */
242 c
->top
= (SCM_STACKITEM
*)&c
;
243 /* save registers. */
244 SCM_FLUSH_REGISTER_WINDOWS
;
253 scm_thread
*t
= suspend ();
254 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
258 /* Put the current thread to sleep until it is explicitely unblocked.
264 scm_thread
*t
= suspend ();
265 err
= scm_i_plugin_cond_wait (&t
->sleep_cond
, &t
->heap_mutex
);
270 /* Put the current thread to sleep until it is explicitely unblocked
271 or until a signal arrives or until time AT (absolute time) is
272 reached. Return 0 when it has been unblocked; errno otherwise.
275 timed_block (const struct timespec
*at
)
278 scm_thread
*t
= suspend ();
279 err
= scm_i_plugin_cond_timedwait (&t
->sleep_cond
, &t
->heap_mutex
, at
);
284 /* Unblock a sleeping thread.
287 unblock (scm_thread
*t
)
289 scm_i_plugin_cond_signal (&t
->sleep_cond
);
292 /*** Thread creation */
294 static scm_t_mutex thread_admin_mutex
;
295 static SCM all_threads
;
296 static int thread_count
;
298 typedef struct launch_data
{
301 scm_t_catch_body body
;
303 scm_t_catch_handler handler
;
308 body_bootstrip (launch_data
* data
)
310 /* First save the new root continuation */
311 data
->rootcont
= scm_root
->rootcont
;
312 return (data
->body
) (data
->body_data
);
316 handler_bootstrip (launch_data
* data
, SCM tag
, SCM throw_args
)
318 scm_root
->rootcont
= data
->rootcont
;
319 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
323 really_launch (SCM_STACKITEM
*base
, launch_data
*data
)
327 thread
= data
->thread
;
328 t
= SCM_THREAD_DATA (thread
);
329 SCM_FREELIST_CREATE (scm_i_freelist
);
330 SCM_FREELIST_CREATE (scm_i_freelist2
);
331 scm_setspecific (scm_i_thread_key
, t
);
332 scm_setspecific (scm_i_root_state_key
, t
->root
);
333 scm_i_plugin_mutex_lock (&t
->heap_mutex
); /* ensure that we "own" the heap */
334 init_thread_creatant (thread
, base
); /* must own the heap */
336 data
->rootcont
= SCM_BOOL_F
;
338 scm_internal_cwdr ((scm_t_catch_body
) body_bootstrip
,
340 (scm_t_catch_handler
) handler_bootstrip
,
342 scm_i_leave_guile (); /* release the heap */
345 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
346 all_threads
= scm_delq_x (thread
, all_threads
);
349 /* detach before unlocking in order to not become joined when detached */
350 scm_thread_detach (t
->thread
);
351 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
355 launch_thread (void *p
)
357 really_launch ((SCM_STACKITEM
*)&p
, (launch_data
*)p
);
362 create_thread (scm_t_catch_body body
, void *body_data
,
363 scm_t_catch_handler handler
, void *handler_data
,
368 /* Make new thread. The first thing the new thread will do is to
369 lock guile_mutex. Thus, we can safely complete its
370 initialization after creating it. While the new thread starts,
371 all its data is protected via all_threads.
381 /* Unwind wind chain. */
382 old_winds
= scm_dynwinds
;
383 scm_dowinds (SCM_EOL
, scm_ilength (scm_root
->dynwinds
));
385 /* Allocate thread locals. */
386 root
= scm_make_root (scm_root
->handle
);
387 data
= scm_malloc (sizeof (launch_data
));
390 thread
= make_thread (protects
);
391 data
->thread
= thread
;
393 data
->body_data
= body_data
;
394 data
->handler
= handler
;
395 data
->handler_data
= handler_data
;
396 t
= SCM_THREAD_DATA (thread
);
397 /* must initialize root state pointer before the thread is linked
399 t
->root
= SCM_ROOT_STATE (root
);
400 /* disconnect from parent, to prevent remembering dead threads */
401 t
->root
->parent
= SCM_BOOL_F
;
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_yield
, "yield", 0, 0, 0,
467 "Move the calling thread to the end of the scheduling queue.")
468 #define FUNC_NAME s_scm_yield
470 return SCM_BOOL (scm_thread_yield
);
474 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
476 "Suspend execution of the calling thread until the target @var{thread} "
477 "terminates, unless the target @var{thread} has already terminated. ")
478 #define FUNC_NAME s_scm_join_thread
483 SCM_VALIDATE_THREAD (1, thread
);
484 if (SCM_EQ_P (cur_thread
, thread
))
485 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
487 t
= SCM_THREAD_DATA (thread
);
491 c
= scm_i_leave_guile ();
492 while (!THREAD_INITIALIZED_P (t
))
493 scm_i_plugin_thread_yield ();
494 scm_thread_join (t
->thread
, 0);
495 scm_i_enter_guile (c
);
498 t
->result
= SCM_BOOL_F
;
503 SCM
*scm_loc_sys_thread_handler
;
506 scm_i_make_future (SCM thunk
)
508 SCM_RETURN_NEWSMOB2 (scm_tc16_future
,
509 create_thread ((scm_t_catch_body
) scm_call_0
,
511 (scm_t_catch_handler
) scm_apply_1
,
512 *scm_loc_sys_thread_handler
,
514 *scm_loc_sys_thread_handler
)),
515 scm_make_rec_mutex ());
519 future_free (SCM future
)
521 scm_rec_mutex_free (SCM_FUTURE_MUTEX (future
));
526 future_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
528 int writingp
= SCM_WRITINGP (pstate
);
529 scm_puts ("#<future ", port
);
530 SCM_SET_WRITINGP (pstate
, 1);
531 scm_iprin1 (SCM_FUTURE_DATA (exp
), port
, pstate
);
532 SCM_SET_WRITINGP (pstate
, writingp
);
533 scm_putc ('>', port
);
537 SCM_DEFINE (scm_future_ref
, "future-ref", 1, 0, 0,
539 "If the future @var{x} has not been computed yet, compute and\n"
540 "return @var{x}, otherwise just return the previously computed\n"
542 #define FUNC_NAME s_scm_future_ref
544 SCM_VALIDATE_FUTURE (1, future
);
545 scm_rec_mutex_lock (SCM_FUTURE_MUTEX (future
));
546 if (!SCM_FUTURE_COMPUTED_P (future
))
548 SCM value
= scm_join_thread (SCM_FUTURE_DATA (future
));
549 if (!SCM_FUTURE_COMPUTED_P (future
))
551 SCM_SET_FUTURE_DATA (future
, value
);
552 SCM_SET_FUTURE_COMPUTED (future
);
555 scm_rec_mutex_unlock (SCM_FUTURE_MUTEX (future
));
556 return SCM_FUTURE_DATA (future
);
562 /* We implement our own mutex type since we want them to be 'fair', we
563 want to do fancy things while waiting for them (like running
564 asyncs) and we want to support waiting on many things at once.
565 Also, we might add things that are nice for debugging.
568 typedef struct fair_mutex
{
569 /* the thread currently owning the mutex, or SCM_BOOL_F. */
573 /* how much the owner owns us. */
575 /* the threads waiting for this mutex. */
580 fair_mutex_mark (SCM mx
)
582 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
583 scm_gc_mark (m
->owner
);
587 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
589 "Create a new fair mutex object. ")
590 #define FUNC_NAME s_scm_make_fair_mutex
592 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
593 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
594 scm_i_plugin_mutex_init (&m
->lock
, &scm_i_plugin_mutex
);
596 m
->owner
= SCM_BOOL_F
;
598 m
->waiting
= make_queue ();
604 fair_mutex_lock (fair_mutex
*m
)
606 scm_i_plugin_mutex_lock (&m
->lock
);
608 /* Need to wait if another thread is just temporarily unlocking.
609 This is happens very seldom and only when the other thread is
610 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
616 if (m
->owner
== SCM_BOOL_F
)
617 m
->owner
= cur_thread
;
618 else if (m
->owner
== cur_thread
)
624 SCM c
= enqueue (m
->waiting
, cur_thread
);
626 /* Note: It's important that m->lock is never locked for
627 any longer amount of time since that could prevent GC */
628 scm_i_plugin_mutex_unlock (&m
->lock
);
630 if (m
->owner
== cur_thread
)
632 scm_i_plugin_mutex_lock (&m
->lock
);
633 remqueue (m
->waiting
, c
);
634 scm_i_plugin_mutex_unlock (&m
->lock
);
638 scm_i_plugin_mutex_lock (&m
->lock
);
641 scm_i_plugin_mutex_unlock (&m
->lock
);
646 fair_mutex_trylock (fair_mutex
*m
)
648 scm_i_plugin_mutex_lock (&m
->lock
);
649 if (m
->owner
== SCM_BOOL_F
)
650 m
->owner
= cur_thread
;
651 else if (m
->owner
== cur_thread
)
655 scm_i_plugin_mutex_unlock (&m
->lock
);
658 scm_i_plugin_mutex_unlock (&m
->lock
);
663 fair_mutex_unlock (fair_mutex
*m
)
665 scm_i_plugin_mutex_lock (&m
->lock
);
666 if (m
->owner
!= cur_thread
)
668 scm_i_plugin_mutex_unlock (&m
->lock
);
671 else if (m
->level
> 0)
675 SCM next
= dequeue (m
->waiting
);
676 if (!SCM_FALSEP (next
))
679 unblock (SCM_THREAD_DATA (next
));
682 m
->owner
= SCM_BOOL_F
;
684 scm_i_plugin_mutex_unlock (&m
->lock
);
688 /*** Fair condition variables */
690 /* Like mutexes, we implement our own condition variables using the
694 typedef struct fair_cond
{
696 /* the threads waiting for this condition. */
701 fair_cond_mark (SCM cv
)
703 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
707 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
709 "Make a new fair condition variable.")
710 #define FUNC_NAME s_scm_make_fair_condition_variable
712 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
713 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
714 scm_i_plugin_mutex_init (&c
->lock
, 0);
715 c
->waiting
= make_queue ();
721 fair_cond_timedwait (fair_cond
*c
,
723 const struct timespec
*waittime
)
726 scm_i_plugin_mutex_lock (&c
->lock
);
730 enqueue (c
->waiting
, cur_thread
);
731 scm_i_plugin_mutex_unlock (&c
->lock
);
732 fair_mutex_unlock (m
); /*fixme* - not thread safe */
733 if (waittime
== NULL
)
736 err
= timed_block (waittime
);
740 /* XXX - check whether we have been signalled. */
747 fair_cond_signal (fair_cond
*c
)
750 scm_i_plugin_mutex_lock (&c
->lock
);
751 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
752 unblock (SCM_THREAD_DATA (th
));
753 scm_i_plugin_mutex_unlock (&c
->lock
);
758 fair_cond_broadcast (fair_cond
*c
)
761 scm_i_plugin_mutex_lock (&c
->lock
);
762 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
763 unblock (SCM_THREAD_DATA (th
));
764 scm_i_plugin_mutex_unlock (&c
->lock
);
770 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
772 "Create a new mutex object. ")
773 #define FUNC_NAME s_scm_make_mutex
775 SCM mx
= scm_make_smob (scm_tc16_mutex
);
776 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), &scm_i_plugin_mutex
);
781 /*fixme* change documentation */
782 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
784 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
785 "blocks until the mutex becomes available. The function returns when "
786 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
787 "a thread already owns will succeed right away and will not block the "
788 "thread. That is, Guile's mutexes are @emph{recursive}. ")
789 #define FUNC_NAME s_scm_lock_mutex
792 SCM_VALIDATE_MUTEX (1, mx
);
794 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
795 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
798 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
799 err
= scm_mutex_lock (m
);
811 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
813 "Try to lock @var{mutex}. If the mutex is already locked by someone "
814 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
815 #define FUNC_NAME s_scm_try_mutex
818 SCM_VALIDATE_MUTEX (1, mx
);
820 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
821 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
824 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
825 err
= scm_mutex_trylock (m
);
841 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
843 "Unlocks @var{mutex} if the calling thread owns the lock on "
844 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
845 "thread results in undefined behaviour. Once a mutex has been unlocked, "
846 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
847 "lock. Every call to @code{lock-mutex} by this thread must be matched "
848 "with a call to @code{unlock-mutex}. Only the last call to "
849 "@code{unlock-mutex} will actually unlock the mutex. ")
850 #define FUNC_NAME s_scm_unlock_mutex
853 SCM_VALIDATE_MUTEX (1, mx
);
855 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
857 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
860 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
861 if (m
->owner
!= cur_thread
)
863 if (m
->owner
== SCM_BOOL_F
)
864 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
866 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
872 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
873 err
= scm_mutex_unlock (m
);
885 /*** Condition variables */
887 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
889 "Make a new condition variable.")
890 #define FUNC_NAME s_scm_make_condition_variable
892 SCM cv
= scm_make_smob (scm_tc16_condvar
);
893 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
898 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
899 (SCM cv
, SCM mx
, SCM t
),
900 "Wait until @var{cond-var} has been signalled. While waiting, "
901 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
902 "is locked again when this function returns. When @var{time} is given, "
903 "it specifies a point in time where the waiting should be aborted. It "
904 "can be either a integer as returned by @code{current-time} or a pair "
905 "as returned by @code{gettimeofday}. When the waiting is aborted the "
906 "mutex is locked and @code{#f} is returned. When the condition "
907 "variable is in fact signalled, the mutex is also locked and @code{#t} "
909 #define FUNC_NAME s_scm_timed_wait_condition_variable
911 struct timespec waittime
;
914 SCM_VALIDATE_CONDVAR (1, cv
);
915 SCM_VALIDATE_MUTEX (2, mx
);
916 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
917 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
918 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
919 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
920 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
927 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
928 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
929 waittime
.tv_nsec
*= 1000;
933 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
934 waittime
.tv_nsec
= 0;
938 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
939 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
941 SCM_UNBNDP (t
) ? NULL
: &waittime
);
944 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
945 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
946 err
= scm_cond_wait (c
, m
);
958 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
960 "Wake up one thread that is waiting for @var{cv}")
961 #define FUNC_NAME s_scm_signal_condition_variable
963 SCM_VALIDATE_CONDVAR (1, cv
);
964 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
965 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
968 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
975 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
977 "Wake up all threads that are waiting for @var{cv}. ")
978 #define FUNC_NAME s_scm_broadcast_condition_variable
980 SCM_VALIDATE_CONDVAR (1, cv
);
981 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
982 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
985 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
986 scm_cond_broadcast (c
);
992 /*** Marking stacks */
994 /* XXX - what to do with this? Do we need to handle this for blocked
998 # define SCM_MARK_BACKING_STORE() do { \
1000 SCM_STACKITEM * top, * bot; \
1001 getcontext (&ctx); \
1002 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1003 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1004 / sizeof (SCM_STACKITEM))); \
1005 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1006 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1007 scm_mark_locations (bot, top - bot); } while (0)
1009 # define SCM_MARK_BACKING_STORE()
1013 scm_threads_mark_stacks (void)
1016 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
1018 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
1019 if (!THREAD_INITIALIZED_P (t
))
1021 /* Not fully initialized yet. */
1028 if (t
->thread
!= scm_thread_self ())
1032 /* stack_len is long rather than sizet in order to guarantee
1033 that &stack_len is long aligned */
1034 #ifdef STACK_GROWS_UP
1035 stack_len
= ((SCM_STACKITEM
*) (&t
) -
1036 (SCM_STACKITEM
*) thread
->base
);
1038 /* Protect from the C stack. This must be the first marking
1039 * done because it provides information about what objects
1040 * are "in-use" by the C code. "in-use" objects are those
1041 * for which the information about length and base address must
1042 * remain usable. This requirement is stricter than a liveness
1043 * requirement -- in particular, it constrains the implementation
1046 SCM_FLUSH_REGISTER_WINDOWS
;
1047 /* This assumes that all registers are saved into the jmp_buf */
1048 setjmp (scm_save_regs_gc_mark
);
1049 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1050 ((size_t) sizeof scm_save_regs_gc_mark
1051 / sizeof (SCM_STACKITEM
)));
1053 scm_mark_locations (((size_t) t
->base
,
1054 (sizet
) stack_len
));
1056 stack_len
= ((SCM_STACKITEM
*) t
->base
-
1057 (SCM_STACKITEM
*) (&t
));
1059 /* Protect from the C stack. This must be the first marking
1060 * done because it provides information about what objects
1061 * are "in-use" by the C code. "in-use" objects are those
1062 * for which the information about length and base address must
1063 * remain usable. This requirement is stricter than a liveness
1064 * requirement -- in particular, it constrains the implementation
1067 SCM_FLUSH_REGISTER_WINDOWS
;
1068 /* This assumes that all registers are saved into the jmp_buf */
1069 setjmp (scm_save_regs_gc_mark
);
1070 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1071 ((size_t) sizeof scm_save_regs_gc_mark
1072 / sizeof (SCM_STACKITEM
)));
1074 scm_mark_locations ((SCM_STACKITEM
*) &t
,
1080 /* Suspended thread */
1081 #ifdef STACK_GROWS_UP
1082 long stack_len
= t
->top
- t
->base
;
1083 scm_mark_locations (t
->base
, stack_len
);
1085 long stack_len
= t
->base
- t
->top
;
1086 scm_mark_locations (t
->top
, stack_len
);
1088 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1089 ((size_t) sizeof(t
->regs
)
1090 / sizeof (SCM_STACKITEM
)));
1098 scm_internal_select (int nfds
,
1099 SELECT_TYPE
*readfds
,
1100 SELECT_TYPE
*writefds
,
1101 SELECT_TYPE
*exceptfds
,
1102 struct timeval
*timeout
)
1105 scm_thread
*c
= scm_i_leave_guile ();
1106 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1108 scm_i_enter_guile (c
);
1114 /* Low-level C API */
1117 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1118 scm_t_catch_handler handler
, void *handler_data
)
1120 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1124 scm_mutex_lock (scm_t_mutex
*m
)
1126 scm_thread
*t
= scm_i_leave_guile ();
1127 int res
= scm_i_plugin_mutex_lock (m
);
1128 scm_i_enter_guile (t
);
1133 scm_make_rec_mutex ()
1135 scm_t_rec_mutex
*m
= scm_malloc (sizeof (scm_t_rec_mutex
));
1136 scm_i_plugin_rec_mutex_init (m
, &scm_i_plugin_rec_mutex
);
1141 scm_rec_mutex_free (scm_t_rec_mutex
*m
)
1143 scm_i_plugin_rec_mutex_destroy (m
);
1148 scm_rec_mutex_lock (scm_t_rec_mutex
*m
)
1150 scm_thread
*t
= scm_i_leave_guile ();
1151 int res
= scm_i_plugin_rec_mutex_lock (m
);
1152 scm_i_enter_guile (t
);
1157 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1159 scm_thread
*t
= scm_i_leave_guile ();
1160 scm_i_plugin_cond_wait (c
, m
);
1161 scm_i_enter_guile (t
);
1166 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
, const struct timespec
*wt
)
1168 scm_thread
*t
= scm_i_leave_guile ();
1169 int res
= scm_i_plugin_cond_timedwait (c
, m
, wt
);
1170 scm_i_enter_guile (t
);
1177 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1183 scm_i_leave_guile ();
1187 scm_thread_usleep (unsigned long usecs
)
1190 tv
.tv_usec
= usecs
% 1000000;
1191 tv
.tv_sec
= usecs
/ 1000000;
1192 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1193 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1197 scm_thread_sleep (unsigned long secs
)
1202 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1208 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1210 "Return the thread that called this function.")
1211 #define FUNC_NAME s_scm_current_thread
1217 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1219 "Return a list of all threads.")
1220 #define FUNC_NAME s_scm_all_threads
1222 return scm_list_copy (all_threads
);
1227 scm_i_thread_root (SCM thread
)
1229 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1232 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1234 "Return @code{#t} iff @var{thread} has exited.\n")
1235 #define FUNC_NAME s_scm_thread_exited_p
1237 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1242 scm_c_thread_exited_p (SCM thread
)
1243 #define FUNC_NAME s_scm_thread_exited_p
1246 SCM_VALIDATE_THREAD (1, thread
);
1247 t
= SCM_THREAD_DATA (thread
);
1252 static scm_t_cond wake_up_cond
;
1253 int scm_i_thread_go_to_sleep
;
1254 static scm_t_rec_mutex gc_section_mutex
;
1255 static int gc_section_count
= 0;
1256 static int threads_initialized_p
= 0;
1259 scm_i_thread_put_to_sleep ()
1261 scm_rec_mutex_lock (&gc_section_mutex
);
1262 if (threads_initialized_p
&& !gc_section_count
++)
1265 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1266 threads
= all_threads
;
1267 /* Signal all threads to go to sleep */
1268 scm_i_thread_go_to_sleep
= 1;
1269 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1270 if (SCM_CAR (threads
) != cur_thread
)
1272 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1273 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1275 scm_i_thread_go_to_sleep
= 0;
1280 scm_i_thread_invalidate_freelists ()
1282 /* Don't need to lock thread_admin_mutex here since we are single threaded */
1283 SCM threads
= all_threads
;
1284 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1285 if (SCM_CAR (threads
) != cur_thread
)
1287 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1288 t
->clear_freelists_p
= 1;
1293 scm_i_thread_wake_up ()
1295 if (threads_initialized_p
&& !--gc_section_count
)
1298 threads
= all_threads
;
1299 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1300 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1301 if (SCM_CAR (threads
) != cur_thread
)
1303 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1304 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1306 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1308 scm_rec_mutex_unlock (&gc_section_mutex
);
1312 scm_i_thread_sleep_for_gc ()
1316 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1320 scm_t_mutex scm_i_critical_section_mutex
;
1321 scm_t_rec_mutex scm_i_defer_mutex
;
1323 #ifdef USE_PTHREAD_THREADS
1324 #include "libguile/pthread-threads.c"
1326 #include "libguile/threads-plugin.c"
1328 /*** Initialization */
1331 scm_threads_prehistory ()
1334 #ifdef USE_PTHREAD_THREADS
1335 /* Must be called before any initialization of a mutex. */
1336 scm_init_pthread_threads ();
1338 scm_i_plugin_mutex_init (&thread_admin_mutex
, &scm_i_plugin_mutex
);
1339 scm_i_plugin_rec_mutex_init (&gc_section_mutex
, &scm_i_plugin_rec_mutex
);
1340 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1341 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, &scm_i_plugin_mutex
);
1343 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1344 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1345 scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex
, &scm_i_plugin_rec_mutex
);
1346 /* Allocate a fake thread object to be used during bootup. */
1347 t
= malloc (sizeof (scm_thread
));
1349 t
->clear_freelists_p
= 0;
1350 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
1351 scm_setspecific (scm_i_thread_key
, t
);
1352 scm_i_enter_guile (t
);
1355 scm_t_bits scm_tc16_thread
;
1356 scm_t_bits scm_tc16_future
;
1357 scm_t_bits scm_tc16_mutex
;
1358 scm_t_bits scm_tc16_fair_mutex
;
1359 scm_t_bits scm_tc16_condvar
;
1360 scm_t_bits scm_tc16_fair_condvar
;
1363 scm_init_threads (SCM_STACKITEM
*base
)
1366 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1367 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1368 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1369 sizeof (fair_mutex
));
1370 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1371 sizeof (scm_t_cond
));
1372 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1373 sizeof (fair_cond
));
1375 thread
= make_thread (SCM_BOOL_F
);
1376 /* Replace initial fake thread with a real thread object */
1377 free (SCM_CURRENT_THREAD
);
1378 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1379 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1381 /* root is set later from init.c */
1382 init_thread_creatant (thread
, base
);
1384 scm_gc_register_root (&all_threads
);
1385 all_threads
= scm_cons (thread
, SCM_EOL
);
1387 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1388 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1389 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1391 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1393 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1395 scm_tc16_future
= scm_make_smob_type ("future", 0);
1396 scm_set_smob_mark (scm_tc16_future
, scm_markcdr
);
1397 scm_set_smob_free (scm_tc16_future
, future_free
);
1398 scm_set_smob_print (scm_tc16_future
, future_print
);
1400 threads_initialized_p
= 1;
1404 scm_init_thread_procs ()
1406 scm_loc_sys_thread_handler
1407 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F
));
1408 #include "libguile/threads.x"