1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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/boehm-gc.h"
26 #include "libguile/_scm.h"
35 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
42 #include "libguile/validate.h"
43 #include "libguile/root.h"
44 #include "libguile/eval.h"
45 #include "libguile/async.h"
46 #include "libguile/ports.h"
47 #include "libguile/threads.h"
48 #include "libguile/dynwind.h"
49 #include "libguile/iselect.h"
50 #include "libguile/fluids.h"
51 #include "libguile/continuations.h"
52 #include "libguile/gc.h"
53 #include "libguile/init.h"
54 #include "libguile/scmsigs.h"
55 #include "libguile/strings.h"
59 # define ETIMEDOUT WSAETIMEDOUT
63 # define pipe(fd) _pipe (fd, 256, O_BINARY)
64 #endif /* __MINGW32__ */
66 #include <full-read.h>
70 to_timespec (SCM t
, scm_t_timespec
*waittime
)
74 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
75 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
79 double time
= scm_to_double (t
);
80 double sec
= scm_c_truncate (time
);
82 waittime
->tv_sec
= (long) sec
;
83 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
89 /* Make an empty queue data structure.
94 return scm_cons (SCM_EOL
, SCM_EOL
);
97 /* Put T at the back of Q and return a handle that can be used with
98 remqueue to remove T from Q again.
101 enqueue (SCM q
, SCM t
)
103 SCM c
= scm_cons (t
, SCM_EOL
);
104 SCM_CRITICAL_SECTION_START
;
105 if (scm_is_null (SCM_CDR (q
)))
108 SCM_SETCDR (SCM_CAR (q
), c
);
110 SCM_CRITICAL_SECTION_END
;
114 /* Remove the element that the handle C refers to from the queue Q. C
115 must have been returned from a call to enqueue. The return value
116 is zero when the element referred to by C has already been removed.
117 Otherwise, 1 is returned.
120 remqueue (SCM q
, SCM c
)
123 SCM_CRITICAL_SECTION_START
;
124 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
126 if (scm_is_eq (p
, c
))
128 if (scm_is_eq (c
, SCM_CAR (q
)))
129 SCM_SETCAR (q
, SCM_CDR (c
));
130 SCM_SETCDR (prev
, SCM_CDR (c
));
131 SCM_CRITICAL_SECTION_END
;
136 SCM_CRITICAL_SECTION_END
;
140 /* Remove the front-most element from the queue Q and return it.
141 Return SCM_BOOL_F when Q is empty.
147 SCM_CRITICAL_SECTION_START
;
151 SCM_CRITICAL_SECTION_END
;
156 SCM_SETCDR (q
, SCM_CDR (c
));
157 if (scm_is_null (SCM_CDR (q
)))
158 SCM_SETCAR (q
, SCM_EOL
);
159 SCM_CRITICAL_SECTION_END
;
164 /*** Thread smob routines */
168 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
170 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
171 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
172 the struct case, hence we go via a union, and extract according to the
173 size of pthread_t. */
181 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
182 scm_i_pthread_t p
= t
->pthread
;
185 if (sizeof (p
) == sizeof (unsigned short))
187 else if (sizeof (p
) == sizeof (unsigned int))
189 else if (sizeof (p
) == sizeof (unsigned long))
194 scm_puts ("#<thread ", port
);
195 scm_uintprint (id
, 10, port
);
196 scm_puts (" (", port
);
197 scm_uintprint ((scm_t_bits
)t
, 16, port
);
198 scm_puts (")>", port
);
203 thread_free (SCM obj
)
205 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
207 scm_gc_free (t
, sizeof (*t
), "thread");
211 /*** Blocking on queues. */
213 /* See also scm_i_queue_async_cell for how such a block is
217 /* Put the current thread on QUEUE and go to sleep, waiting for it to
218 be woken up by a call to 'unblock_from_queue', or to be
219 interrupted. Upon return of this function, the current thread is
220 no longer on QUEUE, even when the sleep has been interrupted.
222 The caller of block_self must hold MUTEX. It will be atomically
223 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
225 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
228 When WAITTIME is not NULL, the sleep will be aborted at that time.
230 The return value of block_self is an errno value. It will be zero
231 when the sleep has been successfully completed by a call to
232 unblock_from_queue, EINTR when it has been interrupted by the
233 delivery of a system async, and ETIMEDOUT when the timeout has
236 The system asyncs themselves are not executed by block_self.
239 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
240 const scm_t_timespec
*waittime
)
242 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
246 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
251 q_handle
= enqueue (queue
, t
->handle
);
252 if (waittime
== NULL
)
253 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
255 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
257 /* When we are still on QUEUE, we have been interrupted. We
258 report this only when no other error (such as a timeout) has
261 if (remqueue (queue
, q_handle
) && err
== 0)
264 scm_i_reset_sleep (t
);
270 /* Wake up the first thread on QUEUE, if any. The awoken thread is
271 returned, or #f if the queue was empty.
274 unblock_from_queue (SCM queue
)
276 SCM thread
= dequeue (queue
);
277 if (scm_is_true (thread
))
278 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
282 /* Getting into and out of guile mode.
285 /* Ken Raeburn observes that the implementation of suspend and resume
286 (and the things that build on top of them) are very likely not
287 correct (see below). We will need fix this eventually, and that's
288 why scm_leave_guile/scm_enter_guile are not exported in the API.
292 Consider this sequence:
294 Function foo, called in Guile mode, calls suspend (maybe indirectly
295 through scm_leave_guile), which does this:
297 // record top of stack for the GC
298 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
301 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
302 SCM_I_SETJMP (t->regs); // here's most of the magic
306 Function foo has a SCM value X, a handle on a non-immediate object, in
307 a caller-saved register R, and it's the only reference to the object
310 The compiler wants to use R in suspend, so it pushes the current
311 value, X, into a stack slot which will be reloaded on exit from
312 suspend; then it loads stuff into R and goes about its business. The
313 setjmp call saves (some of) the current registers, including R, which
314 no longer contains X. (This isn't a problem for a normal
315 setjmp/longjmp situation, where longjmp would be called before
316 setjmp's caller returns; the old value for X would be loaded back from
317 the stack after the longjmp, before the function returned.)
319 So, suspend returns, loading X back into R (and invalidating the jump
320 buffer) in the process. The caller foo then goes off and calls a
321 bunch of other functions out of Guile mode, occasionally storing X on
322 the stack again, but, say, much deeper on the stack than suspend's
323 stack frame went, and the stack slot where suspend had written X has
324 long since been overwritten with other values.
326 Okay, nothing actively broken so far. Now, let garbage collection
327 run, triggered by another thread.
329 The thread calling foo is out of Guile mode at the time, so the
330 garbage collector just scans a range of stack addresses. Too bad that
331 X isn't stored there. So the pointed-to storage goes onto the free
332 list, and I think you can see where things go from there.
334 Is there anything I'm missing that'll prevent this scenario from
335 happening? I mean, aside from, "well, suspend and scm_leave_guile
336 don't have many local variables, so they probably won't need to save
337 any registers on most systems, so we hope everything will wind up in
338 the jump buffer and we'll just get away with it"?
340 (And, going the other direction, if scm_leave_guile and suspend push
341 the stack pointer over onto a new page, and foo doesn't make further
342 function calls and thus the stack pointer no longer includes that
343 page, are we guaranteed that the kernel cannot release the now-unused
344 stack page that contains the top-of-stack pointer we just saved? I
345 don't know if any OS actually does that. If it does, we could get
346 faults in garbage collection.)
348 I don't think scm_without_guile has to have this problem, as it gets
349 more control over the stack handling -- but it should call setjmp
350 itself. I'd probably try something like:
352 // record top of stack for the GC
353 t->top = SCM_STACK_PTR (&t);
355 SCM_FLUSH_REGISTER_WINDOWS;
356 SCM_I_SETJMP (t->regs);
360 ... though even that's making some assumptions about the stack
361 ordering of local variables versus caller-saved registers.
363 For something like scm_leave_guile to work, I don't think it can just
364 rely on invalidated jump buffers. A valid jump buffer, and a handle
365 on the stack state at the point when the jump buffer was initialized,
366 together, would work fine, but I think then we're talking about macros
367 invoking setjmp in the caller's stack frame, and requiring that the
368 caller of scm_leave_guile also call scm_enter_guile before returning,
369 kind of like pthread_cleanup_push/pop calls that have to be paired up
370 in a function. (In fact, the pthread ones have to be paired up
371 syntactically, as if they might expand to a compound statement
372 incorporating the user's code, and invoking a compiler's
373 exception-handling primitives. Which might be something to think
374 about for cases where Guile is used with C++ exceptions or
378 scm_i_pthread_key_t scm_i_thread_key
;
381 resume (scm_i_thread
*t
)
386 typedef void* scm_t_guile_ticket
;
389 scm_enter_guile (scm_t_guile_ticket ticket
)
391 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
398 static scm_i_thread
*
401 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
403 /* record top of stack for the GC */
404 t
->top
= SCM_STACK_PTR (&t
);
405 /* save registers. */
406 SCM_FLUSH_REGISTER_WINDOWS
;
407 SCM_I_SETJMP (t
->regs
);
411 static scm_t_guile_ticket
414 scm_i_thread
*t
= suspend ();
415 return (scm_t_guile_ticket
) t
;
418 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
419 static scm_i_thread
*all_threads
= NULL
;
420 static int thread_count
;
422 static SCM scm_i_default_dynamic_state
;
424 /* Perform first stage of thread initialisation, in non-guile mode.
427 guilify_self_1 (SCM_STACKITEM
*base
)
429 scm_i_thread
*t
= scm_gc_malloc (sizeof (scm_i_thread
), "thread");
431 t
->pthread
= scm_i_pthread_self ();
432 t
->handle
= SCM_BOOL_F
;
433 t
->result
= SCM_BOOL_F
;
434 t
->cleanup_handler
= SCM_BOOL_F
;
435 t
->mutexes
= SCM_EOL
;
436 t
->held_mutex
= NULL
;
437 t
->join_queue
= SCM_EOL
;
438 t
->dynamic_state
= SCM_BOOL_F
;
439 t
->dynwinds
= SCM_EOL
;
440 t
->active_asyncs
= SCM_EOL
;
442 t
->pending_asyncs
= 1;
443 t
->last_debug_frame
= NULL
;
446 /* Calculate and store off the base of this thread's register
447 backing store (RBS). Unfortunately our implementation(s) of
448 scm_ia64_register_backing_store_base are only reliable for the
449 main thread. For other threads, therefore, find out the current
450 top of the RBS, and use that as a maximum. */
451 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
456 bsp
= scm_ia64_ar_bsp (&ctx
);
457 if (t
->register_backing_store_base
> bsp
)
458 t
->register_backing_store_base
= bsp
;
461 t
->continuation_root
= SCM_EOL
;
462 t
->continuation_base
= base
;
463 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
464 t
->sleep_mutex
= NULL
;
465 t
->sleep_object
= SCM_BOOL_F
;
468 if (pipe (t
->sleep_pipe
) != 0)
469 /* FIXME: Error conditions during the initialization phase are handled
470 gracelessly since public functions such as `scm_init_guile ()'
471 currently have type `void'. */
474 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
475 t
->current_mark_stack_ptr
= NULL
;
476 t
->current_mark_stack_limit
= NULL
;
481 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
483 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
484 t
->next_thread
= all_threads
;
487 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
490 /* Perform second stage of thread initialisation, in guile mode.
493 guilify_self_2 (SCM parent
)
495 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
499 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
501 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
502 t
->continuation_base
= t
->base
;
505 if (scm_is_true (parent
))
506 t
->dynamic_state
= scm_make_dynamic_state (parent
);
508 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
510 t
->join_queue
= make_queue ();
517 /* We implement our own mutex type since we want them to be 'fair', we
518 want to do fancy things while waiting for them (like running
519 asyncs) and we might want to add things that are nice for
524 scm_i_pthread_mutex_t lock
;
526 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
528 int recursive
; /* allow recursive locking? */
529 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
530 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
531 owned by the current thread? */
533 SCM waiting
; /* the threads waiting for this mutex. */
536 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
537 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
539 /* Perform thread tear-down, in guile mode.
542 do_thread_exit (void *v
)
544 scm_i_thread
*t
= (scm_i_thread
*) v
;
546 if (!scm_is_false (t
->cleanup_handler
))
548 SCM ptr
= t
->cleanup_handler
;
550 t
->cleanup_handler
= SCM_BOOL_F
;
551 t
->result
= scm_internal_catch (SCM_BOOL_T
,
552 (scm_t_catch_body
) scm_call_0
, ptr
,
553 scm_handle_by_message_noexit
, NULL
);
556 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
559 close (t
->sleep_pipe
[0]);
560 close (t
->sleep_pipe
[1]);
561 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
564 while (!scm_is_null (t
->mutexes
))
566 SCM mutex
= SCM_CAR (t
->mutexes
);
567 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
568 scm_i_pthread_mutex_lock (&m
->lock
);
570 unblock_from_queue (m
->waiting
);
572 scm_i_pthread_mutex_unlock (&m
->lock
);
573 t
->mutexes
= SCM_CDR (t
->mutexes
);
576 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
582 on_thread_exit (void *v
)
584 /* This handler is executed in non-guile mode. */
585 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
587 /* If this thread was cancelled while doing a cond wait, it will
588 still have a mutex locked, so we unlock it here. */
591 scm_i_pthread_mutex_unlock (t
->held_mutex
);
592 t
->held_mutex
= NULL
;
595 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
597 /* Ensure the signal handling thread has been launched, because we might be
599 scm_i_ensure_signal_delivery_thread ();
601 /* Unblocking the joining threads needs to happen in guile mode
602 since the queue is a SCM data structure. */
604 /* Note: Since `do_thread_exit ()' uses allocates memory via `libgc', we
605 assume the GC is usable at this point, and notably that thread-local
606 storage (TLS) hasn't been deallocated yet. */
609 /* Removing ourself from the list of all threads needs to happen in
610 non-guile mode since all SCM values on our stack become
611 unprotected once we are no longer in the list. */
612 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
613 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
616 *tp
= t
->next_thread
;
621 /* If there's only one other thread, it could be the signal delivery
622 thread, so we need to notify it to shut down by closing its read pipe.
623 If it's not the signal delivery thread, then closing the read pipe isn't
625 if (thread_count
<= 1)
626 scm_i_close_signal_pipe ();
628 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
630 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
633 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
636 init_thread_key (void)
638 scm_i_pthread_key_create (&scm_i_thread_key
, NULL
);
641 /* Perform any initializations necessary to bring the current thread
642 into guile mode, initializing Guile itself, if necessary.
644 BASE is the stack base to use with GC.
646 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
647 which case the default dynamic state is used.
649 Return zero when the thread was in guile mode already; otherwise
654 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
658 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
660 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
662 /* This thread has not been guilified yet.
665 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
666 if (scm_initialized_p
== 0)
668 /* First thread ever to enter Guile. Run the full
671 scm_i_init_guile (base
);
672 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
676 /* Guile is already initialized, but this thread enters it for
677 the first time. Only initialize this thread.
679 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
680 guilify_self_1 (base
);
681 guilify_self_2 (parent
);
687 /* This thread is already guilified but not in guile mode, just
690 A user call to scm_with_guile() will lead us to here. This could
691 happen from anywhere on the stack, and in particular lower on the
692 stack than when it was when this thread was first guilified. Thus,
693 `base' must be updated. */
694 #if SCM_STACK_GROWS_UP
702 scm_enter_guile ((scm_t_guile_ticket
) t
);
707 /* Thread is already in guile mode. Nothing to do.
713 #if SCM_USE_PTHREAD_THREADS
715 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
716 /* This method for GNU/Linux and perhaps some other systems.
717 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
718 available on them. */
719 #define HAVE_GET_THREAD_STACK_BASE
721 static SCM_STACKITEM
*
722 get_thread_stack_base ()
728 pthread_getattr_np (pthread_self (), &attr
);
729 pthread_attr_getstack (&attr
, &start
, &size
);
730 end
= (char *)start
+ size
;
732 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
733 for the main thread, but we can use scm_get_stack_base in that
737 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
738 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
739 return (SCM_STACKITEM
*) GC_stackbottom
;
743 #if SCM_STACK_GROWS_UP
751 #elif HAVE_PTHREAD_GET_STACKADDR_NP
752 /* This method for MacOS X.
753 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
754 but as of 2006 there's nothing obvious at apple.com. */
755 #define HAVE_GET_THREAD_STACK_BASE
756 static SCM_STACKITEM
*
757 get_thread_stack_base ()
759 return pthread_get_stackaddr_np (pthread_self ());
762 #elif defined (__MINGW32__)
763 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
764 in any thread. We don't like hard-coding the name of a system, but there
765 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
767 #define HAVE_GET_THREAD_STACK_BASE
768 static SCM_STACKITEM
*
769 get_thread_stack_base ()
771 return (SCM_STACKITEM
*) GC_stackbottom
;
774 #endif /* pthread methods of get_thread_stack_base */
776 #else /* !SCM_USE_PTHREAD_THREADS */
778 #define HAVE_GET_THREAD_STACK_BASE
780 static SCM_STACKITEM
*
781 get_thread_stack_base ()
783 return (SCM_STACKITEM
*) GC_stackbottom
;
786 #endif /* !SCM_USE_PTHREAD_THREADS */
788 #ifdef HAVE_GET_THREAD_STACK_BASE
793 scm_i_init_thread_for_guile (get_thread_stack_base (),
794 scm_i_default_dynamic_state
);
800 scm_with_guile (void *(*func
)(void *), void *data
)
802 return scm_i_with_guile_and_parent (func
, data
,
803 scm_i_default_dynamic_state
);
806 SCM_UNUSED
static void
807 scm_leave_guile_cleanup (void *x
)
810 on_thread_exit (SCM_I_CURRENT_THREAD
);
814 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
818 SCM_STACKITEM base_item
;
820 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
823 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
824 res
= scm_c_with_continuation_barrier (func
, data
);
825 scm_i_pthread_cleanup_pop (0);
829 res
= scm_c_with_continuation_barrier (func
, data
);
835 /*** Non-guile mode. */
837 #if (defined HAVE_GC_DO_BLOCKING) && (!defined HAVE_DECL_GC_DO_BLOCKING)
839 /* This declaration is missing from the public headers of GC 7.1. */
840 extern void GC_do_blocking (void (*) (void *), void *);
844 #ifdef HAVE_GC_DO_BLOCKING
845 struct without_guile_arg
847 void * (*function
) (void *);
853 without_guile_trampoline (void *closure
)
855 struct without_guile_arg
*arg
;
857 SCM_I_CURRENT_THREAD
->guile_mode
= 0;
859 arg
= (struct without_guile_arg
*) closure
;
860 arg
->result
= arg
->function (arg
->data
);
862 SCM_I_CURRENT_THREAD
->guile_mode
= 1;
867 scm_without_guile (void *(*func
)(void *), void *data
)
871 #ifdef HAVE_GC_DO_BLOCKING
872 if (SCM_I_CURRENT_THREAD
->guile_mode
)
874 struct without_guile_arg arg
;
878 GC_do_blocking (without_guile_trampoline
, &arg
);
883 result
= func (data
);
889 /*** Thread creation */
896 scm_i_pthread_mutex_t mutex
;
897 scm_i_pthread_cond_t cond
;
901 really_launch (void *d
)
903 launch_data
*data
= (launch_data
*)d
;
904 SCM thunk
= data
->thunk
, handler
= data
->handler
;
907 t
= SCM_I_CURRENT_THREAD
;
909 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
910 data
->thread
= scm_current_thread ();
911 scm_i_pthread_cond_signal (&data
->cond
);
912 scm_i_pthread_mutex_unlock (&data
->mutex
);
914 if (SCM_UNBNDP (handler
))
915 t
->result
= scm_call_0 (thunk
);
917 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
919 /* Trigger a call to `on_thread_exit ()'. */
926 launch_thread (void *d
)
928 launch_data
*data
= (launch_data
*)d
;
929 scm_i_pthread_detach (scm_i_pthread_self ());
930 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
934 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
935 (SCM thunk
, SCM handler
),
936 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
937 "returning a new thread object representing the thread. The procedure\n"
938 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
940 "When @var{handler} is specified, then @var{thunk} is called from\n"
941 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
942 "handler. This catch is established inside the continuation barrier.\n"
944 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
945 "the @emph{exit value} of the thread and the thread is terminated.")
946 #define FUNC_NAME s_scm_call_with_new_thread
952 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
953 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
954 handler
, SCM_ARG2
, FUNC_NAME
);
956 data
.parent
= scm_current_dynamic_state ();
958 data
.handler
= handler
;
959 data
.thread
= SCM_BOOL_F
;
960 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
961 scm_i_pthread_cond_init (&data
.cond
, NULL
);
963 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
964 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
967 scm_i_pthread_mutex_unlock (&data
.mutex
);
971 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
972 scm_i_pthread_mutex_unlock (&data
.mutex
);
980 scm_t_catch_body body
;
982 scm_t_catch_handler handler
;
985 scm_i_pthread_mutex_t mutex
;
986 scm_i_pthread_cond_t cond
;
990 really_spawn (void *d
)
992 spawn_data
*data
= (spawn_data
*)d
;
993 scm_t_catch_body body
= data
->body
;
994 void *body_data
= data
->body_data
;
995 scm_t_catch_handler handler
= data
->handler
;
996 void *handler_data
= data
->handler_data
;
997 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
999 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
1000 data
->thread
= scm_current_thread ();
1001 scm_i_pthread_cond_signal (&data
->cond
);
1002 scm_i_pthread_mutex_unlock (&data
->mutex
);
1004 if (handler
== NULL
)
1005 t
->result
= body (body_data
);
1007 t
->result
= scm_internal_catch (SCM_BOOL_T
,
1009 handler
, handler_data
);
1015 spawn_thread (void *d
)
1017 spawn_data
*data
= (spawn_data
*)d
;
1018 scm_i_pthread_detach (scm_i_pthread_self ());
1019 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
1024 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1025 scm_t_catch_handler handler
, void *handler_data
)
1031 data
.parent
= scm_current_dynamic_state ();
1033 data
.body_data
= body_data
;
1034 data
.handler
= handler
;
1035 data
.handler_data
= handler_data
;
1036 data
.thread
= SCM_BOOL_F
;
1037 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1038 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1040 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1041 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1044 scm_i_pthread_mutex_unlock (&data
.mutex
);
1046 scm_syserror (NULL
);
1048 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1049 scm_i_pthread_mutex_unlock (&data
.mutex
);
1054 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1056 "Move the calling thread to the end of the scheduling queue.")
1057 #define FUNC_NAME s_scm_yield
1059 return scm_from_bool (scm_i_sched_yield ());
1063 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1065 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1066 "cannot be the current thread, and if @var{thread} has already terminated or "
1067 "been signaled to terminate, this function is a no-op.")
1068 #define FUNC_NAME s_scm_cancel_thread
1070 scm_i_thread
*t
= NULL
;
1072 SCM_VALIDATE_THREAD (1, thread
);
1073 t
= SCM_I_THREAD_DATA (thread
);
1074 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1078 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1079 scm_i_pthread_cancel (t
->pthread
);
1082 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1084 return SCM_UNSPECIFIED
;
1088 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1089 (SCM thread
, SCM proc
),
1090 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1091 "This handler will be called when the thread exits.")
1092 #define FUNC_NAME s_scm_set_thread_cleanup_x
1096 SCM_VALIDATE_THREAD (1, thread
);
1097 if (!scm_is_false (proc
))
1098 SCM_VALIDATE_THUNK (2, proc
);
1100 t
= SCM_I_THREAD_DATA (thread
);
1101 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1103 if (!(t
->exited
|| t
->canceled
))
1104 t
->cleanup_handler
= proc
;
1106 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1108 return SCM_UNSPECIFIED
;
1112 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1114 "Return the cleanup handler installed for the thread @var{thread}.")
1115 #define FUNC_NAME s_scm_thread_cleanup
1120 SCM_VALIDATE_THREAD (1, thread
);
1122 t
= SCM_I_THREAD_DATA (thread
);
1123 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1124 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1125 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1131 SCM
scm_join_thread (SCM thread
)
1133 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1136 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1137 (SCM thread
, SCM timeout
, SCM timeoutval
),
1138 "Suspend execution of the calling thread until the target @var{thread} "
1139 "terminates, unless the target @var{thread} has already terminated. ")
1140 #define FUNC_NAME s_scm_join_thread_timed
1143 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1144 SCM res
= SCM_BOOL_F
;
1146 if (! (SCM_UNBNDP (timeoutval
)))
1149 SCM_VALIDATE_THREAD (1, thread
);
1150 if (scm_is_eq (scm_current_thread (), thread
))
1151 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1153 t
= SCM_I_THREAD_DATA (thread
);
1154 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1156 if (! SCM_UNBNDP (timeout
))
1158 to_timespec (timeout
, &ctimeout
);
1159 timeout_ptr
= &ctimeout
;
1168 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1178 else if (err
== ETIMEDOUT
)
1181 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1183 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1185 /* Check for exit again, since we just released and
1186 reacquired the admin mutex, before the next block_self
1187 call (which would block forever if t has already
1197 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1203 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1205 "Return @code{#t} if @var{obj} is a thread.")
1206 #define FUNC_NAME s_scm_thread_p
1208 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1214 fat_mutex_free (SCM mx
)
1216 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1217 scm_i_pthread_mutex_destroy (&m
->lock
);
1218 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1223 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1225 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1226 scm_puts ("#<mutex ", port
);
1227 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1228 scm_puts (">", port
);
1233 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1238 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1239 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1240 m
->owner
= SCM_BOOL_F
;
1243 m
->recursive
= recursive
;
1244 m
->unchecked_unlock
= unchecked_unlock
;
1245 m
->allow_external_unlock
= external_unlock
;
1247 m
->waiting
= SCM_EOL
;
1248 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1249 m
->waiting
= make_queue ();
1253 SCM
scm_make_mutex (void)
1255 return scm_make_mutex_with_flags (SCM_EOL
);
1258 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1259 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1260 SCM_SYMBOL (recursive_sym
, "recursive");
1262 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1264 "Create a new mutex. ")
1265 #define FUNC_NAME s_scm_make_mutex_with_flags
1267 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1270 while (! scm_is_null (ptr
))
1272 SCM flag
= SCM_CAR (ptr
);
1273 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1274 unchecked_unlock
= 1;
1275 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1276 external_unlock
= 1;
1277 else if (scm_is_eq (flag
, recursive_sym
))
1280 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1281 ptr
= SCM_CDR (ptr
);
1283 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1287 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1289 "Create a new recursive mutex. ")
1290 #define FUNC_NAME s_scm_make_recursive_mutex
1292 return make_fat_mutex (1, 0, 0);
1296 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1299 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1301 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1303 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1304 SCM err
= SCM_BOOL_F
;
1306 struct timeval current_time
;
1308 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1314 m
->owner
= new_owner
;
1317 if (SCM_I_IS_THREAD (new_owner
))
1319 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1320 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1321 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1322 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1327 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1329 m
->owner
= new_owner
;
1330 err
= scm_cons (scm_abandoned_mutex_error_key
,
1331 scm_from_locale_string ("lock obtained on abandoned "
1336 else if (scm_is_eq (m
->owner
, new_owner
))
1345 err
= scm_cons (scm_misc_error_key
,
1346 scm_from_locale_string ("mutex already locked "
1354 if (timeout
!= NULL
)
1356 gettimeofday (¤t_time
, NULL
);
1357 if (current_time
.tv_sec
> timeout
->tv_sec
||
1358 (current_time
.tv_sec
== timeout
->tv_sec
&&
1359 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1365 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1366 scm_i_pthread_mutex_unlock (&m
->lock
);
1368 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1371 scm_i_pthread_mutex_unlock (&m
->lock
);
1375 SCM
scm_lock_mutex (SCM mx
)
1377 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1380 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1381 (SCM m
, SCM timeout
, SCM owner
),
1382 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1383 "blocks until the mutex becomes available. The function returns when "
1384 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1385 "a thread already owns will succeed right away and will not block the "
1386 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1387 #define FUNC_NAME s_scm_lock_mutex_timed
1391 scm_t_timespec cwaittime
, *waittime
= NULL
;
1393 SCM_VALIDATE_MUTEX (1, m
);
1395 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1397 to_timespec (timeout
, &cwaittime
);
1398 waittime
= &cwaittime
;
1401 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1402 if (!scm_is_false (exception
))
1403 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1404 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1409 scm_dynwind_lock_mutex (SCM mutex
)
1411 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1412 SCM_F_WIND_EXPLICITLY
);
1413 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1414 SCM_F_WIND_EXPLICITLY
);
1417 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1419 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1420 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1421 #define FUNC_NAME s_scm_try_mutex
1425 scm_t_timespec cwaittime
, *waittime
= NULL
;
1427 SCM_VALIDATE_MUTEX (1, mutex
);
1429 to_timespec (scm_from_int(0), &cwaittime
);
1430 waittime
= &cwaittime
;
1432 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1433 if (!scm_is_false (exception
))
1434 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1435 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1439 /*** Fat condition variables */
1442 scm_i_pthread_mutex_t lock
;
1443 SCM waiting
; /* the threads waiting for this condition. */
1446 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1447 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1450 fat_mutex_unlock (SCM mutex
, SCM cond
,
1451 const scm_t_timespec
*waittime
, int relock
)
1453 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1455 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1456 int err
= 0, ret
= 0;
1458 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1460 SCM owner
= m
->owner
;
1462 if (!scm_is_eq (owner
, scm_current_thread ()))
1466 if (!m
->unchecked_unlock
)
1468 scm_i_pthread_mutex_unlock (&m
->lock
);
1469 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1471 owner
= scm_current_thread ();
1473 else if (!m
->allow_external_unlock
)
1475 scm_i_pthread_mutex_unlock (&m
->lock
);
1476 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1480 if (! (SCM_UNBNDP (cond
)))
1482 c
= SCM_CONDVAR_DATA (cond
);
1490 m
->owner
= unblock_from_queue (m
->waiting
);
1494 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1495 scm_i_pthread_mutex_unlock (&m
->lock
);
1502 else if (err
== ETIMEDOUT
)
1507 else if (err
!= EINTR
)
1510 scm_syserror (NULL
);
1516 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1524 scm_remember_upto_here_2 (cond
, mutex
);
1526 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1534 m
->owner
= unblock_from_queue (m
->waiting
);
1536 scm_i_pthread_mutex_unlock (&m
->lock
);
1543 SCM
scm_unlock_mutex (SCM mx
)
1545 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1548 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1549 (SCM mx
, SCM cond
, SCM timeout
),
1550 "Unlocks @var{mutex} if the calling thread owns the lock on "
1551 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1552 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1553 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1554 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1555 "with a call to @code{unlock-mutex}. Only the last call to "
1556 "@code{unlock-mutex} will actually unlock the mutex. ")
1557 #define FUNC_NAME s_scm_unlock_mutex_timed
1559 scm_t_timespec cwaittime
, *waittime
= NULL
;
1561 SCM_VALIDATE_MUTEX (1, mx
);
1562 if (! (SCM_UNBNDP (cond
)))
1564 SCM_VALIDATE_CONDVAR (2, cond
);
1566 if (! (SCM_UNBNDP (timeout
)))
1568 to_timespec (timeout
, &cwaittime
);
1569 waittime
= &cwaittime
;
1573 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1577 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1579 "Return @code{#t} if @var{obj} is a mutex.")
1580 #define FUNC_NAME s_scm_mutex_p
1582 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1586 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1588 "Return the thread owning @var{mx}, or @code{#f}.")
1589 #define FUNC_NAME s_scm_mutex_owner
1592 fat_mutex
*m
= NULL
;
1594 SCM_VALIDATE_MUTEX (1, mx
);
1595 m
= SCM_MUTEX_DATA (mx
);
1596 scm_i_pthread_mutex_lock (&m
->lock
);
1598 scm_i_pthread_mutex_unlock (&m
->lock
);
1604 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1606 "Return the lock level of mutex @var{mx}.")
1607 #define FUNC_NAME s_scm_mutex_level
1609 SCM_VALIDATE_MUTEX (1, mx
);
1610 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1614 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1616 "Returns @code{#t} if the mutex @var{mx} is locked.")
1617 #define FUNC_NAME s_scm_mutex_locked_p
1619 SCM_VALIDATE_MUTEX (1, mx
);
1620 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1625 fat_cond_free (SCM mx
)
1627 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1628 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1633 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1635 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1636 scm_puts ("#<condition-variable ", port
);
1637 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1638 scm_puts (">", port
);
1642 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1644 "Make a new condition variable.")
1645 #define FUNC_NAME s_scm_make_condition_variable
1650 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1651 c
->waiting
= SCM_EOL
;
1652 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1653 c
->waiting
= make_queue ();
1658 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1659 (SCM cv
, SCM mx
, SCM t
),
1660 "Wait until @var{cond-var} has been signalled. While waiting, "
1661 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1662 "is locked again when this function returns. When @var{time} is given, "
1663 "it specifies a point in time where the waiting should be aborted. It "
1664 "can be either a integer as returned by @code{current-time} or a pair "
1665 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1666 "mutex is locked and @code{#f} is returned. When the condition "
1667 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1669 #define FUNC_NAME s_scm_timed_wait_condition_variable
1671 scm_t_timespec waittime
, *waitptr
= NULL
;
1673 SCM_VALIDATE_CONDVAR (1, cv
);
1674 SCM_VALIDATE_MUTEX (2, mx
);
1676 if (!SCM_UNBNDP (t
))
1678 to_timespec (t
, &waittime
);
1679 waitptr
= &waittime
;
1682 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1687 fat_cond_signal (fat_cond
*c
)
1689 unblock_from_queue (c
->waiting
);
1692 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1694 "Wake up one thread that is waiting for @var{cv}")
1695 #define FUNC_NAME s_scm_signal_condition_variable
1697 SCM_VALIDATE_CONDVAR (1, cv
);
1698 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1704 fat_cond_broadcast (fat_cond
*c
)
1706 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1710 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1712 "Wake up all threads that are waiting for @var{cv}. ")
1713 #define FUNC_NAME s_scm_broadcast_condition_variable
1715 SCM_VALIDATE_CONDVAR (1, cv
);
1716 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1721 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1723 "Return @code{#t} if @var{obj} is a condition variable.")
1724 #define FUNC_NAME s_scm_condition_variable_p
1726 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1730 /*** Marking stacks */
1732 /* XXX - what to do with this? Do we need to handle this for blocked
1736 # define SCM_MARK_BACKING_STORE() do { \
1738 SCM_STACKITEM * top, * bot; \
1739 getcontext (&ctx); \
1740 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1741 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1742 / sizeof (SCM_STACKITEM))); \
1743 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1744 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1745 scm_mark_locations (bot, top - bot); } while (0)
1747 # define SCM_MARK_BACKING_STORE()
1757 SELECT_TYPE
*read_fds
;
1758 SELECT_TYPE
*write_fds
;
1759 SELECT_TYPE
*except_fds
;
1760 struct timeval
*timeout
;
1767 do_std_select (void *args
)
1769 struct select_args
*select_args
;
1771 select_args
= (struct select_args
*) args
;
1773 select_args
->result
=
1774 select (select_args
->nfds
,
1775 select_args
->read_fds
, select_args
->write_fds
,
1776 select_args
->except_fds
, select_args
->timeout
);
1777 select_args
->errno_value
= errno
;
1783 scm_std_select (int nfds
,
1784 SELECT_TYPE
*readfds
,
1785 SELECT_TYPE
*writefds
,
1786 SELECT_TYPE
*exceptfds
,
1787 struct timeval
*timeout
)
1790 int res
, eno
, wakeup_fd
;
1791 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1792 struct select_args args
;
1794 if (readfds
== NULL
)
1796 FD_ZERO (&my_readfds
);
1797 readfds
= &my_readfds
;
1800 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1803 wakeup_fd
= t
->sleep_pipe
[0];
1804 FD_SET (wakeup_fd
, readfds
);
1805 if (wakeup_fd
>= nfds
)
1809 args
.read_fds
= readfds
;
1810 args
.write_fds
= writefds
;
1811 args
.except_fds
= exceptfds
;
1812 args
.timeout
= timeout
;
1814 /* Explicitly cooperate with the GC. */
1815 scm_without_guile (do_std_select
, &args
);
1818 eno
= args
.errno_value
;
1821 scm_i_reset_sleep (t
);
1823 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1826 full_read (wakeup_fd
, &dummy
, 1);
1828 FD_CLR (wakeup_fd
, readfds
);
1840 /* Convenience API for blocking while in guile mode. */
1842 #if SCM_USE_PTHREAD_THREADS
1844 /* It seems reasonable to not run procedures related to mutex and condition
1845 variables within `GC_do_blocking ()' since, (i) the GC can operate even
1846 without it, and (ii) the only potential gain would be GC latency. See
1847 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2245/focus=2251
1848 for a discussion of the pros and cons. */
1851 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1853 int res
= scm_i_pthread_mutex_lock (mutex
);
1858 do_unlock (void *data
)
1860 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1864 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1866 scm_i_scm_pthread_mutex_lock (mutex
);
1867 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1871 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1874 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1876 t
->held_mutex
= mutex
;
1877 res
= scm_i_pthread_cond_wait (cond
, mutex
);
1878 t
->held_mutex
= NULL
;
1884 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1885 scm_i_pthread_mutex_t
*mutex
,
1886 const scm_t_timespec
*wt
)
1889 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1891 t
->held_mutex
= mutex
;
1892 res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1893 t
->held_mutex
= NULL
;
1901 scm_std_usleep (unsigned long usecs
)
1904 tv
.tv_usec
= usecs
% 1000000;
1905 tv
.tv_sec
= usecs
/ 1000000;
1906 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1907 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1911 scm_std_sleep (unsigned int secs
)
1916 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1922 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1924 "Return the thread that called this function.")
1925 #define FUNC_NAME s_scm_current_thread
1927 return SCM_I_CURRENT_THREAD
->handle
;
1932 scm_c_make_list (size_t n
, SCM fill
)
1936 res
= scm_cons (fill
, res
);
1940 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1942 "Return a list of all threads.")
1943 #define FUNC_NAME s_scm_all_threads
1945 /* We can not allocate while holding the thread_admin_mutex because
1946 of the way GC is done.
1948 int n
= thread_count
;
1950 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1952 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1954 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1956 if (t
!= scm_i_signal_delivery_thread
)
1958 SCM_SETCAR (*l
, t
->handle
);
1959 l
= SCM_CDRLOC (*l
);
1964 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1969 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1971 "Return @code{#t} iff @var{thread} has exited.\n")
1972 #define FUNC_NAME s_scm_thread_exited_p
1974 return scm_from_bool (scm_c_thread_exited_p (thread
));
1979 scm_c_thread_exited_p (SCM thread
)
1980 #define FUNC_NAME s_scm_thread_exited_p
1983 SCM_VALIDATE_THREAD (1, thread
);
1984 t
= SCM_I_THREAD_DATA (thread
);
1989 static scm_i_pthread_cond_t wake_up_cond
;
1990 static int threads_initialized_p
= 0;
1993 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1995 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1996 int scm_i_critical_section_level
= 0;
1998 static SCM dynwind_critical_section_mutex
;
2001 scm_dynwind_critical_section (SCM mutex
)
2003 if (scm_is_false (mutex
))
2004 mutex
= dynwind_critical_section_mutex
;
2005 scm_dynwind_lock_mutex (mutex
);
2006 scm_dynwind_block_asyncs ();
2009 /*** Initialization */
2011 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2013 #if SCM_USE_PTHREAD_THREADS
2014 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2018 scm_threads_prehistory (SCM_STACKITEM
*base
)
2020 #if SCM_USE_PTHREAD_THREADS
2021 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2022 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2023 PTHREAD_MUTEX_RECURSIVE
);
2026 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2027 scm_i_pthread_mutexattr_recursive
);
2028 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2029 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2031 guilify_self_1 (base
);
2034 scm_t_bits scm_tc16_thread
;
2035 scm_t_bits scm_tc16_mutex
;
2036 scm_t_bits scm_tc16_condvar
;
2041 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2042 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2043 scm_set_smob_free (scm_tc16_thread
, thread_free
); /* XXX: Could be removed */
2045 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2046 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2047 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2049 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2051 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2052 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2054 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2055 guilify_self_2 (SCM_BOOL_F
);
2056 threads_initialized_p
= 1;
2058 dynwind_critical_section_mutex
=
2059 scm_permanent_object (scm_make_recursive_mutex ());
2063 scm_init_threads_default_dynamic_state ()
2065 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2066 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2070 scm_init_thread_procs ()
2072 #include "libguile/threads.x"
2076 /* IA64-specific things. */
2080 # include <sys/param.h>
2081 # include <sys/pstat.h>
2083 scm_ia64_register_backing_store_base (void)
2085 struct pst_vm_status vm_status
;
2087 while (pstat_getprocvm (&vm_status
, sizeof (vm_status
), 0, i
++) == 1)
2088 if (vm_status
.pst_type
== PS_RSESTACK
)
2089 return (void *) vm_status
.pst_vaddr
;
2093 scm_ia64_ar_bsp (const void *ctx
)
2096 __uc_get_ar_bsp (ctx
, &bsp
);
2097 return (void *) bsp
;
2101 # include <ucontext.h>
2103 scm_ia64_register_backing_store_base (void)
2105 extern void *__libc_ia64_register_backing_store_base
;
2106 return __libc_ia64_register_backing_store_base
;
2109 scm_ia64_ar_bsp (const void *opaque
)
2111 const ucontext_t
*ctx
= opaque
;
2112 return (void *) ctx
->uc_mcontext
.sc_ar_bsp
;
2115 #endif /* __ia64__ */