1 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
2 * 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
3 * 2014 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/bdw-gc.h"
28 #include <gc/gc_mark.h>
29 #include "libguile/_scm.h"
36 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
44 # include <pthread_np.h>
47 #include <sys/select.h>
53 #include "libguile/validate.h"
54 #include "libguile/root.h"
55 #include "libguile/eval.h"
56 #include "libguile/async.h"
57 #include "libguile/ports.h"
58 #include "libguile/threads.h"
59 #include "libguile/dynwind.h"
60 #include "libguile/iselect.h"
61 #include "libguile/fluids.h"
62 #include "libguile/continuations.h"
63 #include "libguile/gc.h"
64 #include "libguile/gc-inline.h"
65 #include "libguile/init.h"
66 #include "libguile/scmsigs.h"
67 #include "libguile/strings.h"
68 #include "libguile/vm.h"
70 #include <full-read.h>
75 /* The GC "kind" for threads that allow them to mark their VM
77 static int thread_gc_kind
;
79 static struct GC_ms_entry
*
80 thread_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
81 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
84 const struct scm_i_thread
*t
= (struct scm_i_thread
*) addr
;
86 if (SCM_UNPACK (t
->handle
) == 0)
87 /* T must be on the free-list; ignore. (See warning in
89 return mark_stack_ptr
;
91 /* Mark T. We could be more precise, but it doesn't matter. */
92 for (word
= 0; word
* sizeof (*addr
) < sizeof (*t
); word
++)
93 mark_stack_ptr
= GC_MARK_AND_PUSH ((void *) addr
[word
],
94 mark_stack_ptr
, mark_stack_limit
,
97 /* The pointerless freelists are threaded through their first word,
98 but GC doesn't know to trace them (as they are pointerless), so we
99 need to do that here. See the comments at the top of libgc's
101 if (t
->pointerless_freelists
)
104 for (n
= 0; n
< SCM_INLINE_GC_FREELIST_COUNT
; n
++)
106 void *chain
= t
->pointerless_freelists
[n
];
109 /* The first link is already marked by the freelist vector,
110 so we just have to mark the tail. */
111 while ((chain
= *(void **)chain
))
112 mark_stack_ptr
= GC_mark_and_push (chain
, mark_stack_ptr
,
113 mark_stack_limit
, NULL
);
119 mark_stack_ptr
= scm_i_vm_mark_stack (t
->vp
, mark_stack_ptr
,
122 return mark_stack_ptr
;
128 to_timespec (SCM t
, scm_t_timespec
*waittime
)
132 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
133 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
137 double time
= scm_to_double (t
);
138 double sec
= scm_c_truncate (time
);
140 waittime
->tv_sec
= (long) sec
;
141 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
149 /* Note: We annotate with "GC-robust" assignments whose purpose is to avoid
150 the risk of false references leading to unbounded retained space as
151 described in "Bounding Space Usage of Conservative Garbage Collectors",
154 /* Make an empty queue data structure.
159 return scm_cons (SCM_EOL
, SCM_EOL
);
162 /* Put T at the back of Q and return a handle that can be used with
163 remqueue to remove T from Q again.
166 enqueue (SCM q
, SCM t
)
168 SCM c
= scm_cons (t
, SCM_EOL
);
169 SCM_CRITICAL_SECTION_START
;
170 if (scm_is_null (SCM_CDR (q
)))
173 SCM_SETCDR (SCM_CAR (q
), c
);
175 SCM_CRITICAL_SECTION_END
;
179 /* Remove the element that the handle C refers to from the queue Q. C
180 must have been returned from a call to enqueue. The return value
181 is zero when the element referred to by C has already been removed.
182 Otherwise, 1 is returned.
185 remqueue (SCM q
, SCM c
)
188 SCM_CRITICAL_SECTION_START
;
189 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
191 if (scm_is_eq (p
, c
))
193 if (scm_is_eq (c
, SCM_CAR (q
)))
194 SCM_SETCAR (q
, scm_is_eq (prev
, q
) ? SCM_EOL
: prev
);
195 SCM_SETCDR (prev
, SCM_CDR (c
));
198 SCM_SETCDR (c
, SCM_EOL
);
200 SCM_CRITICAL_SECTION_END
;
205 SCM_CRITICAL_SECTION_END
;
209 /* Remove the front-most element from the queue Q and return it.
210 Return SCM_BOOL_F when Q is empty.
216 SCM_CRITICAL_SECTION_START
;
220 SCM_CRITICAL_SECTION_END
;
225 SCM_SETCDR (q
, SCM_CDR (c
));
226 if (scm_is_null (SCM_CDR (q
)))
227 SCM_SETCAR (q
, SCM_EOL
);
228 SCM_CRITICAL_SECTION_END
;
231 SCM_SETCDR (c
, SCM_EOL
);
237 /*** Thread smob routines */
241 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
243 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
244 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
245 the struct case, hence we go via a union, and extract according to the
246 size of pthread_t. */
254 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
255 scm_i_pthread_t p
= t
->pthread
;
258 if (sizeof (p
) == sizeof (unsigned short))
260 else if (sizeof (p
) == sizeof (unsigned int))
262 else if (sizeof (p
) == sizeof (unsigned long))
267 scm_puts_unlocked ("#<thread ", port
);
268 scm_uintprint (id
, 10, port
);
269 scm_puts_unlocked (" (", port
);
270 scm_uintprint ((scm_t_bits
)t
, 16, port
);
271 scm_puts_unlocked (")>", port
);
276 /*** Blocking on queues. */
278 /* See also scm_i_queue_async_cell for how such a block is
282 /* Put the current thread on QUEUE and go to sleep, waiting for it to
283 be woken up by a call to 'unblock_from_queue', or to be
284 interrupted. Upon return of this function, the current thread is
285 no longer on QUEUE, even when the sleep has been interrupted.
287 The caller of block_self must hold MUTEX. It will be atomically
288 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
290 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
293 When WAITTIME is not NULL, the sleep will be aborted at that time.
295 The return value of block_self is an errno value. It will be zero
296 when the sleep has been successfully completed by a call to
297 unblock_from_queue, EINTR when it has been interrupted by the
298 delivery of a system async, and ETIMEDOUT when the timeout has
301 The system asyncs themselves are not executed by block_self.
304 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
305 const scm_t_timespec
*waittime
)
307 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
311 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
316 q_handle
= enqueue (queue
, t
->handle
);
317 if (waittime
== NULL
)
318 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
320 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
322 /* When we are still on QUEUE, we have been interrupted. We
323 report this only when no other error (such as a timeout) has
326 if (remqueue (queue
, q_handle
) && err
== 0)
329 scm_i_reset_sleep (t
);
335 /* Wake up the first thread on QUEUE, if any. The awoken thread is
336 returned, or #f if the queue was empty.
339 unblock_from_queue (SCM queue
)
341 SCM thread
= dequeue (queue
);
342 if (scm_is_true (thread
))
343 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
348 /* Getting into and out of guile mode.
351 /* Key used to attach a cleanup handler to a given thread. Also, if
352 thread-local storage is unavailable, this key is used to retrieve the
353 current thread with `pthread_getspecific ()'. */
354 scm_i_pthread_key_t scm_i_thread_key
;
357 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
359 /* When thread-local storage (TLS) is available, a pointer to the
360 current-thread object is kept in TLS. Note that storing the thread-object
361 itself in TLS (rather than a pointer to some malloc'd memory) is not
362 possible since thread objects may live longer than the actual thread they
364 SCM_THREAD_LOCAL scm_i_thread
*scm_i_current_thread
= NULL
;
366 #endif /* SCM_HAVE_THREAD_STORAGE_CLASS */
369 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
370 static scm_i_thread
*all_threads
= NULL
;
371 static int thread_count
;
373 static SCM scm_i_default_dynamic_state
;
375 /* Run when a fluid is collected. */
377 scm_i_reset_fluid (size_t n
)
381 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
382 for (t
= all_threads
; t
; t
= t
->next_thread
)
383 if (SCM_I_DYNAMIC_STATE_P (t
->dynamic_state
))
385 SCM v
= SCM_I_DYNAMIC_STATE_FLUIDS (t
->dynamic_state
);
387 if (n
< SCM_SIMPLE_VECTOR_LENGTH (v
))
388 SCM_SIMPLE_VECTOR_SET (v
, n
, SCM_UNDEFINED
);
390 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
393 /* Perform first stage of thread initialisation, in non-guile mode.
396 guilify_self_1 (struct GC_stack_base
*base
)
400 /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value
401 before allocating anything in this thread, because allocation could
402 cause GC to run, and GC could cause finalizers, which could invoke
403 Scheme functions, which need the current thread to be set. */
405 t
.pthread
= scm_i_pthread_self ();
406 t
.handle
= SCM_BOOL_F
;
407 t
.result
= SCM_BOOL_F
;
408 t
.cleanup_handler
= SCM_BOOL_F
;
411 t
.join_queue
= SCM_EOL
;
413 t
.pointerless_freelists
= NULL
;
414 t
.dynamic_state
= SCM_BOOL_F
;
415 t
.dynstack
.base
= NULL
;
416 t
.dynstack
.top
= NULL
;
417 t
.dynstack
.limit
= NULL
;
418 t
.active_asyncs
= SCM_EOL
;
420 t
.pending_asyncs
= 1;
421 t
.critical_section_level
= 0;
422 t
.base
= base
->mem_base
;
424 t
.register_backing_store_base
= base
->reg_base
;
426 t
.continuation_root
= SCM_EOL
;
427 t
.continuation_base
= t
.base
;
428 scm_i_pthread_cond_init (&t
.sleep_cond
, NULL
);
429 t
.sleep_mutex
= NULL
;
430 t
.sleep_object
= SCM_BOOL_F
;
434 if (pipe2 (t
.sleep_pipe
, O_CLOEXEC
) != 0)
435 /* FIXME: Error conditions during the initialization phase are handled
436 gracelessly since public functions such as `scm_init_guile ()'
437 currently have type `void'. */
440 scm_i_pthread_mutex_init (&t
.admin_mutex
, NULL
);
445 /* The switcheroo. */
447 scm_i_thread
*t_ptr
= &t
;
450 t_ptr
= GC_generic_malloc (sizeof (*t_ptr
), thread_gc_kind
);
451 memcpy (t_ptr
, &t
, sizeof t
);
453 scm_i_pthread_setspecific (scm_i_thread_key
, t_ptr
);
455 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
456 /* Cache the current thread in TLS for faster lookup. */
457 scm_i_current_thread
= t_ptr
;
460 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
461 t_ptr
->next_thread
= all_threads
;
464 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
470 /* Perform second stage of thread initialisation, in guile mode.
473 guilify_self_2 (SCM parent
)
475 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
479 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
481 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
482 t
->continuation_base
= t
->base
;
485 size_t size
= SCM_INLINE_GC_FREELIST_COUNT
* sizeof (void *);
486 t
->freelists
= scm_gc_malloc (size
, "freelists");
487 t
->pointerless_freelists
= scm_gc_malloc (size
, "atomic freelists");
490 if (scm_is_true (parent
))
491 t
->dynamic_state
= scm_make_dynamic_state (parent
);
493 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
495 t
->dynstack
.base
= scm_gc_malloc (16 * sizeof (scm_t_bits
), "dynstack");
496 t
->dynstack
.limit
= t
->dynstack
.base
+ 16;
497 t
->dynstack
.top
= t
->dynstack
.base
+ SCM_DYNSTACK_HEADER_LEN
;
499 t
->join_queue
= make_queue ();
502 /* See note in finalizers.c:queue_finalizer_async(). */
503 GC_invoke_finalizers ();
509 /* We implement our own mutex type since we want them to be 'fair', we
510 want to do fancy things while waiting for them (like running
511 asyncs) and we might want to add things that are nice for
516 scm_i_pthread_mutex_t lock
;
518 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
520 int recursive
; /* allow recursive locking? */
521 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
522 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
523 owned by the current thread? */
525 SCM waiting
; /* the threads waiting for this mutex. */
528 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
529 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
532 call_cleanup (void *data
)
535 return scm_call_0 (*proc_p
);
538 /* Perform thread tear-down, in guile mode.
541 do_thread_exit (void *v
)
543 scm_i_thread
*t
= (scm_i_thread
*) v
;
545 if (!scm_is_false (t
->cleanup_handler
))
547 SCM ptr
= t
->cleanup_handler
;
549 t
->cleanup_handler
= SCM_BOOL_F
;
550 t
->result
= scm_internal_catch (SCM_BOOL_T
,
552 scm_handle_by_message_noexit
, NULL
);
555 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
558 close (t
->sleep_pipe
[0]);
559 close (t
->sleep_pipe
[1]);
560 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
563 while (!scm_is_null (t
->mutexes
))
565 SCM mutex
= scm_c_weak_vector_ref (scm_car (t
->mutexes
), 0);
567 if (scm_is_true (mutex
))
569 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
571 scm_i_pthread_mutex_lock (&m
->lock
);
573 /* Check whether T owns MUTEX. This is usually the case, unless
574 T abandoned MUTEX; in that case, T is no longer its owner (see
575 `fat_mutex_lock') but MUTEX is still in `t->mutexes'. */
576 if (scm_is_eq (m
->owner
, t
->handle
))
577 unblock_from_queue (m
->waiting
);
579 scm_i_pthread_mutex_unlock (&m
->lock
);
582 t
->mutexes
= scm_cdr (t
->mutexes
);
585 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
591 do_thread_exit_trampoline (struct GC_stack_base
*sb
, void *v
)
593 /* Won't hurt if we are already registered. */
594 #if SCM_USE_PTHREAD_THREADS
595 GC_register_my_thread (sb
);
598 return scm_with_guile (do_thread_exit
, v
);
602 on_thread_exit (void *v
)
604 /* This handler is executed in non-guile mode. */
605 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
607 /* If we were canceled, we were unable to clear `t->guile_mode', so do
611 /* If this thread was cancelled while doing a cond wait, it will
612 still have a mutex locked, so we unlock it here. */
615 scm_i_pthread_mutex_unlock (t
->held_mutex
);
616 t
->held_mutex
= NULL
;
619 /* Reinstate the current thread for purposes of scm_with_guile
620 guile-mode cleanup handlers. Only really needed in the non-TLS
621 case but it doesn't hurt to be consistent. */
622 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
624 /* Scheme-level thread finalizers and other cleanup needs to happen in
626 GC_call_with_stack_base (do_thread_exit_trampoline
, t
);
628 /* Removing ourself from the list of all threads needs to happen in
629 non-guile mode since all SCM values on our stack become
630 unprotected once we are no longer in the list. */
631 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
632 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
635 *tp
= t
->next_thread
;
638 t
->next_thread
= NULL
;
644 /* If there's only one other thread, it could be the signal delivery
645 thread, so we need to notify it to shut down by closing its read pipe.
646 If it's not the signal delivery thread, then closing the read pipe isn't
648 if (thread_count
<= 1)
649 scm_i_close_signal_pipe ();
651 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
653 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
657 scm_i_vm_free_stack (t
->vp
);
661 #if SCM_USE_PTHREAD_THREADS
662 GC_unregister_my_thread ();
666 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
669 init_thread_key (void)
671 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
674 /* Perform any initializations necessary to make the current thread
675 known to Guile (via SCM_I_CURRENT_THREAD), initializing Guile itself,
678 BASE is the stack base to use with GC.
680 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
681 which case the default dynamic state is used.
683 Returns zero when the thread was known to guile already; otherwise
686 Note that it could be the case that the thread was known
687 to Guile, but not in guile mode (because we are within a
688 scm_without_guile call). Check SCM_I_CURRENT_THREAD->guile_mode to
689 be sure. New threads are put into guile mode implicitly. */
692 scm_i_init_thread_for_guile (struct GC_stack_base
*base
, SCM parent
)
694 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
696 if (SCM_I_CURRENT_THREAD
)
698 /* Thread is already known to Guile.
704 /* This thread has not been guilified yet.
707 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
708 if (scm_initialized_p
== 0)
710 /* First thread ever to enter Guile. Run the full
713 scm_i_init_guile (base
);
715 #if SCM_USE_PTHREAD_THREADS
716 /* Allow other threads to come in later. */
717 GC_allow_register_threads ();
720 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
724 /* Guile is already initialized, but this thread enters it for
725 the first time. Only initialize this thread.
727 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
729 /* Register this thread with libgc. */
730 #if SCM_USE_PTHREAD_THREADS
731 GC_register_my_thread (base
);
734 guilify_self_1 (base
);
735 guilify_self_2 (parent
);
744 struct GC_stack_base stack_base
;
746 if (GC_get_stack_base (&stack_base
) == GC_SUCCESS
)
747 scm_i_init_thread_for_guile (&stack_base
,
748 scm_i_default_dynamic_state
);
751 fprintf (stderr
, "Failed to get stack base for current thread.\n");
756 struct with_guile_args
764 with_guile_trampoline (void *data
)
766 struct with_guile_args
*args
= data
;
768 return scm_c_with_continuation_barrier (args
->func
, args
->data
);
772 with_guile_and_parent (struct GC_stack_base
*base
, void *data
)
777 struct with_guile_args
*args
= data
;
779 new_thread
= scm_i_init_thread_for_guile (base
, args
->parent
);
780 t
= SCM_I_CURRENT_THREAD
;
783 /* We are in Guile mode. */
784 assert (t
->guile_mode
);
786 res
= scm_c_with_continuation_barrier (args
->func
, args
->data
);
788 /* Leave Guile mode. */
791 else if (t
->guile_mode
)
793 /* Already in Guile mode. */
794 res
= scm_c_with_continuation_barrier (args
->func
, args
->data
);
798 /* We are not in Guile mode, either because we are not within a
799 scm_with_guile, or because we are within a scm_without_guile.
801 This call to scm_with_guile() could happen from anywhere on the
802 stack, and in particular lower on the stack than when it was
803 when this thread was first guilified. Thus, `base' must be
805 #if SCM_STACK_GROWS_UP
806 if (SCM_STACK_PTR (base
->mem_base
) < t
->base
)
807 t
->base
= SCM_STACK_PTR (base
->mem_base
);
809 if (SCM_STACK_PTR (base
->mem_base
) > t
->base
)
810 t
->base
= SCM_STACK_PTR (base
->mem_base
);
814 res
= GC_call_with_gc_active (with_guile_trampoline
, args
);
821 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
823 struct with_guile_args args
;
827 args
.parent
= parent
;
829 return GC_call_with_stack_base (with_guile_and_parent
, &args
);
833 scm_with_guile (void *(*func
)(void *), void *data
)
835 return scm_i_with_guile_and_parent (func
, data
,
836 scm_i_default_dynamic_state
);
840 scm_without_guile (void *(*func
)(void *), void *data
)
843 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
847 SCM_I_CURRENT_THREAD
->guile_mode
= 0;
848 result
= GC_do_blocking (func
, data
);
849 SCM_I_CURRENT_THREAD
->guile_mode
= 1;
852 /* Otherwise we're not in guile mode, so nothing to do. */
853 result
= func (data
);
859 /*** Thread creation */
866 scm_i_pthread_mutex_t mutex
;
867 scm_i_pthread_cond_t cond
;
871 really_launch (void *d
)
873 launch_data
*data
= (launch_data
*)d
;
874 SCM thunk
= data
->thunk
, handler
= data
->handler
;
877 t
= SCM_I_CURRENT_THREAD
;
879 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
880 data
->thread
= scm_current_thread ();
881 scm_i_pthread_cond_signal (&data
->cond
);
882 scm_i_pthread_mutex_unlock (&data
->mutex
);
884 if (SCM_UNBNDP (handler
))
885 t
->result
= scm_call_0 (thunk
);
887 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
893 launch_thread (void *d
)
895 launch_data
*data
= (launch_data
*)d
;
896 scm_i_pthread_detach (scm_i_pthread_self ());
897 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
901 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
902 (SCM thunk
, SCM handler
),
903 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
904 "returning a new thread object representing the thread. The procedure\n"
905 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
907 "When @var{handler} is specified, then @var{thunk} is called from\n"
908 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
909 "handler. This catch is established inside the continuation barrier.\n"
911 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
912 "the @emph{exit value} of the thread and the thread is terminated.")
913 #define FUNC_NAME s_scm_call_with_new_thread
919 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
920 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
921 handler
, SCM_ARG2
, FUNC_NAME
);
923 GC_collect_a_little ();
924 data
.parent
= scm_current_dynamic_state ();
926 data
.handler
= handler
;
927 data
.thread
= SCM_BOOL_F
;
928 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
929 scm_i_pthread_cond_init (&data
.cond
, NULL
);
931 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
932 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
935 scm_i_pthread_mutex_unlock (&data
.mutex
);
940 while (scm_is_false (data
.thread
))
941 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
943 scm_i_pthread_mutex_unlock (&data
.mutex
);
951 scm_t_catch_body body
;
953 scm_t_catch_handler handler
;
956 scm_i_pthread_mutex_t mutex
;
957 scm_i_pthread_cond_t cond
;
961 really_spawn (void *d
)
963 spawn_data
*data
= (spawn_data
*)d
;
964 scm_t_catch_body body
= data
->body
;
965 void *body_data
= data
->body_data
;
966 scm_t_catch_handler handler
= data
->handler
;
967 void *handler_data
= data
->handler_data
;
968 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
970 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
971 data
->thread
= scm_current_thread ();
972 scm_i_pthread_cond_signal (&data
->cond
);
973 scm_i_pthread_mutex_unlock (&data
->mutex
);
976 t
->result
= body (body_data
);
978 t
->result
= scm_internal_catch (SCM_BOOL_T
,
980 handler
, handler_data
);
986 spawn_thread (void *d
)
988 spawn_data
*data
= (spawn_data
*)d
;
989 scm_i_pthread_detach (scm_i_pthread_self ());
990 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
995 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
996 scm_t_catch_handler handler
, void *handler_data
)
1002 data
.parent
= scm_current_dynamic_state ();
1004 data
.body_data
= body_data
;
1005 data
.handler
= handler
;
1006 data
.handler_data
= handler_data
;
1007 data
.thread
= SCM_BOOL_F
;
1008 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1009 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1011 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1012 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1015 scm_i_pthread_mutex_unlock (&data
.mutex
);
1017 scm_syserror (NULL
);
1020 while (scm_is_false (data
.thread
))
1021 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1023 scm_i_pthread_mutex_unlock (&data
.mutex
);
1025 assert (SCM_I_IS_THREAD (data
.thread
));
1030 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1032 "Move the calling thread to the end of the scheduling queue.")
1033 #define FUNC_NAME s_scm_yield
1035 return scm_from_bool (scm_i_sched_yield ());
1039 /* Some systems, notably Android, lack 'pthread_cancel'. Don't provide
1040 'cancel-thread' on these systems. */
1042 #if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL
1044 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1046 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1047 "cannot be the current thread, and if @var{thread} has already terminated or "
1048 "been signaled to terminate, this function is a no-op.")
1049 #define FUNC_NAME s_scm_cancel_thread
1051 scm_i_thread
*t
= NULL
;
1053 SCM_VALIDATE_THREAD (1, thread
);
1054 t
= SCM_I_THREAD_DATA (thread
);
1055 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1059 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1060 scm_i_pthread_cancel (t
->pthread
);
1063 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1065 return SCM_UNSPECIFIED
;
1071 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1072 (SCM thread
, SCM proc
),
1073 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1074 "This handler will be called when the thread exits.")
1075 #define FUNC_NAME s_scm_set_thread_cleanup_x
1079 SCM_VALIDATE_THREAD (1, thread
);
1080 if (!scm_is_false (proc
))
1081 SCM_VALIDATE_THUNK (2, proc
);
1083 t
= SCM_I_THREAD_DATA (thread
);
1084 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1086 if (!(t
->exited
|| t
->canceled
))
1087 t
->cleanup_handler
= proc
;
1089 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1091 return SCM_UNSPECIFIED
;
1095 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1097 "Return the cleanup handler installed for the thread @var{thread}.")
1098 #define FUNC_NAME s_scm_thread_cleanup
1103 SCM_VALIDATE_THREAD (1, thread
);
1105 t
= SCM_I_THREAD_DATA (thread
);
1106 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1107 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1108 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1114 SCM
scm_join_thread (SCM thread
)
1116 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1119 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1120 (SCM thread
, SCM timeout
, SCM timeoutval
),
1121 "Suspend execution of the calling thread until the target @var{thread} "
1122 "terminates, unless the target @var{thread} has already terminated. ")
1123 #define FUNC_NAME s_scm_join_thread_timed
1126 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1127 SCM res
= SCM_BOOL_F
;
1129 if (! (SCM_UNBNDP (timeoutval
)))
1132 SCM_VALIDATE_THREAD (1, thread
);
1133 if (scm_is_eq (scm_current_thread (), thread
))
1134 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1136 t
= SCM_I_THREAD_DATA (thread
);
1137 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1139 if (! SCM_UNBNDP (timeout
))
1141 to_timespec (timeout
, &ctimeout
);
1142 timeout_ptr
= &ctimeout
;
1151 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1161 else if (err
== ETIMEDOUT
)
1164 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1166 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1168 /* Check for exit again, since we just released and
1169 reacquired the admin mutex, before the next block_self
1170 call (which would block forever if t has already
1180 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1186 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1188 "Return @code{#t} if @var{obj} is a thread.")
1189 #define FUNC_NAME s_scm_thread_p
1191 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1197 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1199 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1200 scm_puts_unlocked ("#<mutex ", port
);
1201 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1202 scm_puts_unlocked (">", port
);
1207 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1211 scm_i_pthread_mutex_t lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
1213 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1214 /* Because PTHREAD_MUTEX_INITIALIZER is static, it's plain old data,
1215 and so we can just copy it. */
1216 memcpy (&m
->lock
, &lock
, sizeof (m
->lock
));
1217 m
->owner
= SCM_BOOL_F
;
1220 m
->recursive
= recursive
;
1221 m
->unchecked_unlock
= unchecked_unlock
;
1222 m
->allow_external_unlock
= external_unlock
;
1224 m
->waiting
= SCM_EOL
;
1225 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1226 m
->waiting
= make_queue ();
1230 SCM
scm_make_mutex (void)
1232 return scm_make_mutex_with_flags (SCM_EOL
);
1235 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1236 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1237 SCM_SYMBOL (recursive_sym
, "recursive");
1239 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1241 "Create a new mutex. ")
1242 #define FUNC_NAME s_scm_make_mutex_with_flags
1244 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1247 while (! scm_is_null (ptr
))
1249 SCM flag
= SCM_CAR (ptr
);
1250 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1251 unchecked_unlock
= 1;
1252 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1253 external_unlock
= 1;
1254 else if (scm_is_eq (flag
, recursive_sym
))
1257 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1258 ptr
= SCM_CDR (ptr
);
1260 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1264 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1266 "Create a new recursive mutex. ")
1267 #define FUNC_NAME s_scm_make_recursive_mutex
1269 return make_fat_mutex (1, 0, 0);
1273 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1276 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1278 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1280 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1281 SCM err
= SCM_BOOL_F
;
1283 struct timeval current_time
;
1285 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1291 m
->owner
= new_owner
;
1294 if (SCM_I_IS_THREAD (new_owner
))
1296 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1298 /* FIXME: The order in which `t->admin_mutex' and
1299 `m->lock' are taken differs from that in
1300 `on_thread_exit', potentially leading to deadlocks. */
1301 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1303 /* Only keep a weak reference to MUTEX so that it's not
1304 retained when not referenced elsewhere (bug #27450).
1305 The weak pair itself is eventually removed when MUTEX
1306 is unlocked. Note that `t->mutexes' lists mutexes
1307 currently held by T, so it should be small. */
1308 t
->mutexes
= scm_cons (scm_make_weak_vector (SCM_INUM1
, mutex
),
1311 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1316 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1318 m
->owner
= new_owner
;
1319 err
= scm_cons (scm_abandoned_mutex_error_key
,
1320 scm_from_locale_string ("lock obtained on abandoned "
1325 else if (scm_is_eq (m
->owner
, new_owner
))
1334 err
= scm_cons (scm_misc_error_key
,
1335 scm_from_locale_string ("mutex already locked "
1343 if (timeout
!= NULL
)
1345 gettimeofday (¤t_time
, NULL
);
1346 if (current_time
.tv_sec
> timeout
->tv_sec
||
1347 (current_time
.tv_sec
== timeout
->tv_sec
&&
1348 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1354 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1355 scm_i_pthread_mutex_unlock (&m
->lock
);
1357 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1360 scm_i_pthread_mutex_unlock (&m
->lock
);
1364 SCM
scm_lock_mutex (SCM mx
)
1366 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1369 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1370 (SCM m
, SCM timeout
, SCM owner
),
1371 "Lock mutex @var{m}. If the mutex is already locked, the calling\n"
1372 "thread blocks until the mutex becomes available. The function\n"
1373 "returns when the calling thread owns the lock on @var{m}.\n"
1374 "Locking a mutex that a thread already owns will succeed right\n"
1375 "away and will not block the thread. That is, Guile's mutexes\n"
1376 "are @emph{recursive}.")
1377 #define FUNC_NAME s_scm_lock_mutex_timed
1381 scm_t_timespec cwaittime
, *waittime
= NULL
;
1383 SCM_VALIDATE_MUTEX (1, m
);
1385 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1387 to_timespec (timeout
, &cwaittime
);
1388 waittime
= &cwaittime
;
1391 if (!SCM_UNBNDP (owner
) && !scm_is_false (owner
))
1392 SCM_VALIDATE_THREAD (3, owner
);
1394 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1395 if (!scm_is_false (exception
))
1396 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1397 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1402 lock_mutex_return_void (SCM mx
)
1404 (void) scm_lock_mutex (mx
);
1408 unlock_mutex_return_void (SCM mx
)
1410 (void) scm_unlock_mutex (mx
);
1414 scm_dynwind_lock_mutex (SCM mutex
)
1416 scm_dynwind_unwind_handler_with_scm (unlock_mutex_return_void
, mutex
,
1417 SCM_F_WIND_EXPLICITLY
);
1418 scm_dynwind_rewind_handler_with_scm (lock_mutex_return_void
, mutex
,
1419 SCM_F_WIND_EXPLICITLY
);
1422 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1424 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1425 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1426 #define FUNC_NAME s_scm_try_mutex
1430 scm_t_timespec cwaittime
, *waittime
= NULL
;
1432 SCM_VALIDATE_MUTEX (1, mutex
);
1434 to_timespec (scm_from_int(0), &cwaittime
);
1435 waittime
= &cwaittime
;
1437 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1438 if (!scm_is_false (exception
))
1439 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1440 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1444 /*** Fat condition variables */
1447 scm_i_pthread_mutex_t lock
;
1448 SCM waiting
; /* the threads waiting for this condition. */
1451 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1452 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1455 remove_mutex_from_thread (SCM mutex
, scm_i_thread
*t
)
1459 for (prev
= SCM_BOOL_F
, walk
= t
->mutexes
; scm_is_pair (walk
);
1460 walk
= SCM_CDR (walk
))
1462 if (scm_is_eq (mutex
, scm_c_weak_vector_ref (SCM_CAR (walk
), 0)))
1464 if (scm_is_pair (prev
))
1465 SCM_SETCDR (prev
, SCM_CDR (walk
));
1467 t
->mutexes
= SCM_CDR (walk
);
1474 fat_mutex_unlock (SCM mutex
, SCM cond
,
1475 const scm_t_timespec
*waittime
, int relock
)
1478 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1480 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1481 int err
= 0, ret
= 0;
1483 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1487 if (!scm_is_eq (owner
, t
->handle
))
1491 if (!m
->unchecked_unlock
)
1493 scm_i_pthread_mutex_unlock (&m
->lock
);
1494 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1498 else if (!m
->allow_external_unlock
)
1500 scm_i_pthread_mutex_unlock (&m
->lock
);
1501 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1505 if (! (SCM_UNBNDP (cond
)))
1507 c
= SCM_CONDVAR_DATA (cond
);
1516 /* Change the owner of MUTEX. */
1517 remove_mutex_from_thread (mutex
, t
);
1518 m
->owner
= unblock_from_queue (m
->waiting
);
1523 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1524 scm_i_pthread_mutex_unlock (&m
->lock
);
1531 else if (err
== ETIMEDOUT
)
1536 else if (err
!= EINTR
)
1539 scm_syserror (NULL
);
1545 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1553 scm_remember_upto_here_2 (cond
, mutex
);
1555 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1564 /* Change the owner of MUTEX. */
1565 remove_mutex_from_thread (mutex
, t
);
1566 m
->owner
= unblock_from_queue (m
->waiting
);
1569 scm_i_pthread_mutex_unlock (&m
->lock
);
1576 SCM
scm_unlock_mutex (SCM mx
)
1578 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1581 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1582 (SCM mx
, SCM cond
, SCM timeout
),
1583 "Unlocks @var{mutex} if the calling thread owns the lock on "
1584 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1585 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1586 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1587 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1588 "with a call to @code{unlock-mutex}. Only the last call to "
1589 "@code{unlock-mutex} will actually unlock the mutex. ")
1590 #define FUNC_NAME s_scm_unlock_mutex_timed
1592 scm_t_timespec cwaittime
, *waittime
= NULL
;
1594 SCM_VALIDATE_MUTEX (1, mx
);
1595 if (! (SCM_UNBNDP (cond
)))
1597 SCM_VALIDATE_CONDVAR (2, cond
);
1599 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1601 to_timespec (timeout
, &cwaittime
);
1602 waittime
= &cwaittime
;
1606 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1610 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1612 "Return @code{#t} if @var{obj} is a mutex.")
1613 #define FUNC_NAME s_scm_mutex_p
1615 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1619 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1621 "Return the thread owning @var{mx}, or @code{#f}.")
1622 #define FUNC_NAME s_scm_mutex_owner
1625 fat_mutex
*m
= NULL
;
1627 SCM_VALIDATE_MUTEX (1, mx
);
1628 m
= SCM_MUTEX_DATA (mx
);
1629 scm_i_pthread_mutex_lock (&m
->lock
);
1631 scm_i_pthread_mutex_unlock (&m
->lock
);
1637 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1639 "Return the lock level of mutex @var{mx}.")
1640 #define FUNC_NAME s_scm_mutex_level
1642 SCM_VALIDATE_MUTEX (1, mx
);
1643 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1647 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1649 "Returns @code{#t} if the mutex @var{mx} is locked.")
1650 #define FUNC_NAME s_scm_mutex_locked_p
1652 SCM_VALIDATE_MUTEX (1, mx
);
1653 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1658 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1660 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1661 scm_puts_unlocked ("#<condition-variable ", port
);
1662 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1663 scm_puts_unlocked (">", port
);
1667 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1669 "Make a new condition variable.")
1670 #define FUNC_NAME s_scm_make_condition_variable
1675 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1676 c
->waiting
= SCM_EOL
;
1677 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1678 c
->waiting
= make_queue ();
1683 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1684 (SCM cv
, SCM mx
, SCM t
),
1685 "Wait until condition variable @var{cv} has been signalled. While waiting, "
1686 "mutex @var{mx} is atomically unlocked (as with @code{unlock-mutex}) and "
1687 "is locked again when this function returns. When @var{t} is given, "
1688 "it specifies a point in time where the waiting should be aborted. It "
1689 "can be either a integer as returned by @code{current-time} or a pair "
1690 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1691 "mutex is locked and @code{#f} is returned. When the condition "
1692 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1694 #define FUNC_NAME s_scm_timed_wait_condition_variable
1696 scm_t_timespec waittime
, *waitptr
= NULL
;
1698 SCM_VALIDATE_CONDVAR (1, cv
);
1699 SCM_VALIDATE_MUTEX (2, mx
);
1701 if (!SCM_UNBNDP (t
))
1703 to_timespec (t
, &waittime
);
1704 waitptr
= &waittime
;
1707 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1712 fat_cond_signal (fat_cond
*c
)
1714 unblock_from_queue (c
->waiting
);
1717 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1719 "Wake up one thread that is waiting for @var{cv}")
1720 #define FUNC_NAME s_scm_signal_condition_variable
1722 SCM_VALIDATE_CONDVAR (1, cv
);
1723 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1729 fat_cond_broadcast (fat_cond
*c
)
1731 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1735 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1737 "Wake up all threads that are waiting for @var{cv}. ")
1738 #define FUNC_NAME s_scm_broadcast_condition_variable
1740 SCM_VALIDATE_CONDVAR (1, cv
);
1741 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1746 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1748 "Return @code{#t} if @var{obj} is a condition variable.")
1749 #define FUNC_NAME s_scm_condition_variable_p
1751 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1765 struct timeval
*timeout
;
1772 do_std_select (void *args
)
1774 struct select_args
*select_args
;
1776 select_args
= (struct select_args
*) args
;
1778 select_args
->result
=
1779 select (select_args
->nfds
,
1780 select_args
->read_fds
, select_args
->write_fds
,
1781 select_args
->except_fds
, select_args
->timeout
);
1782 select_args
->errno_value
= errno
;
1788 scm_std_select (int nfds
,
1792 struct timeval
*timeout
)
1795 int res
, eno
, wakeup_fd
;
1796 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1797 struct select_args args
;
1799 if (readfds
== NULL
)
1801 FD_ZERO (&my_readfds
);
1802 readfds
= &my_readfds
;
1805 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1808 wakeup_fd
= t
->sleep_pipe
[0];
1809 FD_SET (wakeup_fd
, readfds
);
1810 if (wakeup_fd
>= nfds
)
1814 args
.read_fds
= readfds
;
1815 args
.write_fds
= writefds
;
1816 args
.except_fds
= exceptfds
;
1817 args
.timeout
= timeout
;
1819 /* Explicitly cooperate with the GC. */
1820 scm_without_guile (do_std_select
, &args
);
1823 eno
= args
.errno_value
;
1826 scm_i_reset_sleep (t
);
1828 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1831 full_read (wakeup_fd
, &dummy
, 1);
1833 FD_CLR (wakeup_fd
, readfds
);
1845 /* Convenience API for blocking while in guile mode. */
1847 #if SCM_USE_PTHREAD_THREADS
1849 /* It seems reasonable to not run procedures related to mutex and condition
1850 variables within `GC_do_blocking ()' since, (i) the GC can operate even
1851 without it, and (ii) the only potential gain would be GC latency. See
1852 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2245/focus=2251
1853 for a discussion of the pros and cons. */
1856 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1858 int res
= scm_i_pthread_mutex_lock (mutex
);
1863 do_unlock (void *data
)
1865 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1869 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1871 scm_i_scm_pthread_mutex_lock (mutex
);
1872 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1876 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1879 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1881 t
->held_mutex
= mutex
;
1882 res
= scm_i_pthread_cond_wait (cond
, mutex
);
1883 t
->held_mutex
= NULL
;
1889 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1890 scm_i_pthread_mutex_t
*mutex
,
1891 const scm_t_timespec
*wt
)
1894 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1896 t
->held_mutex
= mutex
;
1897 res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1898 t
->held_mutex
= NULL
;
1906 do_unlock_with_asyncs (void *data
)
1908 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1909 SCM_I_CURRENT_THREAD
->block_asyncs
--;
1913 scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t
*mutex
)
1915 SCM_I_CURRENT_THREAD
->block_asyncs
++;
1916 scm_i_scm_pthread_mutex_lock (mutex
);
1917 scm_dynwind_unwind_handler (do_unlock_with_asyncs
, mutex
,
1918 SCM_F_WIND_EXPLICITLY
);
1922 scm_std_usleep (unsigned long usecs
)
1925 tv
.tv_usec
= usecs
% 1000000;
1926 tv
.tv_sec
= usecs
/ 1000000;
1927 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1928 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1932 scm_std_sleep (unsigned int secs
)
1937 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1943 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1945 "Return the thread that called this function.")
1946 #define FUNC_NAME s_scm_current_thread
1948 return SCM_I_CURRENT_THREAD
->handle
;
1953 scm_c_make_list (size_t n
, SCM fill
)
1957 res
= scm_cons (fill
, res
);
1961 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1963 "Return a list of all threads.")
1964 #define FUNC_NAME s_scm_all_threads
1966 /* We can not allocate while holding the thread_admin_mutex because
1967 of the way GC is done.
1969 int n
= thread_count
;
1971 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1973 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1975 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1977 if (t
!= scm_i_signal_delivery_thread
)
1979 SCM_SETCAR (*l
, t
->handle
);
1980 l
= SCM_CDRLOC (*l
);
1985 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1990 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1992 "Return @code{#t} iff @var{thread} has exited.\n")
1993 #define FUNC_NAME s_scm_thread_exited_p
1995 return scm_from_bool (scm_c_thread_exited_p (thread
));
2000 scm_c_thread_exited_p (SCM thread
)
2001 #define FUNC_NAME s_scm_thread_exited_p
2004 SCM_VALIDATE_THREAD (1, thread
);
2005 t
= SCM_I_THREAD_DATA (thread
);
2010 SCM_DEFINE (scm_total_processor_count
, "total-processor-count", 0, 0, 0,
2012 "Return the total number of processors of the machine, which\n"
2013 "is guaranteed to be at least 1. A ``processor'' here is a\n"
2014 "thread execution unit, which can be either:\n\n"
2016 "@item an execution core in a (possibly multi-core) chip, in a\n"
2017 " (possibly multi- chip) module, in a single computer, or\n"
2018 "@item a thread execution unit inside a core in the case of\n"
2019 " @dfn{hyper-threaded} CPUs.\n"
2021 "Which of the two definitions is used, is unspecified.\n")
2022 #define FUNC_NAME s_scm_total_processor_count
2024 return scm_from_ulong (num_processors (NPROC_ALL
));
2028 SCM_DEFINE (scm_current_processor_count
, "current-processor-count", 0, 0, 0,
2030 "Like @code{total-processor-count}, but return the number of\n"
2031 "processors available to the current process. See\n"
2032 "@code{setaffinity} and @code{getaffinity} for more\n"
2034 #define FUNC_NAME s_scm_current_processor_count
2036 return scm_from_ulong (num_processors (NPROC_CURRENT
));
2043 static scm_i_pthread_cond_t wake_up_cond
;
2044 static int threads_initialized_p
= 0;
2047 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
2049 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
2051 static SCM dynwind_critical_section_mutex
;
2054 scm_dynwind_critical_section (SCM mutex
)
2056 if (scm_is_false (mutex
))
2057 mutex
= dynwind_critical_section_mutex
;
2058 scm_dynwind_lock_mutex (mutex
);
2059 scm_dynwind_block_asyncs ();
2062 /*** Initialization */
2064 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2066 #if SCM_USE_PTHREAD_THREADS
2067 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2071 scm_threads_prehistory (void *base
)
2073 #if SCM_USE_PTHREAD_THREADS
2074 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2075 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2076 PTHREAD_MUTEX_RECURSIVE
);
2079 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2080 scm_i_pthread_mutexattr_recursive
);
2081 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2082 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2085 GC_new_kind (GC_new_free_list (),
2086 GC_MAKE_PROC (GC_new_proc (thread_mark
), 0),
2089 guilify_self_1 ((struct GC_stack_base
*) base
);
2092 scm_t_bits scm_tc16_thread
;
2093 scm_t_bits scm_tc16_mutex
;
2094 scm_t_bits scm_tc16_condvar
;
2099 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2100 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2102 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2103 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2105 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2107 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2109 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2110 guilify_self_2 (SCM_BOOL_F
);
2111 threads_initialized_p
= 1;
2113 dynwind_critical_section_mutex
= scm_make_recursive_mutex ();
2117 scm_init_threads_default_dynamic_state ()
2119 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2120 scm_i_default_dynamic_state
= state
;
2124 scm_init_thread_procs ()
2126 #include "libguile/threads.x"
2130 /* IA64-specific things. */
2134 # include <sys/param.h>
2135 # include <sys/pstat.h>
2137 scm_ia64_register_backing_store_base (void)
2139 struct pst_vm_status vm_status
;
2141 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
2142 if (vm_status
.pst_type
== PS_RSESTACK
)
2143 return (void *) vm_status
.pst_vaddr
;
2147 scm_ia64_ar_bsp (const void *ctx
)
2150 __uc_get_ar_bsp (ctx
, &bsp
);
2151 return (void *) bsp
;
2155 # include <ucontext.h>
2157 scm_ia64_register_backing_store_base (void)
2159 extern void *__libc_ia64_register_backing_store_base
;
2160 return __libc_ia64_register_backing_store_base
;
2163 scm_ia64_ar_bsp (const void *opaque
)
2165 const ucontext_t
*ctx
= opaque
;
2166 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
2170 # include <ucontext.h>
2172 scm_ia64_register_backing_store_base (void)
2174 return (void *)0x8000000000000000;
2177 scm_ia64_ar_bsp (const void *opaque
)
2179 const ucontext_t
*ctx
= opaque
;
2180 return (void *)(ctx
->uc_mcontext
.mc_special
.bspstore
2181 + ctx
->uc_mcontext
.mc_special
.ndirty
);
2183 # endif /* __FreeBSD__ */
2184 #endif /* __ia64__ */