1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "libguile/bdw-gc.h"
26 #include "libguile/_scm.h"
34 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
43 #include "libguile/validate.h"
44 #include "libguile/root.h"
45 #include "libguile/eval.h"
46 #include "libguile/async.h"
47 #include "libguile/ports.h"
48 #include "libguile/threads.h"
49 #include "libguile/dynwind.h"
50 #include "libguile/iselect.h"
51 #include "libguile/fluids.h"
52 #include "libguile/continuations.h"
53 #include "libguile/gc.h"
54 #include "libguile/init.h"
55 #include "libguile/scmsigs.h"
56 #include "libguile/strings.h"
57 #include "libguile/weaks.h"
61 # define ETIMEDOUT WSAETIMEDOUT
65 # define pipe(fd) _pipe (fd, 256, O_BINARY)
66 #endif /* __MINGW32__ */
68 #include <full-read.h>
73 /* First some libgc shims. */
75 /* Make sure GC_fn_type is defined; it is missing from the public
76 headers of GC 7.1 and earlier. */
77 #ifndef HAVE_GC_FN_TYPE
78 typedef void * (* GC_fn_type
) (void *);
86 #ifndef GC_UNIMPLEMENTED
87 #define GC_UNIMPLEMENTED 3
90 /* Likewise struct GC_stack_base is missing before 7.1. */
91 #ifndef HAVE_GC_STACK_BASE
95 GC_register_my_thread (struct GC_stack_base
*)
97 return GC_UNIMPLEMENTED
;
101 GC_unregister_my_thread ()
106 GC_call_with_stack_base(void * (*fn
) (struct GC_stack_base
*, void*), void *arg
)
108 return fn (NULL
, arg
);
113 /* Now define with_gc_active and with_gc_inactive. */
115 #if (defined(HAVE_GC_DO_BLOCKING) && defined (HAVE_DECL_GC_DO_BLOCKING) && defined (HAVE_GC_CALL_WITH_GC_ACTIVE))
117 /* We have a sufficiently new libgc (7.2 or newer). */
120 with_gc_inactive (GC_fn_type func
, void *data
)
122 return GC_do_blocking (func
, data
);
126 with_gc_active (GC_fn_type func
, void *data
)
128 return GC_call_with_gc_active (func
, data
);
133 /* libgc not new enough, so never actually deactivate GC.
135 Note that though GC 7.1 does have a GC_do_blocking, it doesn't have
136 GC_call_with_gc_active. */
139 with_gc_inactive (GC_fn_type func
, void *data
)
145 with_gc_active (GC_fn_type func
, void *data
)
150 #endif /* HAVE_GC_DO_BLOCKING */
155 to_timespec (SCM t
, scm_t_timespec
*waittime
)
159 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
160 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
164 double time
= scm_to_double (t
);
165 double sec
= scm_c_truncate (time
);
167 waittime
->tv_sec
= (long) sec
;
168 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
175 /* Note: We annotate with "GC-robust" assignments whose purpose is to avoid
176 the risk of false references leading to unbounded retained space as
177 described in "Bounding Space Usage of Conservative Garbage Collectors",
180 /* Make an empty queue data structure.
185 return scm_cons (SCM_EOL
, SCM_EOL
);
188 /* Put T at the back of Q and return a handle that can be used with
189 remqueue to remove T from Q again.
192 enqueue (SCM q
, SCM t
)
194 SCM c
= scm_cons (t
, SCM_EOL
);
195 SCM_CRITICAL_SECTION_START
;
196 if (scm_is_null (SCM_CDR (q
)))
199 SCM_SETCDR (SCM_CAR (q
), c
);
201 SCM_CRITICAL_SECTION_END
;
205 /* Remove the element that the handle C refers to from the queue Q. C
206 must have been returned from a call to enqueue. The return value
207 is zero when the element referred to by C has already been removed.
208 Otherwise, 1 is returned.
211 remqueue (SCM q
, SCM c
)
214 SCM_CRITICAL_SECTION_START
;
215 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
217 if (scm_is_eq (p
, c
))
219 if (scm_is_eq (c
, SCM_CAR (q
)))
220 SCM_SETCAR (q
, SCM_CDR (c
));
221 SCM_SETCDR (prev
, SCM_CDR (c
));
224 SCM_SETCDR (c
, SCM_EOL
);
226 SCM_CRITICAL_SECTION_END
;
231 SCM_CRITICAL_SECTION_END
;
235 /* Remove the front-most element from the queue Q and return it.
236 Return SCM_BOOL_F when Q is empty.
242 SCM_CRITICAL_SECTION_START
;
246 SCM_CRITICAL_SECTION_END
;
251 SCM_SETCDR (q
, SCM_CDR (c
));
252 if (scm_is_null (SCM_CDR (q
)))
253 SCM_SETCAR (q
, SCM_EOL
);
254 SCM_CRITICAL_SECTION_END
;
257 SCM_SETCDR (c
, SCM_EOL
);
263 /*** Thread smob routines */
267 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
269 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
270 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
271 the struct case, hence we go via a union, and extract according to the
272 size of pthread_t. */
280 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
281 scm_i_pthread_t p
= t
->pthread
;
284 if (sizeof (p
) == sizeof (unsigned short))
286 else if (sizeof (p
) == sizeof (unsigned int))
288 else if (sizeof (p
) == sizeof (unsigned long))
293 scm_puts ("#<thread ", port
);
294 scm_uintprint (id
, 10, port
);
295 scm_puts (" (", port
);
296 scm_uintprint ((scm_t_bits
)t
, 16, port
);
297 scm_puts (")>", port
);
302 /*** Blocking on queues. */
304 /* See also scm_i_queue_async_cell for how such a block is
308 /* Put the current thread on QUEUE and go to sleep, waiting for it to
309 be woken up by a call to 'unblock_from_queue', or to be
310 interrupted. Upon return of this function, the current thread is
311 no longer on QUEUE, even when the sleep has been interrupted.
313 The caller of block_self must hold MUTEX. It will be atomically
314 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
316 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
319 When WAITTIME is not NULL, the sleep will be aborted at that time.
321 The return value of block_self is an errno value. It will be zero
322 when the sleep has been successfully completed by a call to
323 unblock_from_queue, EINTR when it has been interrupted by the
324 delivery of a system async, and ETIMEDOUT when the timeout has
327 The system asyncs themselves are not executed by block_self.
330 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
331 const scm_t_timespec
*waittime
)
333 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
337 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
342 q_handle
= enqueue (queue
, t
->handle
);
343 if (waittime
== NULL
)
344 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
346 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
348 /* When we are still on QUEUE, we have been interrupted. We
349 report this only when no other error (such as a timeout) has
352 if (remqueue (queue
, q_handle
) && err
== 0)
355 scm_i_reset_sleep (t
);
361 /* Wake up the first thread on QUEUE, if any. The awoken thread is
362 returned, or #f if the queue was empty.
365 unblock_from_queue (SCM queue
)
367 SCM thread
= dequeue (queue
);
368 if (scm_is_true (thread
))
369 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
374 /* Getting into and out of guile mode.
377 /* Key used to attach a cleanup handler to a given thread. Also, if
378 thread-local storage is unavailable, this key is used to retrieve the
379 current thread with `pthread_getspecific ()'. */
380 scm_i_pthread_key_t scm_i_thread_key
;
383 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
385 /* When thread-local storage (TLS) is available, a pointer to the
386 current-thread object is kept in TLS. Note that storing the thread-object
387 itself in TLS (rather than a pointer to some malloc'd memory) is not
388 possible since thread objects may live longer than the actual thread they
390 SCM_THREAD_LOCAL scm_i_thread
*scm_i_current_thread
= NULL
;
392 #endif /* SCM_HAVE_THREAD_STORAGE_CLASS */
395 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
396 static scm_i_thread
*all_threads
= NULL
;
397 static int thread_count
;
399 static SCM scm_i_default_dynamic_state
;
401 /* Perform first stage of thread initialisation, in non-guile mode.
404 guilify_self_1 (SCM_STACKITEM
*base
)
406 scm_i_thread
*t
= scm_gc_malloc (sizeof (scm_i_thread
), "thread");
408 t
->pthread
= scm_i_pthread_self ();
409 t
->handle
= SCM_BOOL_F
;
410 t
->result
= SCM_BOOL_F
;
411 t
->cleanup_handler
= SCM_BOOL_F
;
412 t
->mutexes
= SCM_EOL
;
413 t
->held_mutex
= NULL
;
414 t
->join_queue
= SCM_EOL
;
415 t
->dynamic_state
= SCM_BOOL_F
;
416 t
->dynwinds
= SCM_EOL
;
417 t
->active_asyncs
= SCM_EOL
;
419 t
->pending_asyncs
= 1;
420 t
->critical_section_level
= 0;
423 /* Calculate and store off the base of this thread's register
424 backing store (RBS). Unfortunately our implementation(s) of
425 scm_ia64_register_backing_store_base are only reliable for the
426 main thread. For other threads, therefore, find out the current
427 top of the RBS, and use that as a maximum. */
428 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
433 bsp
= scm_ia64_ar_bsp (&ctx
);
434 if (t
->register_backing_store_base
> bsp
)
435 t
->register_backing_store_base
= bsp
;
438 t
->continuation_root
= SCM_EOL
;
439 t
->continuation_base
= base
;
440 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
441 t
->sleep_mutex
= NULL
;
442 t
->sleep_object
= SCM_BOOL_F
;
445 if (pipe (t
->sleep_pipe
) != 0)
446 /* FIXME: Error conditions during the initialization phase are handled
447 gracelessly since public functions such as `scm_init_guile ()'
448 currently have type `void'. */
451 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
452 t
->current_mark_stack_ptr
= NULL
;
453 t
->current_mark_stack_limit
= NULL
;
458 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
460 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
461 /* Cache the current thread in TLS for faster lookup. */
462 scm_i_current_thread
= t
;
465 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
466 t
->next_thread
= all_threads
;
469 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
472 /* Perform second stage of thread initialisation, in guile mode.
475 guilify_self_2 (SCM parent
)
477 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
481 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
483 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
484 t
->continuation_base
= t
->base
;
487 if (scm_is_true (parent
))
488 t
->dynamic_state
= scm_make_dynamic_state (parent
);
490 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
492 t
->join_queue
= make_queue ();
499 /* We implement our own mutex type since we want them to be 'fair', we
500 want to do fancy things while waiting for them (like running
501 asyncs) and we might want to add things that are nice for
506 scm_i_pthread_mutex_t lock
;
508 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
510 int recursive
; /* allow recursive locking? */
511 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
512 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
513 owned by the current thread? */
515 SCM waiting
; /* the threads waiting for this mutex. */
518 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
519 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
521 /* Perform thread tear-down, in guile mode.
524 do_thread_exit (void *v
)
526 scm_i_thread
*t
= (scm_i_thread
*) v
;
528 if (!scm_is_false (t
->cleanup_handler
))
530 SCM ptr
= t
->cleanup_handler
;
532 t
->cleanup_handler
= SCM_BOOL_F
;
533 t
->result
= scm_internal_catch (SCM_BOOL_T
,
534 (scm_t_catch_body
) scm_call_0
, ptr
,
535 scm_handle_by_message_noexit
, NULL
);
538 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
541 close (t
->sleep_pipe
[0]);
542 close (t
->sleep_pipe
[1]);
543 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
546 while (!scm_is_null (t
->mutexes
))
548 SCM mutex
= SCM_WEAK_PAIR_CAR (t
->mutexes
);
550 if (!SCM_UNBNDP (mutex
))
552 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
554 scm_i_pthread_mutex_lock (&m
->lock
);
556 /* Since MUTEX is in `t->mutexes', T must be its owner. */
557 assert (scm_is_eq (m
->owner
, t
->handle
));
559 unblock_from_queue (m
->waiting
);
561 scm_i_pthread_mutex_unlock (&m
->lock
);
564 t
->mutexes
= SCM_WEAK_PAIR_CDR (t
->mutexes
);
567 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
573 do_thread_exit_trampoline (struct GC_stack_base
*sb
, void *v
)
578 registered
= GC_register_my_thread (sb
);
580 ret
= scm_with_guile (do_thread_exit
, v
);
582 if (registered
== GC_SUCCESS
)
583 GC_unregister_my_thread ();
589 on_thread_exit (void *v
)
591 /* This handler is executed in non-guile mode. */
592 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
594 /* If this thread was cancelled while doing a cond wait, it will
595 still have a mutex locked, so we unlock it here. */
598 scm_i_pthread_mutex_unlock (t
->held_mutex
);
599 t
->held_mutex
= NULL
;
602 /* Reinstate the current thread for purposes of scm_with_guile
603 guile-mode cleanup handlers. Only really needed in the non-TLS
604 case but it doesn't hurt to be consistent. */
605 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
607 /* Ensure the signal handling thread has been launched, because we might be
609 scm_i_ensure_signal_delivery_thread ();
611 /* Unblocking the joining threads needs to happen in guile mode
612 since the queue is a SCM data structure. Trampoline through
613 GC_call_with_stack_base so that the GC works even if it already
614 cleaned up for this thread. */
615 GC_call_with_stack_base (do_thread_exit_trampoline
, v
);
617 /* Removing ourself from the list of all threads needs to happen in
618 non-guile mode since all SCM values on our stack become
619 unprotected once we are no longer in the list. */
620 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
621 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
624 *tp
= t
->next_thread
;
627 t
->next_thread
= NULL
;
633 /* If there's only one other thread, it could be the signal delivery
634 thread, so we need to notify it to shut down by closing its read pipe.
635 If it's not the signal delivery thread, then closing the read pipe isn't
637 if (thread_count
<= 1)
638 scm_i_close_signal_pipe ();
640 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
642 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
645 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
648 init_thread_key (void)
650 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
653 /* Perform any initializations necessary to make the current thread
654 known to Guile (via SCM_I_CURRENT_THREAD), initializing Guile itself,
657 BASE is the stack base to use with GC.
659 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
660 which case the default dynamic state is used.
662 Returns zero when the thread was known to guile already; otherwise
665 Note that it could be the case that the thread was known
666 to Guile, but not in guile mode (because we are within a
667 scm_without_guile call). Check SCM_I_CURRENT_THREAD->guile_mode to
668 be sure. New threads are put into guile mode implicitly. */
671 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
673 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
675 if (SCM_I_CURRENT_THREAD
)
677 /* Thread is already known to Guile.
683 /* This thread has not been guilified yet.
686 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
687 if (scm_initialized_p
== 0)
689 /* First thread ever to enter Guile. Run the full
692 scm_i_init_guile (base
);
693 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
697 /* Guile is already initialized, but this thread enters it for
698 the first time. Only initialize this thread.
700 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
701 guilify_self_1 (base
);
702 guilify_self_2 (parent
);
708 #if SCM_USE_PTHREAD_THREADS
710 #if defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP
711 /* This method for GNU/Linux and perhaps some other systems.
712 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
713 available on them. */
714 #define HAVE_GET_THREAD_STACK_BASE
716 static SCM_STACKITEM
*
717 get_thread_stack_base ()
723 pthread_getattr_np (pthread_self (), &attr
);
724 pthread_attr_getstack (&attr
, &start
, &size
);
725 end
= (char *)start
+ size
;
727 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
728 for the main thread, but we can use scm_get_stack_base in that
732 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
733 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
734 return (SCM_STACKITEM
*) GC_stackbottom
;
738 #if SCM_STACK_GROWS_UP
746 #elif defined HAVE_PTHREAD_GET_STACKADDR_NP
747 /* This method for MacOS X.
748 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
749 but as of 2006 there's nothing obvious at apple.com. */
750 #define HAVE_GET_THREAD_STACK_BASE
751 static SCM_STACKITEM
*
752 get_thread_stack_base ()
754 return pthread_get_stackaddr_np (pthread_self ());
757 #elif defined (__MINGW32__)
758 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
759 in any thread. We don't like hard-coding the name of a system, but there
760 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
762 #define HAVE_GET_THREAD_STACK_BASE
763 static SCM_STACKITEM
*
764 get_thread_stack_base ()
766 return (SCM_STACKITEM
*) GC_stackbottom
;
769 #endif /* pthread methods of get_thread_stack_base */
771 #else /* !SCM_USE_PTHREAD_THREADS */
773 #define HAVE_GET_THREAD_STACK_BASE
775 static SCM_STACKITEM
*
776 get_thread_stack_base ()
778 return (SCM_STACKITEM
*) GC_stackbottom
;
781 #endif /* !SCM_USE_PTHREAD_THREADS */
783 #ifdef HAVE_GET_THREAD_STACK_BASE
788 scm_i_init_thread_for_guile (get_thread_stack_base (),
789 scm_i_default_dynamic_state
);
795 scm_with_guile (void *(*func
)(void *), void *data
)
797 return scm_i_with_guile_and_parent (func
, data
,
798 scm_i_default_dynamic_state
);
801 SCM_UNUSED
static void
802 scm_leave_guile_cleanup (void *x
)
804 on_thread_exit (SCM_I_CURRENT_THREAD
);
807 struct with_guile_trampoline_args
814 with_guile_trampoline (void *data
)
816 struct with_guile_trampoline_args
*args
= data
;
818 return scm_c_with_continuation_barrier (args
->func
, args
->data
);
822 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
827 SCM_STACKITEM base_item
;
829 new_thread
= scm_i_init_thread_for_guile (&base_item
, parent
);
830 t
= SCM_I_CURRENT_THREAD
;
833 /* We are in Guile mode. */
834 assert (t
->guile_mode
);
836 res
= scm_c_with_continuation_barrier (func
, data
);
838 /* Leave Guile mode. */
841 else if (t
->guile_mode
)
843 /* Already in Guile mode. */
844 res
= scm_c_with_continuation_barrier (func
, data
);
848 struct with_guile_trampoline_args args
;
852 /* We are not in Guile mode, either because we are not within a
853 scm_with_guile, or because we are within a scm_without_guile.
855 This call to scm_with_guile() could happen from anywhere on the
856 stack, and in particular lower on the stack than when it was
857 when this thread was first guilified. Thus, `base' must be
859 #if SCM_STACK_GROWS_UP
860 if (SCM_STACK_PTR (&base_item
) < t
->base
)
861 t
->base
= SCM_STACK_PTR (&base_item
);
863 if (SCM_STACK_PTR (&base_item
) > t
->base
)
864 t
->base
= SCM_STACK_PTR (&base_item
);
868 res
= with_gc_active (with_guile_trampoline
, &args
);
875 scm_without_guile (void *(*func
)(void *), void *data
)
878 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
882 SCM_I_CURRENT_THREAD
->guile_mode
= 0;
883 result
= with_gc_inactive (func
, data
);
884 SCM_I_CURRENT_THREAD
->guile_mode
= 1;
887 /* Otherwise we're not in guile mode, so nothing to do. */
888 result
= func (data
);
894 /*** Thread creation */
901 scm_i_pthread_mutex_t mutex
;
902 scm_i_pthread_cond_t cond
;
906 really_launch (void *d
)
908 launch_data
*data
= (launch_data
*)d
;
909 SCM thunk
= data
->thunk
, handler
= data
->handler
;
912 t
= SCM_I_CURRENT_THREAD
;
914 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
915 data
->thread
= scm_current_thread ();
916 scm_i_pthread_cond_signal (&data
->cond
);
917 scm_i_pthread_mutex_unlock (&data
->mutex
);
919 if (SCM_UNBNDP (handler
))
920 t
->result
= scm_call_0 (thunk
);
922 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
928 launch_thread (void *d
)
930 launch_data
*data
= (launch_data
*)d
;
931 scm_i_pthread_detach (scm_i_pthread_self ());
932 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
936 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
937 (SCM thunk
, SCM handler
),
938 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
939 "returning a new thread object representing the thread. The procedure\n"
940 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
942 "When @var{handler} is specified, then @var{thunk} is called from\n"
943 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
944 "handler. This catch is established inside the continuation barrier.\n"
946 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
947 "the @emph{exit value} of the thread and the thread is terminated.")
948 #define FUNC_NAME s_scm_call_with_new_thread
954 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
955 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
956 handler
, SCM_ARG2
, FUNC_NAME
);
958 data
.parent
= scm_current_dynamic_state ();
960 data
.handler
= handler
;
961 data
.thread
= SCM_BOOL_F
;
962 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
963 scm_i_pthread_cond_init (&data
.cond
, NULL
);
965 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
966 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
969 scm_i_pthread_mutex_unlock (&data
.mutex
);
973 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
974 scm_i_pthread_mutex_unlock (&data
.mutex
);
982 scm_t_catch_body body
;
984 scm_t_catch_handler handler
;
987 scm_i_pthread_mutex_t mutex
;
988 scm_i_pthread_cond_t cond
;
992 really_spawn (void *d
)
994 spawn_data
*data
= (spawn_data
*)d
;
995 scm_t_catch_body body
= data
->body
;
996 void *body_data
= data
->body_data
;
997 scm_t_catch_handler handler
= data
->handler
;
998 void *handler_data
= data
->handler_data
;
999 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1001 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
1002 data
->thread
= scm_current_thread ();
1003 scm_i_pthread_cond_signal (&data
->cond
);
1004 scm_i_pthread_mutex_unlock (&data
->mutex
);
1006 if (handler
== NULL
)
1007 t
->result
= body (body_data
);
1009 t
->result
= scm_internal_catch (SCM_BOOL_T
,
1011 handler
, handler_data
);
1017 spawn_thread (void *d
)
1019 spawn_data
*data
= (spawn_data
*)d
;
1020 scm_i_pthread_detach (scm_i_pthread_self ());
1021 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
1026 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1027 scm_t_catch_handler handler
, void *handler_data
)
1033 data
.parent
= scm_current_dynamic_state ();
1035 data
.body_data
= body_data
;
1036 data
.handler
= handler
;
1037 data
.handler_data
= handler_data
;
1038 data
.thread
= SCM_BOOL_F
;
1039 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1040 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1042 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1043 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1046 scm_i_pthread_mutex_unlock (&data
.mutex
);
1048 scm_syserror (NULL
);
1050 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1051 scm_i_pthread_mutex_unlock (&data
.mutex
);
1056 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1058 "Move the calling thread to the end of the scheduling queue.")
1059 #define FUNC_NAME s_scm_yield
1061 return scm_from_bool (scm_i_sched_yield ());
1065 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1067 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1068 "cannot be the current thread, and if @var{thread} has already terminated or "
1069 "been signaled to terminate, this function is a no-op.")
1070 #define FUNC_NAME s_scm_cancel_thread
1072 scm_i_thread
*t
= NULL
;
1074 SCM_VALIDATE_THREAD (1, thread
);
1075 t
= SCM_I_THREAD_DATA (thread
);
1076 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1080 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1081 scm_i_pthread_cancel (t
->pthread
);
1084 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1086 return SCM_UNSPECIFIED
;
1090 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1091 (SCM thread
, SCM proc
),
1092 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1093 "This handler will be called when the thread exits.")
1094 #define FUNC_NAME s_scm_set_thread_cleanup_x
1098 SCM_VALIDATE_THREAD (1, thread
);
1099 if (!scm_is_false (proc
))
1100 SCM_VALIDATE_THUNK (2, proc
);
1102 t
= SCM_I_THREAD_DATA (thread
);
1103 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1105 if (!(t
->exited
|| t
->canceled
))
1106 t
->cleanup_handler
= proc
;
1108 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1110 return SCM_UNSPECIFIED
;
1114 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1116 "Return the cleanup handler installed for the thread @var{thread}.")
1117 #define FUNC_NAME s_scm_thread_cleanup
1122 SCM_VALIDATE_THREAD (1, thread
);
1124 t
= SCM_I_THREAD_DATA (thread
);
1125 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1126 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1127 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1133 SCM
scm_join_thread (SCM thread
)
1135 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1138 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1139 (SCM thread
, SCM timeout
, SCM timeoutval
),
1140 "Suspend execution of the calling thread until the target @var{thread} "
1141 "terminates, unless the target @var{thread} has already terminated. ")
1142 #define FUNC_NAME s_scm_join_thread_timed
1145 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1146 SCM res
= SCM_BOOL_F
;
1148 if (! (SCM_UNBNDP (timeoutval
)))
1151 SCM_VALIDATE_THREAD (1, thread
);
1152 if (scm_is_eq (scm_current_thread (), thread
))
1153 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1155 t
= SCM_I_THREAD_DATA (thread
);
1156 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1158 if (! SCM_UNBNDP (timeout
))
1160 to_timespec (timeout
, &ctimeout
);
1161 timeout_ptr
= &ctimeout
;
1170 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1180 else if (err
== ETIMEDOUT
)
1183 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1185 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1187 /* Check for exit again, since we just released and
1188 reacquired the admin mutex, before the next block_self
1189 call (which would block forever if t has already
1199 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1205 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1207 "Return @code{#t} if @var{obj} is a thread.")
1208 #define FUNC_NAME s_scm_thread_p
1210 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1216 fat_mutex_free (SCM mx
)
1218 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1219 scm_i_pthread_mutex_destroy (&m
->lock
);
1224 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1226 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1227 scm_puts ("#<mutex ", port
);
1228 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1229 scm_puts (">", port
);
1234 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1239 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1240 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1241 m
->owner
= SCM_BOOL_F
;
1244 m
->recursive
= recursive
;
1245 m
->unchecked_unlock
= unchecked_unlock
;
1246 m
->allow_external_unlock
= external_unlock
;
1248 m
->waiting
= SCM_EOL
;
1249 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1250 m
->waiting
= make_queue ();
1254 SCM
scm_make_mutex (void)
1256 return scm_make_mutex_with_flags (SCM_EOL
);
1259 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1260 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1261 SCM_SYMBOL (recursive_sym
, "recursive");
1263 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1265 "Create a new mutex. ")
1266 #define FUNC_NAME s_scm_make_mutex_with_flags
1268 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1271 while (! scm_is_null (ptr
))
1273 SCM flag
= SCM_CAR (ptr
);
1274 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1275 unchecked_unlock
= 1;
1276 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1277 external_unlock
= 1;
1278 else if (scm_is_eq (flag
, recursive_sym
))
1281 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1282 ptr
= SCM_CDR (ptr
);
1284 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1288 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1290 "Create a new recursive mutex. ")
1291 #define FUNC_NAME s_scm_make_recursive_mutex
1293 return make_fat_mutex (1, 0, 0);
1297 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1300 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1302 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1304 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1305 SCM err
= SCM_BOOL_F
;
1307 struct timeval current_time
;
1309 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1315 m
->owner
= new_owner
;
1318 if (SCM_I_IS_THREAD (new_owner
))
1320 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1321 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1323 /* Only keep a weak reference to MUTEX so that it's not
1324 retained when not referenced elsewhere (bug #27450).
1325 The weak pair itself is eventually removed when MUTEX
1326 is unlocked. Note that `t->mutexes' lists mutexes
1327 currently held by T, so it should be small. */
1328 t
->mutexes
= scm_weak_car_pair (mutex
, t
->mutexes
);
1330 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1335 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1337 m
->owner
= new_owner
;
1338 err
= scm_cons (scm_abandoned_mutex_error_key
,
1339 scm_from_locale_string ("lock obtained on abandoned "
1344 else if (scm_is_eq (m
->owner
, new_owner
))
1353 err
= scm_cons (scm_misc_error_key
,
1354 scm_from_locale_string ("mutex already locked "
1362 if (timeout
!= NULL
)
1364 gettimeofday (¤t_time
, NULL
);
1365 if (current_time
.tv_sec
> timeout
->tv_sec
||
1366 (current_time
.tv_sec
== timeout
->tv_sec
&&
1367 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1373 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1374 scm_i_pthread_mutex_unlock (&m
->lock
);
1376 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1379 scm_i_pthread_mutex_unlock (&m
->lock
);
1383 SCM
scm_lock_mutex (SCM mx
)
1385 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1388 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1389 (SCM m
, SCM timeout
, SCM owner
),
1390 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1391 "blocks until the mutex becomes available. The function returns when "
1392 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1393 "a thread already owns will succeed right away and will not block the "
1394 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1395 #define FUNC_NAME s_scm_lock_mutex_timed
1399 scm_t_timespec cwaittime
, *waittime
= NULL
;
1401 SCM_VALIDATE_MUTEX (1, m
);
1403 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1405 to_timespec (timeout
, &cwaittime
);
1406 waittime
= &cwaittime
;
1409 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1410 if (!scm_is_false (exception
))
1411 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1412 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1417 scm_dynwind_lock_mutex (SCM mutex
)
1419 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1420 SCM_F_WIND_EXPLICITLY
);
1421 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1422 SCM_F_WIND_EXPLICITLY
);
1425 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1427 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1428 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1429 #define FUNC_NAME s_scm_try_mutex
1433 scm_t_timespec cwaittime
, *waittime
= NULL
;
1435 SCM_VALIDATE_MUTEX (1, mutex
);
1437 to_timespec (scm_from_int(0), &cwaittime
);
1438 waittime
= &cwaittime
;
1440 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1441 if (!scm_is_false (exception
))
1442 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1443 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1447 /*** Fat condition variables */
1450 scm_i_pthread_mutex_t lock
;
1451 SCM waiting
; /* the threads waiting for this condition. */
1454 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1455 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1458 fat_mutex_unlock (SCM mutex
, SCM cond
,
1459 const scm_t_timespec
*waittime
, int relock
)
1462 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1464 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1465 int err
= 0, ret
= 0;
1467 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1471 if (!scm_is_eq (owner
, t
->handle
))
1475 if (!m
->unchecked_unlock
)
1477 scm_i_pthread_mutex_unlock (&m
->lock
);
1478 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1482 else if (!m
->allow_external_unlock
)
1484 scm_i_pthread_mutex_unlock (&m
->lock
);
1485 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1489 if (! (SCM_UNBNDP (cond
)))
1491 c
= SCM_CONDVAR_DATA (cond
);
1500 /* Change the owner of MUTEX. */
1501 t
->mutexes
= scm_delq_x (mutex
, t
->mutexes
);
1502 m
->owner
= unblock_from_queue (m
->waiting
);
1507 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1508 scm_i_pthread_mutex_unlock (&m
->lock
);
1515 else if (err
== ETIMEDOUT
)
1520 else if (err
!= EINTR
)
1523 scm_syserror (NULL
);
1529 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1537 scm_remember_upto_here_2 (cond
, mutex
);
1539 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1548 /* Change the owner of MUTEX. */
1549 t
->mutexes
= scm_delq_x (mutex
, t
->mutexes
);
1550 m
->owner
= unblock_from_queue (m
->waiting
);
1553 scm_i_pthread_mutex_unlock (&m
->lock
);
1560 SCM
scm_unlock_mutex (SCM mx
)
1562 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1565 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1566 (SCM mx
, SCM cond
, SCM timeout
),
1567 "Unlocks @var{mutex} if the calling thread owns the lock on "
1568 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1569 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1570 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1571 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1572 "with a call to @code{unlock-mutex}. Only the last call to "
1573 "@code{unlock-mutex} will actually unlock the mutex. ")
1574 #define FUNC_NAME s_scm_unlock_mutex_timed
1576 scm_t_timespec cwaittime
, *waittime
= NULL
;
1578 SCM_VALIDATE_MUTEX (1, mx
);
1579 if (! (SCM_UNBNDP (cond
)))
1581 SCM_VALIDATE_CONDVAR (2, cond
);
1583 if (! (SCM_UNBNDP (timeout
)))
1585 to_timespec (timeout
, &cwaittime
);
1586 waittime
= &cwaittime
;
1590 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1594 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1596 "Return @code{#t} if @var{obj} is a mutex.")
1597 #define FUNC_NAME s_scm_mutex_p
1599 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1603 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1605 "Return the thread owning @var{mx}, or @code{#f}.")
1606 #define FUNC_NAME s_scm_mutex_owner
1609 fat_mutex
*m
= NULL
;
1611 SCM_VALIDATE_MUTEX (1, mx
);
1612 m
= SCM_MUTEX_DATA (mx
);
1613 scm_i_pthread_mutex_lock (&m
->lock
);
1615 scm_i_pthread_mutex_unlock (&m
->lock
);
1621 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1623 "Return the lock level of mutex @var{mx}.")
1624 #define FUNC_NAME s_scm_mutex_level
1626 SCM_VALIDATE_MUTEX (1, mx
);
1627 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1631 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1633 "Returns @code{#t} if the mutex @var{mx} is locked.")
1634 #define FUNC_NAME s_scm_mutex_locked_p
1636 SCM_VALIDATE_MUTEX (1, mx
);
1637 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1642 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1644 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1645 scm_puts ("#<condition-variable ", port
);
1646 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1647 scm_puts (">", port
);
1651 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1653 "Make a new condition variable.")
1654 #define FUNC_NAME s_scm_make_condition_variable
1659 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1660 c
->waiting
= SCM_EOL
;
1661 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1662 c
->waiting
= make_queue ();
1667 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1668 (SCM cv
, SCM mx
, SCM t
),
1669 "Wait until @var{cond-var} has been signalled. While waiting, "
1670 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1671 "is locked again when this function returns. When @var{time} is given, "
1672 "it specifies a point in time where the waiting should be aborted. It "
1673 "can be either a integer as returned by @code{current-time} or a pair "
1674 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1675 "mutex is locked and @code{#f} is returned. When the condition "
1676 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1678 #define FUNC_NAME s_scm_timed_wait_condition_variable
1680 scm_t_timespec waittime
, *waitptr
= NULL
;
1682 SCM_VALIDATE_CONDVAR (1, cv
);
1683 SCM_VALIDATE_MUTEX (2, mx
);
1685 if (!SCM_UNBNDP (t
))
1687 to_timespec (t
, &waittime
);
1688 waitptr
= &waittime
;
1691 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1696 fat_cond_signal (fat_cond
*c
)
1698 unblock_from_queue (c
->waiting
);
1701 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1703 "Wake up one thread that is waiting for @var{cv}")
1704 #define FUNC_NAME s_scm_signal_condition_variable
1706 SCM_VALIDATE_CONDVAR (1, cv
);
1707 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1713 fat_cond_broadcast (fat_cond
*c
)
1715 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1719 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1721 "Wake up all threads that are waiting for @var{cv}. ")
1722 #define FUNC_NAME s_scm_broadcast_condition_variable
1724 SCM_VALIDATE_CONDVAR (1, cv
);
1725 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1730 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1732 "Return @code{#t} if @var{obj} is a condition variable.")
1733 #define FUNC_NAME s_scm_condition_variable_p
1735 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1746 SELECT_TYPE
*read_fds
;
1747 SELECT_TYPE
*write_fds
;
1748 SELECT_TYPE
*except_fds
;
1749 struct timeval
*timeout
;
1756 do_std_select (void *args
)
1758 struct select_args
*select_args
;
1760 select_args
= (struct select_args
*) args
;
1762 select_args
->result
=
1763 select (select_args
->nfds
,
1764 select_args
->read_fds
, select_args
->write_fds
,
1765 select_args
->except_fds
, select_args
->timeout
);
1766 select_args
->errno_value
= errno
;
1772 scm_std_select (int nfds
,
1773 SELECT_TYPE
*readfds
,
1774 SELECT_TYPE
*writefds
,
1775 SELECT_TYPE
*exceptfds
,
1776 struct timeval
*timeout
)
1779 int res
, eno
, wakeup_fd
;
1780 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1781 struct select_args args
;
1783 if (readfds
== NULL
)
1785 FD_ZERO (&my_readfds
);
1786 readfds
= &my_readfds
;
1789 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1792 wakeup_fd
= t
->sleep_pipe
[0];
1793 FD_SET (wakeup_fd
, readfds
);
1794 if (wakeup_fd
>= nfds
)
1798 args
.read_fds
= readfds
;
1799 args
.write_fds
= writefds
;
1800 args
.except_fds
= exceptfds
;
1801 args
.timeout
= timeout
;
1803 /* Explicitly cooperate with the GC. */
1804 scm_without_guile (do_std_select
, &args
);
1807 eno
= args
.errno_value
;
1810 scm_i_reset_sleep (t
);
1812 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1815 full_read (wakeup_fd
, &dummy
, 1);
1817 FD_CLR (wakeup_fd
, readfds
);
1829 /* Convenience API for blocking while in guile mode. */
1831 #if SCM_USE_PTHREAD_THREADS
1833 /* It seems reasonable to not run procedures related to mutex and condition
1834 variables within `GC_do_blocking ()' since, (i) the GC can operate even
1835 without it, and (ii) the only potential gain would be GC latency. See
1836 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2245/focus=2251
1837 for a discussion of the pros and cons. */
1840 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1842 int res
= scm_i_pthread_mutex_lock (mutex
);
1847 do_unlock (void *data
)
1849 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1853 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1855 scm_i_scm_pthread_mutex_lock (mutex
);
1856 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1860 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1863 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1865 t
->held_mutex
= mutex
;
1866 res
= scm_i_pthread_cond_wait (cond
, mutex
);
1867 t
->held_mutex
= NULL
;
1873 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1874 scm_i_pthread_mutex_t
*mutex
,
1875 const scm_t_timespec
*wt
)
1878 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1880 t
->held_mutex
= mutex
;
1881 res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1882 t
->held_mutex
= NULL
;
1890 scm_std_usleep (unsigned long usecs
)
1893 tv
.tv_usec
= usecs
% 1000000;
1894 tv
.tv_sec
= usecs
/ 1000000;
1895 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1896 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1900 scm_std_sleep (unsigned int secs
)
1905 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1911 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1913 "Return the thread that called this function.")
1914 #define FUNC_NAME s_scm_current_thread
1916 return SCM_I_CURRENT_THREAD
->handle
;
1921 scm_c_make_list (size_t n
, SCM fill
)
1925 res
= scm_cons (fill
, res
);
1929 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1931 "Return a list of all threads.")
1932 #define FUNC_NAME s_scm_all_threads
1934 /* We can not allocate while holding the thread_admin_mutex because
1935 of the way GC is done.
1937 int n
= thread_count
;
1939 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1941 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1943 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1945 if (t
!= scm_i_signal_delivery_thread
)
1947 SCM_SETCAR (*l
, t
->handle
);
1948 l
= SCM_CDRLOC (*l
);
1953 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1958 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1960 "Return @code{#t} iff @var{thread} has exited.\n")
1961 #define FUNC_NAME s_scm_thread_exited_p
1963 return scm_from_bool (scm_c_thread_exited_p (thread
));
1968 scm_c_thread_exited_p (SCM thread
)
1969 #define FUNC_NAME s_scm_thread_exited_p
1972 SCM_VALIDATE_THREAD (1, thread
);
1973 t
= SCM_I_THREAD_DATA (thread
);
1978 static scm_i_pthread_cond_t wake_up_cond
;
1979 static int threads_initialized_p
= 0;
1982 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1984 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1986 static SCM dynwind_critical_section_mutex
;
1989 scm_dynwind_critical_section (SCM mutex
)
1991 if (scm_is_false (mutex
))
1992 mutex
= dynwind_critical_section_mutex
;
1993 scm_dynwind_lock_mutex (mutex
);
1994 scm_dynwind_block_asyncs ();
1997 /*** Initialization */
1999 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2001 #if SCM_USE_PTHREAD_THREADS
2002 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2006 scm_threads_prehistory (SCM_STACKITEM
*base
)
2008 #if SCM_USE_PTHREAD_THREADS
2009 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2010 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2011 PTHREAD_MUTEX_RECURSIVE
);
2014 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2015 scm_i_pthread_mutexattr_recursive
);
2016 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2017 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2019 guilify_self_1 (base
);
2022 scm_t_bits scm_tc16_thread
;
2023 scm_t_bits scm_tc16_mutex
;
2024 scm_t_bits scm_tc16_condvar
;
2029 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2030 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2032 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2033 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2034 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2036 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2038 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2040 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2041 guilify_self_2 (SCM_BOOL_F
);
2042 threads_initialized_p
= 1;
2044 dynwind_critical_section_mutex
= scm_make_recursive_mutex ();
2048 scm_init_threads_default_dynamic_state ()
2050 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2051 scm_i_default_dynamic_state
= state
;
2055 scm_init_thread_procs ()
2057 #include "libguile/threads.x"
2061 /* IA64-specific things. */
2065 # include <sys/param.h>
2066 # include <sys/pstat.h>
2068 scm_ia64_register_backing_store_base (void)
2070 struct pst_vm_status vm_status
;
2072 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
2073 if (vm_status
.pst_type
== PS_RSESTACK
)
2074 return (void *) vm_status
.pst_vaddr
;
2078 scm_ia64_ar_bsp (const void *ctx
)
2081 __uc_get_ar_bsp (ctx
, &bsp
);
2082 return (void *) bsp
;
2086 # include <ucontext.h>
2088 scm_ia64_register_backing_store_base (void)
2090 extern void *__libc_ia64_register_backing_store_base
;
2091 return __libc_ia64_register_backing_store_base
;
2094 scm_ia64_ar_bsp (const void *opaque
)
2096 const ucontext_t
*ctx
= opaque
;
2097 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
2100 #endif /* __ia64__ */