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 */
45 #include "libguile/validate.h"
46 #include "libguile/root.h"
47 #include "libguile/eval.h"
48 #include "libguile/async.h"
49 #include "libguile/ports.h"
50 #include "libguile/threads.h"
51 #include "libguile/dynwind.h"
52 #include "libguile/iselect.h"
53 #include "libguile/fluids.h"
54 #include "libguile/continuations.h"
55 #include "libguile/gc.h"
56 #include "libguile/init.h"
57 #include "libguile/scmsigs.h"
58 #include "libguile/strings.h"
60 #include <full-read.h>
65 /* First some libgc shims. */
67 /* Make sure GC_fn_type is defined; it is missing from the public
68 headers of GC 7.1 and earlier. */
69 #ifndef HAVE_GC_FN_TYPE
70 typedef void * (* GC_fn_type
) (void *);
78 #ifndef GC_UNIMPLEMENTED
79 #define GC_UNIMPLEMENTED 3
82 /* Likewise struct GC_stack_base is missing before 7.1. */
83 #ifndef HAVE_GC_STACK_BASE
84 struct GC_stack_base
{
85 void * mem_base
; /* Base of memory stack. */
87 void * reg_base
; /* Base of separate register stack. */
92 GC_register_my_thread (struct GC_stack_base
*stack_base
)
94 return GC_UNIMPLEMENTED
;
98 GC_unregister_my_thread ()
102 #if !SCM_USE_PTHREAD_THREADS
103 /* No threads; we can just use GC_stackbottom. */
105 get_thread_stack_base ()
107 return GC_stackbottom
;
110 #elif defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP \
111 && defined PTHREAD_ATTR_GETSTACK_WORKS
112 /* This method for GNU/Linux and perhaps some other systems.
113 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
114 available on them. */
116 get_thread_stack_base ()
122 pthread_getattr_np (pthread_self (), &attr
);
123 pthread_attr_getstack (&attr
, &start
, &size
);
124 end
= (char *)start
+ size
;
126 #if SCM_STACK_GROWS_UP
133 #elif defined HAVE_PTHREAD_GET_STACKADDR_NP
134 /* This method for MacOS X.
135 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
136 but as of 2006 there's nothing obvious at apple.com. */
138 get_thread_stack_base ()
140 return pthread_get_stackaddr_np (pthread_self ());
144 #error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl. Please upgrade to libgc >= 7.1.
148 GC_get_stack_base (struct GC_stack_base
*stack_base
)
150 stack_base
->mem_base
= get_thread_stack_base ();
152 /* Calculate and store off the base of this thread's register
153 backing store (RBS). Unfortunately our implementation(s) of
154 scm_ia64_register_backing_store_base are only reliable for the
155 main thread. For other threads, therefore, find out the current
156 top of the RBS, and use that as a maximum. */
157 stack_base
->reg_base
= scm_ia64_register_backing_store_base ();
162 bsp
= scm_ia64_ar_bsp (&ctx
);
163 if (stack_base
->reg_base
> bsp
)
164 stack_base
->reg_base
= bsp
;
171 GC_call_with_stack_base(void * (*fn
) (struct GC_stack_base
*, void*), void *arg
)
173 struct GC_stack_base stack_base
;
175 stack_base
.mem_base
= (void*)&stack_base
;
177 /* FIXME: Untested. */
181 stack_base
.reg_base
= scm_ia64_ar_bsp (&ctx
);
185 return fn (&stack_base
, arg
);
187 #endif /* HAVE_GC_STACK_BASE */
190 /* Now define with_gc_active and with_gc_inactive. */
192 #if (defined(HAVE_GC_DO_BLOCKING) && defined (HAVE_DECL_GC_DO_BLOCKING) && defined (HAVE_GC_CALL_WITH_GC_ACTIVE))
194 /* We have a sufficiently new libgc (7.2 or newer). */
197 with_gc_inactive (GC_fn_type func
, void *data
)
199 return GC_do_blocking (func
, data
);
203 with_gc_active (GC_fn_type func
, void *data
)
205 return GC_call_with_gc_active (func
, data
);
210 /* libgc not new enough, so never actually deactivate GC.
212 Note that though GC 7.1 does have a GC_do_blocking, it doesn't have
213 GC_call_with_gc_active. */
216 with_gc_inactive (GC_fn_type func
, void *data
)
222 with_gc_active (GC_fn_type func
, void *data
)
227 #endif /* HAVE_GC_DO_BLOCKING */
232 to_timespec (SCM t
, scm_t_timespec
*waittime
)
236 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
237 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
241 double time
= scm_to_double (t
);
242 double sec
= scm_c_truncate (time
);
244 waittime
->tv_sec
= (long) sec
;
245 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
252 /* Note: We annotate with "GC-robust" assignments whose purpose is to avoid
253 the risk of false references leading to unbounded retained space as
254 described in "Bounding Space Usage of Conservative Garbage Collectors",
257 /* Make an empty queue data structure.
262 return scm_cons (SCM_EOL
, SCM_EOL
);
265 /* Put T at the back of Q and return a handle that can be used with
266 remqueue to remove T from Q again.
269 enqueue (SCM q
, SCM t
)
271 SCM c
= scm_cons (t
, SCM_EOL
);
272 SCM_CRITICAL_SECTION_START
;
273 if (scm_is_null (SCM_CDR (q
)))
276 SCM_SETCDR (SCM_CAR (q
), c
);
278 SCM_CRITICAL_SECTION_END
;
282 /* Remove the element that the handle C refers to from the queue Q. C
283 must have been returned from a call to enqueue. The return value
284 is zero when the element referred to by C has already been removed.
285 Otherwise, 1 is returned.
288 remqueue (SCM q
, SCM c
)
291 SCM_CRITICAL_SECTION_START
;
292 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
294 if (scm_is_eq (p
, c
))
296 if (scm_is_eq (c
, SCM_CAR (q
)))
297 SCM_SETCAR (q
, SCM_CDR (c
));
298 SCM_SETCDR (prev
, SCM_CDR (c
));
301 SCM_SETCDR (c
, SCM_EOL
);
303 SCM_CRITICAL_SECTION_END
;
308 SCM_CRITICAL_SECTION_END
;
312 /* Remove the front-most element from the queue Q and return it.
313 Return SCM_BOOL_F when Q is empty.
319 SCM_CRITICAL_SECTION_START
;
323 SCM_CRITICAL_SECTION_END
;
328 SCM_SETCDR (q
, SCM_CDR (c
));
329 if (scm_is_null (SCM_CDR (q
)))
330 SCM_SETCAR (q
, SCM_EOL
);
331 SCM_CRITICAL_SECTION_END
;
334 SCM_SETCDR (c
, SCM_EOL
);
340 /*** Thread smob routines */
344 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
346 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
347 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
348 the struct case, hence we go via a union, and extract according to the
349 size of pthread_t. */
357 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
358 scm_i_pthread_t p
= t
->pthread
;
361 if (sizeof (p
) == sizeof (unsigned short))
363 else if (sizeof (p
) == sizeof (unsigned int))
365 else if (sizeof (p
) == sizeof (unsigned long))
370 scm_puts_unlocked ("#<thread ", port
);
371 scm_uintprint (id
, 10, port
);
372 scm_puts_unlocked (" (", port
);
373 scm_uintprint ((scm_t_bits
)t
, 16, port
);
374 scm_puts_unlocked (")>", port
);
379 /*** Blocking on queues. */
381 /* See also scm_i_queue_async_cell for how such a block is
385 /* Put the current thread on QUEUE and go to sleep, waiting for it to
386 be woken up by a call to 'unblock_from_queue', or to be
387 interrupted. Upon return of this function, the current thread is
388 no longer on QUEUE, even when the sleep has been interrupted.
390 The caller of block_self must hold MUTEX. It will be atomically
391 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
393 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
396 When WAITTIME is not NULL, the sleep will be aborted at that time.
398 The return value of block_self is an errno value. It will be zero
399 when the sleep has been successfully completed by a call to
400 unblock_from_queue, EINTR when it has been interrupted by the
401 delivery of a system async, and ETIMEDOUT when the timeout has
404 The system asyncs themselves are not executed by block_self.
407 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
408 const scm_t_timespec
*waittime
)
410 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
414 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
419 q_handle
= enqueue (queue
, t
->handle
);
420 if (waittime
== NULL
)
421 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
423 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
425 /* When we are still on QUEUE, we have been interrupted. We
426 report this only when no other error (such as a timeout) has
429 if (remqueue (queue
, q_handle
) && err
== 0)
432 scm_i_reset_sleep (t
);
438 /* Wake up the first thread on QUEUE, if any. The awoken thread is
439 returned, or #f if the queue was empty.
442 unblock_from_queue (SCM queue
)
444 SCM thread
= dequeue (queue
);
445 if (scm_is_true (thread
))
446 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
451 /* Getting into and out of guile mode.
454 /* Key used to attach a cleanup handler to a given thread. Also, if
455 thread-local storage is unavailable, this key is used to retrieve the
456 current thread with `pthread_getspecific ()'. */
457 scm_i_pthread_key_t scm_i_thread_key
;
460 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
462 /* When thread-local storage (TLS) is available, a pointer to the
463 current-thread object is kept in TLS. Note that storing the thread-object
464 itself in TLS (rather than a pointer to some malloc'd memory) is not
465 possible since thread objects may live longer than the actual thread they
467 SCM_THREAD_LOCAL scm_i_thread
*scm_i_current_thread
= NULL
;
469 #endif /* SCM_HAVE_THREAD_STORAGE_CLASS */
472 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
473 static scm_i_thread
*all_threads
= NULL
;
474 static int thread_count
;
476 static SCM scm_i_default_dynamic_state
;
478 /* Run when a fluid is collected. */
480 scm_i_reset_fluid (size_t n
)
484 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
485 for (t
= all_threads
; t
; t
= t
->next_thread
)
486 if (SCM_I_DYNAMIC_STATE_P (t
->dynamic_state
))
488 SCM v
= SCM_I_DYNAMIC_STATE_FLUIDS (t
->dynamic_state
);
490 if (n
< SCM_SIMPLE_VECTOR_LENGTH (v
))
491 SCM_SIMPLE_VECTOR_SET (v
, n
, SCM_UNDEFINED
);
493 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
496 /* Perform first stage of thread initialisation, in non-guile mode.
499 guilify_self_1 (struct GC_stack_base
*base
)
503 /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value
504 before allocating anything in this thread, because allocation could
505 cause GC to run, and GC could cause finalizers, which could invoke
506 Scheme functions, which need the current thread to be set. */
508 t
.pthread
= scm_i_pthread_self ();
509 t
.handle
= SCM_BOOL_F
;
510 t
.result
= SCM_BOOL_F
;
511 t
.cleanup_handler
= SCM_BOOL_F
;
514 t
.join_queue
= SCM_EOL
;
515 t
.dynamic_state
= SCM_BOOL_F
;
516 t
.dynwinds
= SCM_EOL
;
517 t
.active_asyncs
= SCM_EOL
;
519 t
.pending_asyncs
= 1;
520 t
.critical_section_level
= 0;
521 t
.base
= base
->mem_base
;
523 t
.register_backing_store_base
= base
->reg
-base
;
525 t
.continuation_root
= SCM_EOL
;
526 t
.continuation_base
= t
.base
;
527 scm_i_pthread_cond_init (&t
.sleep_cond
, NULL
);
528 t
.sleep_mutex
= NULL
;
529 t
.sleep_object
= SCM_BOOL_F
;
532 if (pipe2 (t
.sleep_pipe
, O_CLOEXEC
) != 0)
533 /* FIXME: Error conditions during the initialization phase are handled
534 gracelessly since public functions such as `scm_init_guile ()'
535 currently have type `void'. */
538 scm_i_pthread_mutex_init (&t
.admin_mutex
, NULL
);
539 t
.current_mark_stack_ptr
= NULL
;
540 t
.current_mark_stack_limit
= NULL
;
545 /* The switcheroo. */
547 scm_i_thread
*t_ptr
= &t
;
550 t_ptr
= GC_malloc (sizeof (scm_i_thread
));
551 memcpy (t_ptr
, &t
, sizeof t
);
553 scm_i_pthread_setspecific (scm_i_thread_key
, t_ptr
);
555 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
556 /* Cache the current thread in TLS for faster lookup. */
557 scm_i_current_thread
= t_ptr
;
560 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
561 t_ptr
->next_thread
= all_threads
;
564 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
570 /* Perform second stage of thread initialisation, in guile mode.
573 guilify_self_2 (SCM parent
)
575 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
579 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
581 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
582 t
->continuation_base
= t
->base
;
585 if (scm_is_true (parent
))
586 t
->dynamic_state
= scm_make_dynamic_state (parent
);
588 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
590 t
->join_queue
= make_queue ();
597 /* We implement our own mutex type since we want them to be 'fair', we
598 want to do fancy things while waiting for them (like running
599 asyncs) and we might want to add things that are nice for
604 scm_i_pthread_mutex_t lock
;
606 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
608 int recursive
; /* allow recursive locking? */
609 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
610 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
611 owned by the current thread? */
613 SCM waiting
; /* the threads waiting for this mutex. */
616 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
617 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
620 call_cleanup (void *data
)
623 return scm_call_0 (*proc_p
);
626 /* Perform thread tear-down, in guile mode.
629 do_thread_exit (void *v
)
631 scm_i_thread
*t
= (scm_i_thread
*) v
;
633 if (!scm_is_false (t
->cleanup_handler
))
635 SCM ptr
= t
->cleanup_handler
;
637 t
->cleanup_handler
= SCM_BOOL_F
;
638 t
->result
= scm_internal_catch (SCM_BOOL_T
,
640 scm_handle_by_message_noexit
, NULL
);
643 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
646 close (t
->sleep_pipe
[0]);
647 close (t
->sleep_pipe
[1]);
648 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
651 while (!scm_is_null (t
->mutexes
))
653 SCM mutex
= scm_c_weak_vector_ref (scm_car (t
->mutexes
), 0);
655 if (scm_is_true (mutex
))
657 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
659 scm_i_pthread_mutex_lock (&m
->lock
);
661 /* Since MUTEX is in `t->mutexes', T must be its owner. */
662 assert (scm_is_eq (m
->owner
, t
->handle
));
664 unblock_from_queue (m
->waiting
);
666 scm_i_pthread_mutex_unlock (&m
->lock
);
669 t
->mutexes
= scm_cdr (t
->mutexes
);
672 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
678 do_thread_exit_trampoline (struct GC_stack_base
*sb
, void *v
)
680 /* Won't hurt if we are already registered. */
681 #if SCM_USE_PTHREAD_THREADS
682 GC_register_my_thread (sb
);
685 return scm_with_guile (do_thread_exit
, v
);
689 on_thread_exit (void *v
)
691 /* This handler is executed in non-guile mode. */
692 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
694 /* If we were canceled, we were unable to clear `t->guile_mode', so do
698 /* If this thread was cancelled while doing a cond wait, it will
699 still have a mutex locked, so we unlock it here. */
702 scm_i_pthread_mutex_unlock (t
->held_mutex
);
703 t
->held_mutex
= NULL
;
706 /* Reinstate the current thread for purposes of scm_with_guile
707 guile-mode cleanup handlers. Only really needed in the non-TLS
708 case but it doesn't hurt to be consistent. */
709 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
711 /* Scheme-level thread finalizers and other cleanup needs to happen in
713 GC_call_with_stack_base (do_thread_exit_trampoline
, t
);
715 /* Removing ourself from the list of all threads needs to happen in
716 non-guile mode since all SCM values on our stack become
717 unprotected once we are no longer in the list. */
718 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
719 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
722 *tp
= t
->next_thread
;
725 t
->next_thread
= NULL
;
731 /* If there's only one other thread, it could be the signal delivery
732 thread, so we need to notify it to shut down by closing its read pipe.
733 If it's not the signal delivery thread, then closing the read pipe isn't
735 if (thread_count
<= 1)
736 scm_i_close_signal_pipe ();
738 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
740 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
742 #if SCM_USE_PTHREAD_THREADS
743 GC_unregister_my_thread ();
747 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
750 init_thread_key (void)
752 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
755 /* Perform any initializations necessary to make the current thread
756 known to Guile (via SCM_I_CURRENT_THREAD), initializing Guile itself,
759 BASE is the stack base to use with GC.
761 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
762 which case the default dynamic state is used.
764 Returns zero when the thread was known to guile already; otherwise
767 Note that it could be the case that the thread was known
768 to Guile, but not in guile mode (because we are within a
769 scm_without_guile call). Check SCM_I_CURRENT_THREAD->guile_mode to
770 be sure. New threads are put into guile mode implicitly. */
773 scm_i_init_thread_for_guile (struct GC_stack_base
*base
, SCM parent
)
775 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
777 if (SCM_I_CURRENT_THREAD
)
779 /* Thread is already known to Guile.
785 /* This thread has not been guilified yet.
788 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
789 if (scm_initialized_p
== 0)
791 /* First thread ever to enter Guile. Run the full
794 scm_i_init_guile (base
);
796 #if defined (HAVE_GC_ALLOW_REGISTER_THREADS) && SCM_USE_PTHREAD_THREADS
797 /* Allow other threads to come in later. */
798 GC_allow_register_threads ();
801 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
805 /* Guile is already initialized, but this thread enters it for
806 the first time. Only initialize this thread.
808 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
810 /* Register this thread with libgc. */
811 #if SCM_USE_PTHREAD_THREADS
812 GC_register_my_thread (base
);
815 guilify_self_1 (base
);
816 guilify_self_2 (parent
);
825 struct GC_stack_base stack_base
;
827 if (GC_get_stack_base (&stack_base
) == GC_SUCCESS
)
828 scm_i_init_thread_for_guile (&stack_base
,
829 scm_i_default_dynamic_state
);
832 fprintf (stderr
, "Failed to get stack base for current thread.\n");
837 struct with_guile_args
845 with_guile_trampoline (void *data
)
847 struct with_guile_args
*args
= data
;
849 return scm_c_with_continuation_barrier (args
->func
, args
->data
);
853 with_guile_and_parent (struct GC_stack_base
*base
, void *data
)
858 struct with_guile_args
*args
= data
;
860 new_thread
= scm_i_init_thread_for_guile (base
, args
->parent
);
861 t
= SCM_I_CURRENT_THREAD
;
864 /* We are in Guile mode. */
865 assert (t
->guile_mode
);
867 res
= scm_c_with_continuation_barrier (args
->func
, args
->data
);
869 /* Leave Guile mode. */
872 else if (t
->guile_mode
)
874 /* Already in Guile mode. */
875 res
= scm_c_with_continuation_barrier (args
->func
, args
->data
);
879 /* We are not in Guile mode, either because we are not within a
880 scm_with_guile, or because we are within a scm_without_guile.
882 This call to scm_with_guile() could happen from anywhere on the
883 stack, and in particular lower on the stack than when it was
884 when this thread was first guilified. Thus, `base' must be
886 #if SCM_STACK_GROWS_UP
887 if (SCM_STACK_PTR (base
->mem_base
) < t
->base
)
888 t
->base
= SCM_STACK_PTR (base
->mem_base
);
890 if (SCM_STACK_PTR (base
->mem_base
) > t
->base
)
891 t
->base
= SCM_STACK_PTR (base
->mem_base
);
895 res
= with_gc_active (with_guile_trampoline
, args
);
902 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
904 struct with_guile_args args
;
908 args
.parent
= parent
;
910 return GC_call_with_stack_base (with_guile_and_parent
, &args
);
914 scm_with_guile (void *(*func
)(void *), void *data
)
916 return scm_i_with_guile_and_parent (func
, data
,
917 scm_i_default_dynamic_state
);
921 scm_without_guile (void *(*func
)(void *), void *data
)
924 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
928 SCM_I_CURRENT_THREAD
->guile_mode
= 0;
929 result
= with_gc_inactive (func
, data
);
930 SCM_I_CURRENT_THREAD
->guile_mode
= 1;
933 /* Otherwise we're not in guile mode, so nothing to do. */
934 result
= func (data
);
940 /*** Thread creation */
947 scm_i_pthread_mutex_t mutex
;
948 scm_i_pthread_cond_t cond
;
952 really_launch (void *d
)
954 launch_data
*data
= (launch_data
*)d
;
955 SCM thunk
= data
->thunk
, handler
= data
->handler
;
958 t
= SCM_I_CURRENT_THREAD
;
960 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
961 data
->thread
= scm_current_thread ();
962 scm_i_pthread_cond_signal (&data
->cond
);
963 scm_i_pthread_mutex_unlock (&data
->mutex
);
965 if (SCM_UNBNDP (handler
))
966 t
->result
= scm_call_0 (thunk
);
968 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
974 launch_thread (void *d
)
976 launch_data
*data
= (launch_data
*)d
;
977 scm_i_pthread_detach (scm_i_pthread_self ());
978 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
982 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
983 (SCM thunk
, SCM handler
),
984 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
985 "returning a new thread object representing the thread. The procedure\n"
986 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
988 "When @var{handler} is specified, then @var{thunk} is called from\n"
989 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
990 "handler. This catch is established inside the continuation barrier.\n"
992 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
993 "the @emph{exit value} of the thread and the thread is terminated.")
994 #define FUNC_NAME s_scm_call_with_new_thread
1000 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
1001 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
1002 handler
, SCM_ARG2
, FUNC_NAME
);
1004 GC_collect_a_little ();
1005 data
.parent
= scm_current_dynamic_state ();
1007 data
.handler
= handler
;
1008 data
.thread
= SCM_BOOL_F
;
1009 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1010 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1012 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1013 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
1016 scm_i_pthread_mutex_unlock (&data
.mutex
);
1018 scm_syserror (NULL
);
1020 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1021 scm_i_pthread_mutex_unlock (&data
.mutex
);
1029 scm_t_catch_body body
;
1031 scm_t_catch_handler handler
;
1034 scm_i_pthread_mutex_t mutex
;
1035 scm_i_pthread_cond_t cond
;
1039 really_spawn (void *d
)
1041 spawn_data
*data
= (spawn_data
*)d
;
1042 scm_t_catch_body body
= data
->body
;
1043 void *body_data
= data
->body_data
;
1044 scm_t_catch_handler handler
= data
->handler
;
1045 void *handler_data
= data
->handler_data
;
1046 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1048 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
1049 data
->thread
= scm_current_thread ();
1050 scm_i_pthread_cond_signal (&data
->cond
);
1051 scm_i_pthread_mutex_unlock (&data
->mutex
);
1053 if (handler
== NULL
)
1054 t
->result
= body (body_data
);
1056 t
->result
= scm_internal_catch (SCM_BOOL_T
,
1058 handler
, handler_data
);
1064 spawn_thread (void *d
)
1066 spawn_data
*data
= (spawn_data
*)d
;
1067 scm_i_pthread_detach (scm_i_pthread_self ());
1068 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
1073 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1074 scm_t_catch_handler handler
, void *handler_data
)
1080 data
.parent
= scm_current_dynamic_state ();
1082 data
.body_data
= body_data
;
1083 data
.handler
= handler
;
1084 data
.handler_data
= handler_data
;
1085 data
.thread
= SCM_BOOL_F
;
1086 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1087 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1089 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1090 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1093 scm_i_pthread_mutex_unlock (&data
.mutex
);
1095 scm_syserror (NULL
);
1097 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1098 scm_i_pthread_mutex_unlock (&data
.mutex
);
1103 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1105 "Move the calling thread to the end of the scheduling queue.")
1106 #define FUNC_NAME s_scm_yield
1108 return scm_from_bool (scm_i_sched_yield ());
1112 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1114 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1115 "cannot be the current thread, and if @var{thread} has already terminated or "
1116 "been signaled to terminate, this function is a no-op.")
1117 #define FUNC_NAME s_scm_cancel_thread
1119 scm_i_thread
*t
= NULL
;
1121 SCM_VALIDATE_THREAD (1, thread
);
1122 t
= SCM_I_THREAD_DATA (thread
);
1123 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1127 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1128 scm_i_pthread_cancel (t
->pthread
);
1131 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1133 return SCM_UNSPECIFIED
;
1137 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1138 (SCM thread
, SCM proc
),
1139 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1140 "This handler will be called when the thread exits.")
1141 #define FUNC_NAME s_scm_set_thread_cleanup_x
1145 SCM_VALIDATE_THREAD (1, thread
);
1146 if (!scm_is_false (proc
))
1147 SCM_VALIDATE_THUNK (2, proc
);
1149 t
= SCM_I_THREAD_DATA (thread
);
1150 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1152 if (!(t
->exited
|| t
->canceled
))
1153 t
->cleanup_handler
= proc
;
1155 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1157 return SCM_UNSPECIFIED
;
1161 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1163 "Return the cleanup handler installed for the thread @var{thread}.")
1164 #define FUNC_NAME s_scm_thread_cleanup
1169 SCM_VALIDATE_THREAD (1, thread
);
1171 t
= SCM_I_THREAD_DATA (thread
);
1172 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1173 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1174 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1180 SCM
scm_join_thread (SCM thread
)
1182 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1185 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1186 (SCM thread
, SCM timeout
, SCM timeoutval
),
1187 "Suspend execution of the calling thread until the target @var{thread} "
1188 "terminates, unless the target @var{thread} has already terminated. ")
1189 #define FUNC_NAME s_scm_join_thread_timed
1192 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1193 SCM res
= SCM_BOOL_F
;
1195 if (! (SCM_UNBNDP (timeoutval
)))
1198 SCM_VALIDATE_THREAD (1, thread
);
1199 if (scm_is_eq (scm_current_thread (), thread
))
1200 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1202 t
= SCM_I_THREAD_DATA (thread
);
1203 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1205 if (! SCM_UNBNDP (timeout
))
1207 to_timespec (timeout
, &ctimeout
);
1208 timeout_ptr
= &ctimeout
;
1217 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1227 else if (err
== ETIMEDOUT
)
1230 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1232 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1234 /* Check for exit again, since we just released and
1235 reacquired the admin mutex, before the next block_self
1236 call (which would block forever if t has already
1246 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1252 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1254 "Return @code{#t} if @var{obj} is a thread.")
1255 #define FUNC_NAME s_scm_thread_p
1257 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1263 fat_mutex_free (SCM mx
)
1265 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1266 scm_i_pthread_mutex_destroy (&m
->lock
);
1271 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1273 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1274 scm_puts_unlocked ("#<mutex ", port
);
1275 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1276 scm_puts_unlocked (">", port
);
1281 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1286 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1287 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1288 m
->owner
= SCM_BOOL_F
;
1291 m
->recursive
= recursive
;
1292 m
->unchecked_unlock
= unchecked_unlock
;
1293 m
->allow_external_unlock
= external_unlock
;
1295 m
->waiting
= SCM_EOL
;
1296 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1297 m
->waiting
= make_queue ();
1301 SCM
scm_make_mutex (void)
1303 return scm_make_mutex_with_flags (SCM_EOL
);
1306 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1307 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1308 SCM_SYMBOL (recursive_sym
, "recursive");
1310 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1312 "Create a new mutex. ")
1313 #define FUNC_NAME s_scm_make_mutex_with_flags
1315 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1318 while (! scm_is_null (ptr
))
1320 SCM flag
= SCM_CAR (ptr
);
1321 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1322 unchecked_unlock
= 1;
1323 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1324 external_unlock
= 1;
1325 else if (scm_is_eq (flag
, recursive_sym
))
1328 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1329 ptr
= SCM_CDR (ptr
);
1331 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1335 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1337 "Create a new recursive mutex. ")
1338 #define FUNC_NAME s_scm_make_recursive_mutex
1340 return make_fat_mutex (1, 0, 0);
1344 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1347 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1349 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1351 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1352 SCM err
= SCM_BOOL_F
;
1354 struct timeval current_time
;
1356 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1362 m
->owner
= new_owner
;
1365 if (SCM_I_IS_THREAD (new_owner
))
1367 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1369 /* FIXME: The order in which `t->admin_mutex' and
1370 `m->lock' are taken differs from that in
1371 `on_thread_exit', potentially leading to deadlocks. */
1372 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1374 /* Only keep a weak reference to MUTEX so that it's not
1375 retained when not referenced elsewhere (bug #27450).
1376 The weak pair itself is eventually removed when MUTEX
1377 is unlocked. Note that `t->mutexes' lists mutexes
1378 currently held by T, so it should be small. */
1379 t
->mutexes
= scm_cons (scm_make_weak_vector (SCM_INUM1
, mutex
),
1382 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1387 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1389 m
->owner
= new_owner
;
1390 err
= scm_cons (scm_abandoned_mutex_error_key
,
1391 scm_from_locale_string ("lock obtained on abandoned "
1396 else if (scm_is_eq (m
->owner
, new_owner
))
1405 err
= scm_cons (scm_misc_error_key
,
1406 scm_from_locale_string ("mutex already locked "
1414 if (timeout
!= NULL
)
1416 gettimeofday (¤t_time
, NULL
);
1417 if (current_time
.tv_sec
> timeout
->tv_sec
||
1418 (current_time
.tv_sec
== timeout
->tv_sec
&&
1419 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1425 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1426 scm_i_pthread_mutex_unlock (&m
->lock
);
1428 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1431 scm_i_pthread_mutex_unlock (&m
->lock
);
1435 SCM
scm_lock_mutex (SCM mx
)
1437 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1440 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1441 (SCM m
, SCM timeout
, SCM owner
),
1442 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1443 "blocks until the mutex becomes available. The function returns when "
1444 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1445 "a thread already owns will succeed right away and will not block the "
1446 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1447 #define FUNC_NAME s_scm_lock_mutex_timed
1451 scm_t_timespec cwaittime
, *waittime
= NULL
;
1453 SCM_VALIDATE_MUTEX (1, m
);
1455 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1457 to_timespec (timeout
, &cwaittime
);
1458 waittime
= &cwaittime
;
1461 if (!SCM_UNBNDP (owner
) && !scm_is_false (owner
))
1462 SCM_VALIDATE_THREAD (3, owner
);
1464 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1465 if (!scm_is_false (exception
))
1466 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1467 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1472 lock_mutex_return_void (SCM mx
)
1474 (void) scm_lock_mutex (mx
);
1478 unlock_mutex_return_void (SCM mx
)
1480 (void) scm_unlock_mutex (mx
);
1484 scm_dynwind_lock_mutex (SCM mutex
)
1486 scm_dynwind_unwind_handler_with_scm (unlock_mutex_return_void
, mutex
,
1487 SCM_F_WIND_EXPLICITLY
);
1488 scm_dynwind_rewind_handler_with_scm (lock_mutex_return_void
, mutex
,
1489 SCM_F_WIND_EXPLICITLY
);
1492 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1494 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1495 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1496 #define FUNC_NAME s_scm_try_mutex
1500 scm_t_timespec cwaittime
, *waittime
= NULL
;
1502 SCM_VALIDATE_MUTEX (1, mutex
);
1504 to_timespec (scm_from_int(0), &cwaittime
);
1505 waittime
= &cwaittime
;
1507 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1508 if (!scm_is_false (exception
))
1509 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1510 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1514 /*** Fat condition variables */
1517 scm_i_pthread_mutex_t lock
;
1518 SCM waiting
; /* the threads waiting for this condition. */
1521 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1522 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1525 remove_mutex_from_thread (SCM mutex
, scm_i_thread
*t
)
1529 for (prev
= SCM_BOOL_F
, walk
= t
->mutexes
; scm_is_pair (walk
);
1530 walk
= SCM_CDR (walk
))
1532 if (scm_is_eq (mutex
, scm_c_weak_vector_ref (SCM_CAR (walk
), 0)))
1534 if (scm_is_pair (prev
))
1535 SCM_SETCDR (prev
, SCM_CDR (walk
));
1537 t
->mutexes
= SCM_CDR (walk
);
1544 fat_mutex_unlock (SCM mutex
, SCM cond
,
1545 const scm_t_timespec
*waittime
, int relock
)
1548 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1550 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1551 int err
= 0, ret
= 0;
1553 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1557 if (!scm_is_eq (owner
, t
->handle
))
1561 if (!m
->unchecked_unlock
)
1563 scm_i_pthread_mutex_unlock (&m
->lock
);
1564 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1568 else if (!m
->allow_external_unlock
)
1570 scm_i_pthread_mutex_unlock (&m
->lock
);
1571 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1575 if (! (SCM_UNBNDP (cond
)))
1577 c
= SCM_CONDVAR_DATA (cond
);
1586 /* Change the owner of MUTEX. */
1587 remove_mutex_from_thread (mutex
, t
);
1588 m
->owner
= unblock_from_queue (m
->waiting
);
1593 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1594 scm_i_pthread_mutex_unlock (&m
->lock
);
1601 else if (err
== ETIMEDOUT
)
1606 else if (err
!= EINTR
)
1609 scm_syserror (NULL
);
1615 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1623 scm_remember_upto_here_2 (cond
, mutex
);
1625 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1634 /* Change the owner of MUTEX. */
1635 remove_mutex_from_thread (mutex
, t
);
1636 m
->owner
= unblock_from_queue (m
->waiting
);
1639 scm_i_pthread_mutex_unlock (&m
->lock
);
1646 SCM
scm_unlock_mutex (SCM mx
)
1648 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1651 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1652 (SCM mx
, SCM cond
, SCM timeout
),
1653 "Unlocks @var{mutex} if the calling thread owns the lock on "
1654 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1655 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1656 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1657 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1658 "with a call to @code{unlock-mutex}. Only the last call to "
1659 "@code{unlock-mutex} will actually unlock the mutex. ")
1660 #define FUNC_NAME s_scm_unlock_mutex_timed
1662 scm_t_timespec cwaittime
, *waittime
= NULL
;
1664 SCM_VALIDATE_MUTEX (1, mx
);
1665 if (! (SCM_UNBNDP (cond
)))
1667 SCM_VALIDATE_CONDVAR (2, cond
);
1669 if (! (SCM_UNBNDP (timeout
)))
1671 to_timespec (timeout
, &cwaittime
);
1672 waittime
= &cwaittime
;
1676 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1680 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1682 "Return @code{#t} if @var{obj} is a mutex.")
1683 #define FUNC_NAME s_scm_mutex_p
1685 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1689 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1691 "Return the thread owning @var{mx}, or @code{#f}.")
1692 #define FUNC_NAME s_scm_mutex_owner
1695 fat_mutex
*m
= NULL
;
1697 SCM_VALIDATE_MUTEX (1, mx
);
1698 m
= SCM_MUTEX_DATA (mx
);
1699 scm_i_pthread_mutex_lock (&m
->lock
);
1701 scm_i_pthread_mutex_unlock (&m
->lock
);
1707 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1709 "Return the lock level of mutex @var{mx}.")
1710 #define FUNC_NAME s_scm_mutex_level
1712 SCM_VALIDATE_MUTEX (1, mx
);
1713 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1717 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1719 "Returns @code{#t} if the mutex @var{mx} is locked.")
1720 #define FUNC_NAME s_scm_mutex_locked_p
1722 SCM_VALIDATE_MUTEX (1, mx
);
1723 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1728 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1730 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1731 scm_puts_unlocked ("#<condition-variable ", port
);
1732 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1733 scm_puts_unlocked (">", port
);
1737 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1739 "Make a new condition variable.")
1740 #define FUNC_NAME s_scm_make_condition_variable
1745 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1746 c
->waiting
= SCM_EOL
;
1747 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1748 c
->waiting
= make_queue ();
1753 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1754 (SCM cv
, SCM mx
, SCM t
),
1755 "Wait until @var{cond-var} has been signalled. While waiting, "
1756 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1757 "is locked again when this function returns. When @var{time} is given, "
1758 "it specifies a point in time where the waiting should be aborted. It "
1759 "can be either a integer as returned by @code{current-time} or a pair "
1760 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1761 "mutex is locked and @code{#f} is returned. When the condition "
1762 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1764 #define FUNC_NAME s_scm_timed_wait_condition_variable
1766 scm_t_timespec waittime
, *waitptr
= NULL
;
1768 SCM_VALIDATE_CONDVAR (1, cv
);
1769 SCM_VALIDATE_MUTEX (2, mx
);
1771 if (!SCM_UNBNDP (t
))
1773 to_timespec (t
, &waittime
);
1774 waitptr
= &waittime
;
1777 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1782 fat_cond_signal (fat_cond
*c
)
1784 unblock_from_queue (c
->waiting
);
1787 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1789 "Wake up one thread that is waiting for @var{cv}")
1790 #define FUNC_NAME s_scm_signal_condition_variable
1792 SCM_VALIDATE_CONDVAR (1, cv
);
1793 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1799 fat_cond_broadcast (fat_cond
*c
)
1801 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1805 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1807 "Wake up all threads that are waiting for @var{cv}. ")
1808 #define FUNC_NAME s_scm_broadcast_condition_variable
1810 SCM_VALIDATE_CONDVAR (1, cv
);
1811 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1816 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1818 "Return @code{#t} if @var{obj} is a condition variable.")
1819 #define FUNC_NAME s_scm_condition_variable_p
1821 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1832 SELECT_TYPE
*read_fds
;
1833 SELECT_TYPE
*write_fds
;
1834 SELECT_TYPE
*except_fds
;
1835 struct timeval
*timeout
;
1842 do_std_select (void *args
)
1844 struct select_args
*select_args
;
1846 select_args
= (struct select_args
*) args
;
1848 select_args
->result
=
1849 select (select_args
->nfds
,
1850 select_args
->read_fds
, select_args
->write_fds
,
1851 select_args
->except_fds
, select_args
->timeout
);
1852 select_args
->errno_value
= errno
;
1858 scm_std_select (int nfds
,
1859 SELECT_TYPE
*readfds
,
1860 SELECT_TYPE
*writefds
,
1861 SELECT_TYPE
*exceptfds
,
1862 struct timeval
*timeout
)
1865 int res
, eno
, wakeup_fd
;
1866 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1867 struct select_args args
;
1869 if (readfds
== NULL
)
1871 FD_ZERO (&my_readfds
);
1872 readfds
= &my_readfds
;
1875 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1878 wakeup_fd
= t
->sleep_pipe
[0];
1879 FD_SET (wakeup_fd
, readfds
);
1880 if (wakeup_fd
>= nfds
)
1884 args
.read_fds
= readfds
;
1885 args
.write_fds
= writefds
;
1886 args
.except_fds
= exceptfds
;
1887 args
.timeout
= timeout
;
1889 /* Explicitly cooperate with the GC. */
1890 scm_without_guile (do_std_select
, &args
);
1893 eno
= args
.errno_value
;
1896 scm_i_reset_sleep (t
);
1898 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1901 full_read (wakeup_fd
, &dummy
, 1);
1903 FD_CLR (wakeup_fd
, readfds
);
1915 /* Convenience API for blocking while in guile mode. */
1917 #if SCM_USE_PTHREAD_THREADS
1919 /* It seems reasonable to not run procedures related to mutex and condition
1920 variables within `GC_do_blocking ()' since, (i) the GC can operate even
1921 without it, and (ii) the only potential gain would be GC latency. See
1922 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2245/focus=2251
1923 for a discussion of the pros and cons. */
1926 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1928 int res
= scm_i_pthread_mutex_lock (mutex
);
1933 do_unlock (void *data
)
1935 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1939 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1941 scm_i_scm_pthread_mutex_lock (mutex
);
1942 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1946 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1949 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1951 t
->held_mutex
= mutex
;
1952 res
= scm_i_pthread_cond_wait (cond
, mutex
);
1953 t
->held_mutex
= NULL
;
1959 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1960 scm_i_pthread_mutex_t
*mutex
,
1961 const scm_t_timespec
*wt
)
1964 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1966 t
->held_mutex
= mutex
;
1967 res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1968 t
->held_mutex
= NULL
;
1976 scm_std_usleep (unsigned long usecs
)
1979 tv
.tv_usec
= usecs
% 1000000;
1980 tv
.tv_sec
= usecs
/ 1000000;
1981 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1982 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1986 scm_std_sleep (unsigned int secs
)
1991 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1997 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1999 "Return the thread that called this function.")
2000 #define FUNC_NAME s_scm_current_thread
2002 return SCM_I_CURRENT_THREAD
->handle
;
2007 scm_c_make_list (size_t n
, SCM fill
)
2011 res
= scm_cons (fill
, res
);
2015 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
2017 "Return a list of all threads.")
2018 #define FUNC_NAME s_scm_all_threads
2020 /* We can not allocate while holding the thread_admin_mutex because
2021 of the way GC is done.
2023 int n
= thread_count
;
2025 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
2027 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
2029 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
2031 if (t
!= scm_i_signal_delivery_thread
)
2033 SCM_SETCAR (*l
, t
->handle
);
2034 l
= SCM_CDRLOC (*l
);
2039 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
2044 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
2046 "Return @code{#t} iff @var{thread} has exited.\n")
2047 #define FUNC_NAME s_scm_thread_exited_p
2049 return scm_from_bool (scm_c_thread_exited_p (thread
));
2054 scm_c_thread_exited_p (SCM thread
)
2055 #define FUNC_NAME s_scm_thread_exited_p
2058 SCM_VALIDATE_THREAD (1, thread
);
2059 t
= SCM_I_THREAD_DATA (thread
);
2064 SCM_DEFINE (scm_total_processor_count
, "total-processor-count", 0, 0, 0,
2066 "Return the total number of processors of the machine, which\n"
2067 "is guaranteed to be at least 1. A ``processor'' here is a\n"
2068 "thread execution unit, which can be either:\n\n"
2070 "@item an execution core in a (possibly multi-core) chip, in a\n"
2071 " (possibly multi- chip) module, in a single computer, or\n"
2072 "@item a thread execution unit inside a core in the case of\n"
2073 " @dfn{hyper-threaded} CPUs.\n"
2075 "Which of the two definitions is used, is unspecified.\n")
2076 #define FUNC_NAME s_scm_total_processor_count
2078 return scm_from_ulong (num_processors (NPROC_ALL
));
2082 SCM_DEFINE (scm_current_processor_count
, "current-processor-count", 0, 0, 0,
2084 "Like @code{total-processor-count}, but return the number of\n"
2085 "processors available to the current process. See\n"
2086 "@code{setaffinity} and @code{getaffinity} for more\n"
2088 #define FUNC_NAME s_scm_current_processor_count
2090 return scm_from_ulong (num_processors (NPROC_CURRENT
));
2097 static scm_i_pthread_cond_t wake_up_cond
;
2098 static int threads_initialized_p
= 0;
2101 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
2103 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
2105 static SCM dynwind_critical_section_mutex
;
2108 scm_dynwind_critical_section (SCM mutex
)
2110 if (scm_is_false (mutex
))
2111 mutex
= dynwind_critical_section_mutex
;
2112 scm_dynwind_lock_mutex (mutex
);
2113 scm_dynwind_block_asyncs ();
2116 /*** Initialization */
2118 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2120 #if SCM_USE_PTHREAD_THREADS
2121 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2125 scm_threads_prehistory (void *base
)
2127 #if SCM_USE_PTHREAD_THREADS
2128 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2129 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2130 PTHREAD_MUTEX_RECURSIVE
);
2133 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2134 scm_i_pthread_mutexattr_recursive
);
2135 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2136 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2138 guilify_self_1 ((struct GC_stack_base
*) base
);
2141 scm_t_bits scm_tc16_thread
;
2142 scm_t_bits scm_tc16_mutex
;
2143 scm_t_bits scm_tc16_condvar
;
2148 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2149 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2151 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2152 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2153 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2155 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2157 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2159 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2160 guilify_self_2 (SCM_BOOL_F
);
2161 threads_initialized_p
= 1;
2163 dynwind_critical_section_mutex
= scm_make_recursive_mutex ();
2167 scm_init_threads_default_dynamic_state ()
2169 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2170 scm_i_default_dynamic_state
= state
;
2174 scm_init_thread_procs ()
2176 #include "libguile/threads.x"
2180 /* IA64-specific things. */
2184 # include <sys/param.h>
2185 # include <sys/pstat.h>
2187 scm_ia64_register_backing_store_base (void)
2189 struct pst_vm_status vm_status
;
2191 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
2192 if (vm_status
.pst_type
== PS_RSESTACK
)
2193 return (void *) vm_status
.pst_vaddr
;
2197 scm_ia64_ar_bsp (const void *ctx
)
2200 __uc_get_ar_bsp (ctx
, &bsp
);
2201 return (void *) bsp
;
2205 # include <ucontext.h>
2207 scm_ia64_register_backing_store_base (void)
2209 extern void *__libc_ia64_register_backing_store_base
;
2210 return __libc_ia64_register_backing_store_base
;
2213 scm_ia64_ar_bsp (const void *opaque
)
2215 const ucontext_t
*ctx
= opaque
;
2216 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
2219 #endif /* __ia64__ */