1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 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
49 #include "libguile/_scm.h"
56 #include "libguile/validate.h"
57 #include "libguile/root.h"
58 #include "libguile/eval.h"
59 #include "libguile/async.h"
60 #include "libguile/ports.h"
61 #include "libguile/threads.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/iselect.h"
70 return scm_cons (SCM_EOL
, SCM_EOL
);
74 enqueue (SCM q
, SCM t
)
76 SCM c
= scm_cons (t
, SCM_EOL
);
77 if (SCM_NULLP (SCM_CDR (q
)))
80 SCM_SETCDR (SCM_CAR (q
), c
);
86 remqueue (SCM q
, SCM c
)
89 for (p
= SCM_CDR (q
); !SCM_NULLP (p
); p
= SCM_CDR (p
))
93 if (SCM_EQ_P (c
, SCM_CAR (q
)))
94 SCM_SETCAR (q
, SCM_CDR (c
));
95 SCM_SETCDR (prev
, SCM_CDR (c
));
111 SCM_SETCDR (q
, SCM_CDR (c
));
112 if (SCM_NULLP (SCM_CDR (q
)))
113 SCM_SETCAR (q
, SCM_EOL
);
120 #define THREAD_INITIALIZED_P(t) (t->base != NULL)
126 scm_t_cond sleep_cond
;
127 struct scm_thread
*next_waiting
;
129 /* This mutex represents this threads right to access the heap.
130 That right can temporarily be taken away by the GC. */
131 scm_t_mutex heap_mutex
;
132 int clear_freelists_p
; /* set if GC was done while thread was asleep */
134 scm_root_state
*root
;
140 /* For keeping track of the stack and registers. */
148 make_thread (SCM creation_protects
)
152 z
= scm_make_smob (scm_tc16_thread
);
153 t
= SCM_THREAD_DATA (z
);
155 t
->result
= creation_protects
;
157 scm_i_plugin_cond_init (&t
->sleep_cond
, 0);
158 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
159 t
->clear_freelists_p
= 0;
165 init_thread_creatant (SCM thread
,
168 scm_thread
*t
= SCM_THREAD_DATA (thread
);
169 t
->thread
= scm_thread_self ();
175 thread_mark (SCM obj
)
177 scm_thread
*t
= SCM_THREAD_DATA (obj
);
178 scm_gc_mark (t
->result
);
179 return t
->root
->handle
; /* mark root-state of this thread */
183 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
185 scm_thread
*t
= SCM_THREAD_DATA (exp
);
186 scm_puts ("#<thread ", port
);
187 scm_intprint ((unsigned long)t
->thread
, 10, port
);
188 scm_puts (" (", port
);
189 scm_intprint ((unsigned long)t
, 16, port
);
190 scm_puts (")>", port
);
195 thread_free (SCM obj
)
197 scm_thread
*t
= SCM_THREAD_DATA (obj
);
200 scm_gc_free (t
, sizeof (*t
), "thread");
206 #define cur_thread (SCM_CURRENT_THREAD->handle)
207 scm_t_key scm_i_thread_key
;
208 scm_t_key scm_i_root_state_key
;
211 scm_i_set_thread_data (void *data
)
213 scm_thread
*t
= SCM_CURRENT_THREAD
;
214 scm_setspecific (scm_i_root_state_key
, data
);
215 t
->root
= (scm_root_state
*)data
;
219 resume (scm_thread
*t
)
222 if (t
->clear_freelists_p
)
224 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
225 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
226 t
->clear_freelists_p
= 0;
231 scm_i_enter_guile (scm_thread
*t
)
233 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
240 scm_thread
*c
= SCM_CURRENT_THREAD
;
242 /* record top of stack for the GC */
243 c
->top
= (SCM_STACKITEM
*)&c
;
244 /* save registers. */
245 SCM_FLUSH_REGISTER_WINDOWS
;
254 scm_thread
*t
= suspend ();
255 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
259 /* Put the current thread to sleep until it is explicitely unblocked.
265 scm_thread
*t
= suspend ();
266 err
= scm_i_plugin_cond_wait (&t
->sleep_cond
, &t
->heap_mutex
);
271 /* Put the current thread to sleep until it is explicitely unblocked
272 or until a signal arrives or until time AT (absolute time) is
273 reached. Return 0 when it has been unblocked; errno otherwise.
276 timed_block (const scm_t_timespec
*at
)
279 scm_thread
*t
= suspend ();
280 err
= scm_i_plugin_cond_timedwait (&t
->sleep_cond
, &t
->heap_mutex
, at
);
285 /* Unblock a sleeping thread.
288 unblock (scm_thread
*t
)
290 scm_i_plugin_cond_signal (&t
->sleep_cond
);
293 /*** Thread creation */
295 static scm_t_mutex thread_admin_mutex
;
296 static SCM all_threads
;
297 static int thread_count
;
299 typedef struct launch_data
{
302 scm_t_catch_body body
;
304 scm_t_catch_handler handler
;
309 body_bootstrip (launch_data
* data
)
311 /* First save the new root continuation */
312 data
->rootcont
= scm_root
->rootcont
;
313 return (data
->body
) (data
->body_data
);
317 handler_bootstrip (launch_data
* data
, SCM tag
, SCM throw_args
)
319 scm_root
->rootcont
= data
->rootcont
;
320 return (data
->handler
) (data
->handler_data
, tag
, throw_args
);
324 really_launch (SCM_STACKITEM
*base
, launch_data
*data
)
328 thread
= data
->thread
;
329 t
= SCM_THREAD_DATA (thread
);
330 SCM_FREELIST_CREATE (scm_i_freelist
);
331 SCM_FREELIST_CREATE (scm_i_freelist2
);
332 scm_setspecific (scm_i_thread_key
, t
);
333 scm_setspecific (scm_i_root_state_key
, t
->root
);
334 scm_i_plugin_mutex_lock (&t
->heap_mutex
); /* ensure that we "own" the heap */
335 init_thread_creatant (thread
, base
); /* must own the heap */
337 data
->rootcont
= SCM_BOOL_F
;
339 scm_internal_cwdr ((scm_t_catch_body
) body_bootstrip
,
341 (scm_t_catch_handler
) handler_bootstrip
,
343 scm_i_leave_guile (); /* release the heap */
346 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
347 all_threads
= scm_delq_x (thread
, all_threads
);
350 /* detach before unlocking in order to not become joined when detached */
351 scm_thread_detach (t
->thread
);
352 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
356 launch_thread (void *p
)
358 really_launch ((SCM_STACKITEM
*)&p
, (launch_data
*)p
);
363 create_thread (scm_t_catch_body body
, void *body_data
,
364 scm_t_catch_handler handler
, void *handler_data
,
369 /* Make new thread. The first thing the new thread will do is to
370 lock guile_mutex. Thus, we can safely complete its
371 initialization after creating it. While the new thread starts,
372 all its data is protected via all_threads.
382 /* Allocate thread locals. */
383 root
= scm_make_root (scm_root
->handle
);
384 data
= scm_malloc (sizeof (launch_data
));
387 thread
= make_thread (protects
);
388 data
->thread
= thread
;
390 data
->body_data
= body_data
;
391 data
->handler
= handler
;
392 data
->handler_data
= handler_data
;
393 t
= SCM_THREAD_DATA (thread
);
394 /* must initialize root state pointer before the thread is linked
396 t
->root
= SCM_ROOT_STATE (root
);
397 /* disconnect from parent, to prevent remembering dead threads */
398 t
->root
->parent
= SCM_BOOL_F
;
399 /* start with an empty dynwind chain */
400 t
->root
->dynwinds
= SCM_EOL
;
402 /* In order to avoid the need of synchronization between parent
403 and child thread, we need to insert the child into all_threads
406 SCM new_threads
= scm_cons (thread
, SCM_BOOL_F
); /* could cause GC */
407 scm_thread
*parent
= scm_i_leave_guile (); /* to prevent deadlock */
408 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
409 SCM_SETCDR (new_threads
, all_threads
);
410 all_threads
= new_threads
;
412 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
414 scm_remember_upto_here_1 (root
);
416 scm_i_enter_guile (parent
);
419 err
= scm_i_plugin_thread_create (&th
, 0, launch_thread
, (void *) data
);
422 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
423 all_threads
= scm_delq_x (thread
, all_threads
);
424 ((scm_thread
*) SCM_THREAD_DATA(thread
))->exited
= 1;
426 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
432 scm_syserror ("create-thread");
439 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 2, 0, 0,
440 (SCM thunk
, SCM handler
),
441 "Evaluate @var{(thunk)} in a new thread, and new dynamic context, "
442 "returning a new thread object representing the thread. "
443 "If an error occurs during evaluation, call error-thunk, passing it an "
444 "error code describing the condition. "
445 "If this happens, the error-thunk is called outside the scope of the new "
446 "root -- it is called in the same dynamic context in which "
447 "with-new-thread was evaluated, but not in the callers thread. "
448 "All the evaluation rules for dynamic roots apply to threads.")
449 #define FUNC_NAME s_scm_call_with_new_thread
451 SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
452 SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler
)), handler
, SCM_ARG2
,
455 return create_thread ((scm_t_catch_body
) scm_call_0
, thunk
,
456 (scm_t_catch_handler
) scm_apply_1
, handler
,
457 scm_cons (thunk
, handler
));
461 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
463 "Move the calling thread to the end of the scheduling queue.")
464 #define FUNC_NAME s_scm_yield
466 return SCM_BOOL (scm_thread_yield
);
470 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
472 "Suspend execution of the calling thread until the target @var{thread} "
473 "terminates, unless the target @var{thread} has already terminated. ")
474 #define FUNC_NAME s_scm_join_thread
479 SCM_VALIDATE_THREAD (1, thread
);
480 if (SCM_EQ_P (cur_thread
, thread
))
481 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
483 t
= SCM_THREAD_DATA (thread
);
487 c
= scm_i_leave_guile ();
488 while (!THREAD_INITIALIZED_P (t
))
489 scm_i_plugin_thread_yield ();
490 scm_thread_join (t
->thread
, 0);
491 scm_i_enter_guile (c
);
494 t
->result
= SCM_BOOL_F
;
501 /* We implement our own mutex type since we want them to be 'fair', we
502 want to do fancy things while waiting for them (like running
503 asyncs) and we want to support waiting on many things at once.
504 Also, we might add things that are nice for debugging.
507 typedef struct fair_mutex
{
508 /* the thread currently owning the mutex, or SCM_BOOL_F. */
512 /* how much the owner owns us. */
514 /* the threads waiting for this mutex. */
519 fair_mutex_mark (SCM mx
)
521 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
522 scm_gc_mark (m
->owner
);
526 SCM_DEFINE (scm_make_fair_mutex
, "make-fair-mutex", 0, 0, 0,
528 "Create a new fair mutex object. ")
529 #define FUNC_NAME s_scm_make_fair_mutex
531 SCM mx
= scm_make_smob (scm_tc16_fair_mutex
);
532 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
533 scm_i_plugin_mutex_init (&m
->lock
, &scm_i_plugin_mutex
);
535 m
->owner
= SCM_BOOL_F
;
537 m
->waiting
= make_queue ();
543 fair_mutex_lock (fair_mutex
*m
)
545 scm_i_plugin_mutex_lock (&m
->lock
);
547 /* Need to wait if another thread is just temporarily unlocking.
548 This is happens very seldom and only when the other thread is
549 between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */
555 if (m
->owner
== SCM_BOOL_F
)
556 m
->owner
= cur_thread
;
557 else if (m
->owner
== cur_thread
)
563 SCM c
= enqueue (m
->waiting
, cur_thread
);
565 /* Note: It's important that m->lock is never locked for
566 any longer amount of time since that could prevent GC */
567 scm_i_plugin_mutex_unlock (&m
->lock
);
569 if (m
->owner
== cur_thread
)
571 scm_i_plugin_mutex_lock (&m
->lock
);
572 remqueue (m
->waiting
, c
);
573 scm_i_plugin_mutex_unlock (&m
->lock
);
577 scm_i_plugin_mutex_lock (&m
->lock
);
580 scm_i_plugin_mutex_unlock (&m
->lock
);
585 fair_mutex_trylock (fair_mutex
*m
)
587 scm_i_plugin_mutex_lock (&m
->lock
);
588 if (m
->owner
== SCM_BOOL_F
)
589 m
->owner
= cur_thread
;
590 else if (m
->owner
== cur_thread
)
594 scm_i_plugin_mutex_unlock (&m
->lock
);
597 scm_i_plugin_mutex_unlock (&m
->lock
);
602 fair_mutex_unlock (fair_mutex
*m
)
604 scm_i_plugin_mutex_lock (&m
->lock
);
605 if (m
->owner
!= cur_thread
)
607 scm_i_plugin_mutex_unlock (&m
->lock
);
610 else if (m
->level
> 0)
614 SCM next
= dequeue (m
->waiting
);
615 if (!SCM_FALSEP (next
))
618 unblock (SCM_THREAD_DATA (next
));
621 m
->owner
= SCM_BOOL_F
;
623 scm_i_plugin_mutex_unlock (&m
->lock
);
627 /*** Fair condition variables */
629 /* Like mutexes, we implement our own condition variables using the
633 typedef struct fair_cond
{
635 /* the threads waiting for this condition. */
640 fair_cond_mark (SCM cv
)
642 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
646 SCM_DEFINE (scm_make_fair_condition_variable
, "make-fair-condition-variable", 0, 0, 0,
648 "Make a new fair condition variable.")
649 #define FUNC_NAME s_scm_make_fair_condition_variable
651 SCM cv
= scm_make_smob (scm_tc16_fair_condvar
);
652 fair_cond
*c
= SCM_CONDVAR_DATA (cv
);
653 scm_i_plugin_mutex_init (&c
->lock
, 0);
654 c
->waiting
= make_queue ();
660 fair_cond_timedwait (fair_cond
*c
,
662 const scm_t_timespec
*waittime
)
665 scm_i_plugin_mutex_lock (&c
->lock
);
669 enqueue (c
->waiting
, cur_thread
);
670 scm_i_plugin_mutex_unlock (&c
->lock
);
671 fair_mutex_unlock (m
); /*fixme* - not thread safe */
672 if (waittime
== NULL
)
675 err
= timed_block (waittime
);
679 /* XXX - check whether we have been signalled. */
686 fair_cond_signal (fair_cond
*c
)
689 scm_i_plugin_mutex_lock (&c
->lock
);
690 if (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
691 unblock (SCM_THREAD_DATA (th
));
692 scm_i_plugin_mutex_unlock (&c
->lock
);
697 fair_cond_broadcast (fair_cond
*c
)
700 scm_i_plugin_mutex_lock (&c
->lock
);
701 while (!SCM_FALSEP (th
= dequeue (c
->waiting
)))
702 unblock (SCM_THREAD_DATA (th
));
703 scm_i_plugin_mutex_unlock (&c
->lock
);
709 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
711 "Create a new mutex object. ")
712 #define FUNC_NAME s_scm_make_mutex
714 SCM mx
= scm_make_smob (scm_tc16_mutex
);
715 scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx
), &scm_i_plugin_mutex
);
720 /*fixme* change documentation */
721 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
723 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
724 "blocks until the mutex becomes available. The function returns when "
725 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
726 "a thread already owns will succeed right away and will not block the "
727 "thread. That is, Guile's mutexes are @emph{recursive}. ")
728 #define FUNC_NAME s_scm_lock_mutex
731 SCM_VALIDATE_MUTEX (1, mx
);
733 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
734 err
= fair_mutex_lock (SCM_MUTEX_DATA (mx
));
737 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
738 err
= scm_mutex_lock (m
);
750 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
752 "Try to lock @var{mutex}. If the mutex is already locked by someone "
753 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
754 #define FUNC_NAME s_scm_try_mutex
757 SCM_VALIDATE_MUTEX (1, mx
);
759 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
760 err
= fair_mutex_trylock (SCM_MUTEX_DATA (mx
));
763 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
764 err
= scm_mutex_trylock (m
);
780 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
782 "Unlocks @var{mutex} if the calling thread owns the lock on "
783 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
784 "thread results in undefined behaviour. Once a mutex has been unlocked, "
785 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
786 "lock. Every call to @code{lock-mutex} by this thread must be matched "
787 "with a call to @code{unlock-mutex}. Only the last call to "
788 "@code{unlock-mutex} will actually unlock the mutex. ")
789 #define FUNC_NAME s_scm_unlock_mutex
792 SCM_VALIDATE_MUTEX (1, mx
);
794 if (SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)
796 err
= fair_mutex_unlock (SCM_MUTEX_DATA (mx
));
799 fair_mutex
*m
= SCM_MUTEX_DATA (mx
);
800 if (m
->owner
!= cur_thread
)
802 if (m
->owner
== SCM_BOOL_F
)
803 SCM_MISC_ERROR ("mutex not locked", SCM_EOL
);
805 SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL
);
811 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
812 err
= scm_mutex_unlock (m
);
824 /*** Condition variables */
826 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
828 "Make a new condition variable.")
829 #define FUNC_NAME s_scm_make_condition_variable
831 SCM cv
= scm_make_smob (scm_tc16_condvar
);
832 scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv
), 0);
837 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
838 (SCM cv
, SCM mx
, SCM t
),
839 "Wait until @var{cond-var} has been signalled. While waiting, "
840 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
841 "is locked again when this function returns. When @var{time} is given, "
842 "it specifies a point in time where the waiting should be aborted. It "
843 "can be either a integer as returned by @code{current-time} or a pair "
844 "as returned by @code{gettimeofday}. When the waiting is aborted the "
845 "mutex is locked and @code{#f} is returned. When the condition "
846 "variable is in fact signalled, the mutex is also locked and @code{#t} "
848 #define FUNC_NAME s_scm_timed_wait_condition_variable
850 scm_t_timespec waittime
;
853 SCM_VALIDATE_CONDVAR (1, cv
);
854 SCM_VALIDATE_MUTEX (2, mx
);
855 if (!((SCM_TYP16 (cv
) == scm_tc16_condvar
856 && SCM_TYP16 (mx
) == scm_tc16_mutex
)
857 || (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
858 && SCM_TYP16 (mx
) == scm_tc16_fair_mutex
)))
859 SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.",
866 SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t
), waittime
.tv_sec
);
867 SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t
), waittime
.tv_nsec
);
868 waittime
.tv_nsec
*= 1000;
872 SCM_VALIDATE_UINT_COPY (3, t
, waittime
.tv_sec
);
873 waittime
.tv_nsec
= 0;
877 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
878 err
= fair_cond_timedwait (SCM_CONDVAR_DATA (cv
),
880 SCM_UNBNDP (t
) ? NULL
: &waittime
);
883 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
884 scm_t_mutex
*m
= SCM_MUTEX_DATA (mx
);
886 err
= scm_cond_wait (c
, m
);
888 err
= scm_cond_timedwait (c
, m
, &waittime
);
893 if (err
== ETIMEDOUT
)
902 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
904 "Wake up one thread that is waiting for @var{cv}")
905 #define FUNC_NAME s_scm_signal_condition_variable
907 SCM_VALIDATE_CONDVAR (1, cv
);
908 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
909 fair_cond_signal (SCM_CONDVAR_DATA (cv
));
912 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
919 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
921 "Wake up all threads that are waiting for @var{cv}. ")
922 #define FUNC_NAME s_scm_broadcast_condition_variable
924 SCM_VALIDATE_CONDVAR (1, cv
);
925 if (SCM_TYP16 (cv
) == scm_tc16_fair_condvar
)
926 fair_cond_broadcast (SCM_CONDVAR_DATA (cv
));
929 scm_t_cond
*c
= SCM_CONDVAR_DATA (cv
);
930 scm_cond_broadcast (c
);
936 /*** Marking stacks */
938 /* XXX - what to do with this? Do we need to handle this for blocked
942 # define SCM_MARK_BACKING_STORE() do { \
944 SCM_STACKITEM * top, * bot; \
946 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
947 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
948 / sizeof (SCM_STACKITEM))); \
949 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
950 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
951 scm_mark_locations (bot, top - bot); } while (0)
953 # define SCM_MARK_BACKING_STORE()
957 scm_threads_mark_stacks (void)
960 for (c
= all_threads
; !SCM_NULLP (c
); c
= SCM_CDR (c
))
962 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (c
));
963 if (!THREAD_INITIALIZED_P (t
))
965 /* Not fully initialized yet. */
972 if (t
->thread
!= scm_thread_self ())
976 /* stack_len is long rather than sizet in order to guarantee
977 that &stack_len is long aligned */
978 #if SCM_STACK_GROWS_UP
979 stack_len
= ((SCM_STACKITEM
*) (&t
) -
980 (SCM_STACKITEM
*) thread
->base
);
982 /* Protect from the C stack. This must be the first marking
983 * done because it provides information about what objects
984 * are "in-use" by the C code. "in-use" objects are those
985 * for which the information about length and base address must
986 * remain usable. This requirement is stricter than a liveness
987 * requirement -- in particular, it constrains the implementation
990 SCM_FLUSH_REGISTER_WINDOWS
;
991 /* This assumes that all registers are saved into the jmp_buf */
992 setjmp (scm_save_regs_gc_mark
);
993 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
994 ((size_t) sizeof scm_save_regs_gc_mark
995 / sizeof (SCM_STACKITEM
)));
997 scm_mark_locations (((size_t) t
->base
,
1000 stack_len
= ((SCM_STACKITEM
*) t
->base
-
1001 (SCM_STACKITEM
*) (&t
));
1003 /* Protect from the C stack. This must be the first marking
1004 * done because it provides information about what objects
1005 * are "in-use" by the C code. "in-use" objects are those
1006 * for which the information about length and base address must
1007 * remain usable. This requirement is stricter than a liveness
1008 * requirement -- in particular, it constrains the implementation
1011 SCM_FLUSH_REGISTER_WINDOWS
;
1012 /* This assumes that all registers are saved into the jmp_buf */
1013 setjmp (scm_save_regs_gc_mark
);
1014 scm_mark_locations ((SCM_STACKITEM
*) scm_save_regs_gc_mark
,
1015 ((size_t) sizeof scm_save_regs_gc_mark
1016 / sizeof (SCM_STACKITEM
)));
1018 scm_mark_locations ((SCM_STACKITEM
*) &t
,
1024 /* Suspended thread */
1025 #if SCM_STACK_GROWS_UP
1026 long stack_len
= t
->top
- t
->base
;
1027 scm_mark_locations (t
->base
, stack_len
);
1029 long stack_len
= t
->base
- t
->top
;
1030 scm_mark_locations (t
->top
, stack_len
);
1032 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1033 ((size_t) sizeof(t
->regs
)
1034 / sizeof (SCM_STACKITEM
)));
1042 scm_internal_select (int nfds
,
1043 SELECT_TYPE
*readfds
,
1044 SELECT_TYPE
*writefds
,
1045 SELECT_TYPE
*exceptfds
,
1046 struct timeval
*timeout
)
1049 scm_thread
*c
= scm_i_leave_guile ();
1050 res
= scm_i_plugin_select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1052 scm_i_enter_guile (c
);
1058 /* Low-level C API */
1061 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1062 scm_t_catch_handler handler
, void *handler_data
)
1064 return create_thread (body
, body_data
, handler
, handler_data
, SCM_BOOL_F
);
1068 scm_mutex_lock (scm_t_mutex
*m
)
1070 scm_thread
*t
= scm_i_leave_guile ();
1071 int res
= scm_i_plugin_mutex_lock (m
);
1072 scm_i_enter_guile (t
);
1077 scm_make_rec_mutex ()
1079 scm_t_rec_mutex
*m
= scm_malloc (sizeof (scm_t_rec_mutex
));
1080 scm_i_plugin_rec_mutex_init (m
, &scm_i_plugin_rec_mutex
);
1085 scm_rec_mutex_free (scm_t_rec_mutex
*m
)
1087 scm_i_plugin_rec_mutex_destroy (m
);
1092 scm_rec_mutex_lock (scm_t_rec_mutex
*m
)
1094 scm_thread
*t
= scm_i_leave_guile ();
1095 int res
= scm_i_plugin_rec_mutex_lock (m
);
1096 scm_i_enter_guile (t
);
1101 scm_cond_wait (scm_t_cond
*c
, scm_t_mutex
*m
)
1103 scm_thread
*t
= scm_i_leave_guile ();
1104 scm_i_plugin_cond_wait (c
, m
);
1105 scm_i_enter_guile (t
);
1110 scm_cond_timedwait (scm_t_cond
*c
, scm_t_mutex
*m
, const scm_t_timespec
*wt
)
1112 scm_thread
*t
= scm_i_leave_guile ();
1113 int res
= scm_i_plugin_cond_timedwait (c
, m
, wt
);
1114 scm_i_enter_guile (t
);
1121 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1127 scm_i_leave_guile ();
1131 scm_thread_usleep (unsigned long usecs
)
1134 tv
.tv_usec
= usecs
% 1000000;
1135 tv
.tv_sec
= usecs
/ 1000000;
1136 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1137 return tv
.tv_usec
+ tv
.tv_sec
*1000000;
1141 scm_thread_sleep (unsigned long secs
)
1146 scm_internal_select (0, NULL
, NULL
, NULL
, &tv
);
1152 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1154 "Return the thread that called this function.")
1155 #define FUNC_NAME s_scm_current_thread
1161 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1163 "Return a list of all threads.")
1164 #define FUNC_NAME s_scm_all_threads
1166 return scm_list_copy (all_threads
);
1171 scm_i_thread_root (SCM thread
)
1173 return ((scm_thread
*) SCM_THREAD_DATA (thread
))->root
;
1176 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1178 "Return @code{#t} iff @var{thread} has exited.\n")
1179 #define FUNC_NAME s_scm_thread_exited_p
1181 return SCM_BOOL (scm_c_thread_exited_p (thread
));
1186 scm_c_thread_exited_p (SCM thread
)
1187 #define FUNC_NAME s_scm_thread_exited_p
1190 SCM_VALIDATE_THREAD (1, thread
);
1191 t
= SCM_THREAD_DATA (thread
);
1196 static scm_t_cond wake_up_cond
;
1197 int scm_i_thread_go_to_sleep
;
1198 static int gc_section_count
= 0;
1199 static int threads_initialized_p
= 0;
1202 scm_i_thread_put_to_sleep ()
1204 if (threads_initialized_p
&& !gc_section_count
++)
1207 scm_i_plugin_mutex_lock (&thread_admin_mutex
);
1208 threads
= all_threads
;
1209 /* Signal all threads to go to sleep */
1210 scm_i_thread_go_to_sleep
= 1;
1211 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1212 if (SCM_CAR (threads
) != cur_thread
)
1214 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1215 scm_i_plugin_mutex_lock (&t
->heap_mutex
);
1217 scm_i_thread_go_to_sleep
= 0;
1222 scm_i_thread_invalidate_freelists ()
1224 /* Don't need to lock thread_admin_mutex here since we are single threaded */
1225 SCM threads
= all_threads
;
1226 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1227 if (SCM_CAR (threads
) != cur_thread
)
1229 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1230 t
->clear_freelists_p
= 1;
1235 scm_i_thread_wake_up ()
1237 if (threads_initialized_p
&& !--gc_section_count
)
1240 threads
= all_threads
;
1241 scm_i_plugin_cond_broadcast (&wake_up_cond
);
1242 for (; !SCM_NULLP (threads
); threads
= SCM_CDR (threads
))
1243 if (SCM_CAR (threads
) != cur_thread
)
1245 scm_thread
*t
= SCM_THREAD_DATA (SCM_CAR (threads
));
1246 scm_i_plugin_mutex_unlock (&t
->heap_mutex
);
1248 scm_i_plugin_mutex_unlock (&thread_admin_mutex
);
1253 scm_i_thread_sleep_for_gc ()
1257 scm_i_plugin_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1261 scm_t_mutex scm_i_critical_section_mutex
;
1262 scm_t_rec_mutex scm_i_defer_mutex
;
1264 #if SCM_USE_PTHREAD_THREADS
1265 # include "libguile/pthread-threads.c"
1267 #include "libguile/threads-plugin.c"
1269 /*** Initialization */
1272 scm_threads_prehistory ()
1275 #if SCM_USE_PTHREAD_THREADS
1276 /* Must be called before any initialization of a mutex. */
1277 scm_init_pthread_threads ();
1279 scm_i_plugin_mutex_init (&thread_admin_mutex
, &scm_i_plugin_mutex
);
1280 scm_i_plugin_cond_init (&wake_up_cond
, 0);
1281 scm_i_plugin_mutex_init (&scm_i_critical_section_mutex
, &scm_i_plugin_mutex
);
1283 scm_i_plugin_key_create (&scm_i_thread_key
, 0);
1284 scm_i_plugin_key_create (&scm_i_root_state_key
, 0);
1285 scm_i_plugin_rec_mutex_init (&scm_i_defer_mutex
, &scm_i_plugin_rec_mutex
);
1286 /* Allocate a fake thread object to be used during bootup. */
1287 t
= malloc (sizeof (scm_thread
));
1289 t
->clear_freelists_p
= 0;
1290 scm_i_plugin_mutex_init (&t
->heap_mutex
, &scm_i_plugin_mutex
);
1291 scm_setspecific (scm_i_thread_key
, t
);
1292 scm_i_enter_guile (t
);
1295 scm_t_bits scm_tc16_thread
;
1296 scm_t_bits scm_tc16_future
;
1297 scm_t_bits scm_tc16_mutex
;
1298 scm_t_bits scm_tc16_fair_mutex
;
1299 scm_t_bits scm_tc16_condvar
;
1300 scm_t_bits scm_tc16_fair_condvar
;
1303 scm_init_threads (SCM_STACKITEM
*base
)
1306 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_thread
));
1307 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (scm_t_mutex
));
1308 scm_tc16_fair_mutex
= scm_make_smob_type ("fair-mutex",
1309 sizeof (fair_mutex
));
1310 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1311 sizeof (scm_t_cond
));
1312 scm_tc16_fair_condvar
= scm_make_smob_type ("fair-condition-variable",
1313 sizeof (fair_cond
));
1315 thread
= make_thread (SCM_BOOL_F
);
1316 /* Replace initial fake thread with a real thread object */
1317 free (SCM_CURRENT_THREAD
);
1318 scm_setspecific (scm_i_thread_key
, SCM_THREAD_DATA (thread
));
1319 scm_i_enter_guile (SCM_CURRENT_THREAD
);
1321 /* root is set later from init.c */
1322 init_thread_creatant (thread
, base
);
1324 scm_gc_register_root (&all_threads
);
1325 all_threads
= scm_cons (thread
, SCM_EOL
);
1327 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1328 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1329 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1331 scm_set_smob_mark (scm_tc16_fair_mutex
, fair_mutex_mark
);
1333 scm_set_smob_mark (scm_tc16_fair_condvar
, fair_cond_mark
);
1335 threads_initialized_p
= 1;
1339 scm_init_thread_procs ()
1341 #include "libguile/threads.x"