1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 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 02110-1301 USA
24 #include "libguile/boehm-gc.h"
25 #include "libguile/_scm.h"
34 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
41 #include "libguile/validate.h"
42 #include "libguile/root.h"
43 #include "libguile/eval.h"
44 #include "libguile/async.h"
45 #include "libguile/ports.h"
46 #include "libguile/threads.h"
47 #include "libguile/dynwind.h"
48 #include "libguile/iselect.h"
49 #include "libguile/fluids.h"
50 #include "libguile/continuations.h"
51 #include "libguile/gc.h"
52 #include "libguile/init.h"
53 #include "libguile/scmsigs.h"
54 #include "libguile/strings.h"
58 # define ETIMEDOUT WSAETIMEDOUT
62 # define pipe(fd) _pipe (fd, 256, O_BINARY)
63 #endif /* __MINGW32__ */
66 to_timespec (SCM t
, scm_t_timespec
*waittime
)
70 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
71 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
75 double time
= scm_to_double (t
);
76 double sec
= scm_c_truncate (time
);
78 waittime
->tv_sec
= (long) sec
;
79 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
85 /* Make an empty queue data structure.
90 return scm_cons (SCM_EOL
, SCM_EOL
);
93 /* Put T at the back of Q and return a handle that can be used with
94 remqueue to remove T from Q again.
97 enqueue (SCM q
, SCM t
)
99 SCM c
= scm_cons (t
, SCM_EOL
);
100 if (scm_is_null (SCM_CDR (q
)))
103 SCM_SETCDR (SCM_CAR (q
), c
);
108 /* Remove the element that the handle C refers to from the queue Q. C
109 must have been returned from a call to enqueue. The return value
110 is zero when the element referred to by C has already been removed.
111 Otherwise, 1 is returned.
114 remqueue (SCM q
, SCM c
)
117 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
119 if (scm_is_eq (p
, c
))
121 if (scm_is_eq (c
, SCM_CAR (q
)))
122 SCM_SETCAR (q
, SCM_CDR (c
));
123 SCM_SETCDR (prev
, SCM_CDR (c
));
131 /* Remove the front-most element from the queue Q and return it.
132 Return SCM_BOOL_F when Q is empty.
142 SCM_SETCDR (q
, SCM_CDR (c
));
143 if (scm_is_null (SCM_CDR (q
)))
144 SCM_SETCAR (q
, SCM_EOL
);
149 /*** Thread smob routines */
153 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
155 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
156 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
157 the struct case, hence we go via a union, and extract according to the
158 size of pthread_t. */
166 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
167 scm_i_pthread_t p
= t
->pthread
;
170 if (sizeof (p
) == sizeof (unsigned short))
172 else if (sizeof (p
) == sizeof (unsigned int))
174 else if (sizeof (p
) == sizeof (unsigned long))
179 scm_puts ("#<thread ", port
);
180 scm_uintprint (id
, 10, port
);
181 scm_puts (" (", port
);
182 scm_uintprint ((scm_t_bits
)t
, 16, port
);
183 scm_puts (")>", port
);
188 thread_free (SCM obj
)
190 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
192 scm_gc_free (t
, sizeof (*t
), "thread");
196 /*** Blocking on queues. */
198 /* See also scm_i_queue_async_cell for how such a block is
202 /* Put the current thread on QUEUE and go to sleep, waiting for it to
203 be woken up by a call to 'unblock_from_queue', or to be
204 interrupted. Upon return of this function, the current thread is
205 no longer on QUEUE, even when the sleep has been interrupted.
207 The QUEUE data structure is assumed to be protected by MUTEX and
208 the caller of block_self must hold MUTEX. It will be atomically
209 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
211 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
214 When WAITTIME is not NULL, the sleep will be aborted at that time.
216 The return value of block_self is an errno value. It will be zero
217 when the sleep has been successfully completed by a call to
218 unblock_from_queue, EINTR when it has been interrupted by the
219 delivery of a system async, and ETIMEDOUT when the timeout has
222 The system asyncs themselves are not executed by block_self.
225 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
226 const scm_t_timespec
*waittime
)
228 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
232 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
237 q_handle
= enqueue (queue
, t
->handle
);
238 if (waittime
== NULL
)
239 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
241 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
243 /* When we are still on QUEUE, we have been interrupted. We
244 report this only when no other error (such as a timeout) has
247 if (remqueue (queue
, q_handle
) && err
== 0)
250 scm_i_reset_sleep (t
);
256 /* Wake up the first thread on QUEUE, if any. The caller must hold
257 the mutex that protects QUEUE. The awoken thread is returned, or
258 #f when the queue was empty.
261 unblock_from_queue (SCM queue
)
263 SCM thread
= dequeue (queue
);
264 if (scm_is_true (thread
))
265 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
269 /* Getting into and out of guile mode.
272 /* Ken Raeburn observes that the implementation of suspend and resume
273 (and the things that build on top of them) are very likely not
274 correct (see below). We will need fix this eventually, and that's
275 why scm_leave_guile/scm_enter_guile are not exported in the API.
279 Consider this sequence:
281 Function foo, called in Guile mode, calls suspend (maybe indirectly
282 through scm_leave_guile), which does this:
284 // record top of stack for the GC
285 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
288 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
289 setjmp (t->regs); // here's most of the magic
293 Function foo has a SCM value X, a handle on a non-immediate object, in
294 a caller-saved register R, and it's the only reference to the object
297 The compiler wants to use R in suspend, so it pushes the current
298 value, X, into a stack slot which will be reloaded on exit from
299 suspend; then it loads stuff into R and goes about its business. The
300 setjmp call saves (some of) the current registers, including R, which
301 no longer contains X. (This isn't a problem for a normal
302 setjmp/longjmp situation, where longjmp would be called before
303 setjmp's caller returns; the old value for X would be loaded back from
304 the stack after the longjmp, before the function returned.)
306 So, suspend returns, loading X back into R (and invalidating the jump
307 buffer) in the process. The caller foo then goes off and calls a
308 bunch of other functions out of Guile mode, occasionally storing X on
309 the stack again, but, say, much deeper on the stack than suspend's
310 stack frame went, and the stack slot where suspend had written X has
311 long since been overwritten with other values.
313 Okay, nothing actively broken so far. Now, let garbage collection
314 run, triggered by another thread.
316 The thread calling foo is out of Guile mode at the time, so the
317 garbage collector just scans a range of stack addresses. Too bad that
318 X isn't stored there. So the pointed-to storage goes onto the free
319 list, and I think you can see where things go from there.
321 Is there anything I'm missing that'll prevent this scenario from
322 happening? I mean, aside from, "well, suspend and scm_leave_guile
323 don't have many local variables, so they probably won't need to save
324 any registers on most systems, so we hope everything will wind up in
325 the jump buffer and we'll just get away with it"?
327 (And, going the other direction, if scm_leave_guile and suspend push
328 the stack pointer over onto a new page, and foo doesn't make further
329 function calls and thus the stack pointer no longer includes that
330 page, are we guaranteed that the kernel cannot release the now-unused
331 stack page that contains the top-of-stack pointer we just saved? I
332 don't know if any OS actually does that. If it does, we could get
333 faults in garbage collection.)
335 I don't think scm_without_guile has to have this problem, as it gets
336 more control over the stack handling -- but it should call setjmp
337 itself. I'd probably try something like:
339 // record top of stack for the GC
340 t->top = SCM_STACK_PTR (&t);
342 SCM_FLUSH_REGISTER_WINDOWS;
347 ... though even that's making some assumptions about the stack
348 ordering of local variables versus caller-saved registers.
350 For something like scm_leave_guile to work, I don't think it can just
351 rely on invalidated jump buffers. A valid jump buffer, and a handle
352 on the stack state at the point when the jump buffer was initialized,
353 together, would work fine, but I think then we're talking about macros
354 invoking setjmp in the caller's stack frame, and requiring that the
355 caller of scm_leave_guile also call scm_enter_guile before returning,
356 kind of like pthread_cleanup_push/pop calls that have to be paired up
357 in a function. (In fact, the pthread ones have to be paired up
358 syntactically, as if they might expand to a compound statement
359 incorporating the user's code, and invoking a compiler's
360 exception-handling primitives. Which might be something to think
361 about for cases where Guile is used with C++ exceptions or
365 scm_i_pthread_key_t scm_i_thread_key
;
368 resume (scm_i_thread
*t
)
373 typedef void* scm_t_guile_ticket
;
376 scm_enter_guile (scm_t_guile_ticket ticket
)
378 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
385 static scm_i_thread
*
388 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
390 /* record top of stack for the GC */
391 t
->top
= SCM_STACK_PTR (&t
);
392 /* save registers. */
393 SCM_FLUSH_REGISTER_WINDOWS
;
398 static scm_t_guile_ticket
401 scm_i_thread
*t
= suspend ();
402 return (scm_t_guile_ticket
) t
;
405 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
406 static scm_i_thread
*all_threads
= NULL
;
407 static int thread_count
;
409 static SCM scm_i_default_dynamic_state
;
411 /* Perform first stage of thread initialisation, in non-guile mode.
414 guilify_self_1 (SCM_STACKITEM
*base
)
416 scm_i_thread
*t
= scm_gc_malloc (sizeof (scm_i_thread
), "thread");
418 t
->pthread
= scm_i_pthread_self ();
419 t
->handle
= SCM_BOOL_F
;
420 t
->result
= SCM_BOOL_F
;
421 t
->cleanup_handler
= SCM_BOOL_F
;
422 t
->mutexes
= SCM_EOL
;
423 t
->join_queue
= SCM_EOL
;
424 t
->dynamic_state
= SCM_BOOL_F
;
425 t
->dynwinds
= SCM_EOL
;
426 t
->active_asyncs
= SCM_EOL
;
428 t
->pending_asyncs
= 1;
429 t
->last_debug_frame
= NULL
;
432 /* Calculate and store off the base of this thread's register
433 backing store (RBS). Unfortunately our implementation(s) of
434 scm_ia64_register_backing_store_base are only reliable for the
435 main thread. For other threads, therefore, find out the current
436 top of the RBS, and use that as a maximum. */
437 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
442 bsp
= scm_ia64_ar_bsp (&ctx
);
443 if (t
->register_backing_store_base
> bsp
)
444 t
->register_backing_store_base
= bsp
;
447 t
->continuation_root
= SCM_EOL
;
448 t
->continuation_base
= base
;
449 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
450 t
->sleep_mutex
= NULL
;
451 t
->sleep_object
= SCM_BOOL_F
;
453 /* XXX - check for errors. */
454 pipe (t
->sleep_pipe
);
455 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
456 t
->current_mark_stack_ptr
= NULL
;
457 t
->current_mark_stack_limit
= NULL
;
462 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
464 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
465 t
->next_thread
= all_threads
;
468 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
471 /* Perform second stage of thread initialisation, in guile mode.
474 guilify_self_2 (SCM parent
)
476 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
480 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
482 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
483 t
->continuation_base
= t
->base
;
485 if (scm_is_true (parent
))
486 t
->dynamic_state
= scm_make_dynamic_state (parent
);
488 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
490 t
->join_queue
= make_queue ();
497 /* We implement our own mutex type since we want them to be 'fair', we
498 want to do fancy things while waiting for them (like running
499 asyncs) and we might want to add things that are nice for
504 scm_i_pthread_mutex_t lock
;
506 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
508 int recursive
; /* allow recursive locking? */
509 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
510 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
511 owned by the current thread? */
513 SCM waiting
; /* the threads waiting for this mutex. */
516 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
517 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
519 /* Perform thread tear-down, in guile mode.
522 do_thread_exit (void *v
)
524 scm_i_thread
*t
= (scm_i_thread
*) v
;
526 if (!scm_is_false (t
->cleanup_handler
))
528 SCM ptr
= t
->cleanup_handler
;
530 t
->cleanup_handler
= SCM_BOOL_F
;
531 t
->result
= scm_internal_catch (SCM_BOOL_T
,
532 (scm_t_catch_body
) scm_call_0
, ptr
,
533 scm_handle_by_message_noexit
, NULL
);
536 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
539 close (t
->sleep_pipe
[0]);
540 close (t
->sleep_pipe
[1]);
541 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
544 while (!scm_is_null (t
->mutexes
))
546 SCM mutex
= SCM_CAR (t
->mutexes
);
547 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
548 scm_i_pthread_mutex_lock (&m
->lock
);
550 unblock_from_queue (m
->waiting
);
552 scm_i_pthread_mutex_unlock (&m
->lock
);
553 t
->mutexes
= SCM_CDR (t
->mutexes
);
556 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
562 on_thread_exit (void *v
)
564 /* This handler is executed in non-guile mode. */
565 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
567 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
569 /* Ensure the signal handling thread has been launched, because we might be
571 scm_i_ensure_signal_delivery_thread ();
573 /* Unblocking the joining threads needs to happen in guile mode
574 since the queue is a SCM data structure. */
576 /* Note: `scm_with_guile ()' invokes `GC_local_malloc ()', which accesses
577 thread-local storage (TLS). If said storage is accessed using
578 `pthread_getspecific ()', then it may be inaccessible at this point,
579 having been destroyed earlier, since the invocation order of destructors
580 associated with pthread keys is unspecified:
582 http://www.opengroup.org/onlinepubs/009695399/functions/pthread_key_create.html
584 Thus, `libgc' *must* be compiled with `USE_COMPILER_TLS' for this code
586 scm_with_guile (do_thread_exit
, v
);
588 /* Removing ourself from the list of all threads needs to happen in
589 non-guile mode since all SCM values on our stack become
590 unprotected once we are no longer in the list. */
591 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
592 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
595 *tp
= t
->next_thread
;
600 /* If there's only one other thread, it could be the signal delivery
601 thread, so we need to notify it to shut down by closing its read pipe.
602 If it's not the signal delivery thread, then closing the read pipe isn't
604 if (thread_count
<= 1)
605 scm_i_close_signal_pipe ();
607 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
609 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
612 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
615 init_thread_key (void)
617 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
620 /* Perform any initializations necessary to bring the current thread
621 into guile mode, initializing Guile itself, if necessary.
623 BASE is the stack base to use with GC.
625 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
626 which case the default dynamic state is used.
628 Return zero when the thread was in guile mode already; otherwise
633 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
637 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
639 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
641 /* This thread has not been guilified yet.
644 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
645 if (scm_initialized_p
== 0)
647 /* First thread ever to enter Guile. Run the full
650 scm_i_init_guile (base
);
651 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
655 /* Guile is already initialized, but this thread enters it for
656 the first time. Only initialize this thread.
658 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
659 guilify_self_1 (base
);
660 guilify_self_2 (parent
);
666 /* This thread is already guilified but not in guile mode, just
669 XXX - base might be lower than when this thread was first
672 scm_enter_guile ((scm_t_guile_ticket
) t
);
677 /* Thread is already in guile mode. Nothing to do.
683 #if SCM_USE_PTHREAD_THREADS
685 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
686 /* This method for GNU/Linux and perhaps some other systems.
687 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
688 available on them. */
689 #define HAVE_GET_THREAD_STACK_BASE
691 static SCM_STACKITEM
*
692 get_thread_stack_base ()
698 pthread_getattr_np (pthread_self (), &attr
);
699 pthread_attr_getstack (&attr
, &start
, &size
);
700 end
= (char *)start
+ size
;
702 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
703 for the main thread, but we can use scm_get_stack_base in that
707 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
708 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
709 return (SCM_STACKITEM
*) GC_stackbottom
;
713 #if SCM_STACK_GROWS_UP
721 #elif HAVE_PTHREAD_GET_STACKADDR_NP
722 /* This method for MacOS X.
723 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
724 but as of 2006 there's nothing obvious at apple.com. */
725 #define HAVE_GET_THREAD_STACK_BASE
726 static SCM_STACKITEM
*
727 get_thread_stack_base ()
729 return pthread_get_stackaddr_np (pthread_self ());
732 #elif defined (__MINGW32__)
733 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
734 in any thread. We don't like hard-coding the name of a system, but there
735 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
737 #define HAVE_GET_THREAD_STACK_BASE
738 static SCM_STACKITEM
*
739 get_thread_stack_base ()
741 return (SCM_STACKITEM
*) GC_stackbottom
;
744 #endif /* pthread methods of get_thread_stack_base */
746 #else /* !SCM_USE_PTHREAD_THREADS */
748 #define HAVE_GET_THREAD_STACK_BASE
750 static SCM_STACKITEM
*
751 get_thread_stack_base ()
753 return (SCM_STACKITEM
*) GC_stackbottom
;
756 #endif /* !SCM_USE_PTHREAD_THREADS */
758 #ifdef HAVE_GET_THREAD_STACK_BASE
763 scm_i_init_thread_for_guile (get_thread_stack_base (),
764 scm_i_default_dynamic_state
);
770 scm_with_guile (void *(*func
)(void *), void *data
)
772 return scm_i_with_guile_and_parent (func
, data
,
773 scm_i_default_dynamic_state
);
776 SCM_UNUSED
static void
777 scm_leave_guile_cleanup (void *x
)
783 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
787 SCM_STACKITEM base_item
;
789 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
792 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
793 res
= scm_c_with_continuation_barrier (func
, data
);
794 scm_i_pthread_cleanup_pop (0);
798 res
= scm_c_with_continuation_barrier (func
, data
);
804 /*** Non-guile mode. */
806 #if (defined HAVE_GC_DO_BLOCKING) && (!defined HAVE_DECL_GC_DO_BLOCKING)
808 /* This declaration is missing from the public headers of GC 7.1. */
809 extern void GC_do_blocking (void (*) (void *), void *);
813 #ifdef HAVE_GC_DO_BLOCKING
814 struct without_guile_arg
816 void * (*function
) (void *);
822 without_guile_trampoline (void *closure
)
824 struct without_guile_arg
*arg
;
826 SCM_I_CURRENT_THREAD
->guile_mode
= 0;
828 arg
= (struct without_guile_arg
*) closure
;
829 arg
->result
= arg
->function (arg
->data
);
831 SCM_I_CURRENT_THREAD
->guile_mode
= 1;
836 scm_without_guile (void *(*func
)(void *), void *data
)
840 #ifdef HAVE_GC_DO_BLOCKING
841 if (SCM_I_CURRENT_THREAD
->guile_mode
)
843 struct without_guile_arg arg
;
847 GC_do_blocking (without_guile_trampoline
, &arg
);
852 result
= func (data
);
858 /*** Thread creation */
865 scm_i_pthread_mutex_t mutex
;
866 scm_i_pthread_cond_t cond
;
870 really_launch (void *d
)
872 launch_data
*data
= (launch_data
*)d
;
873 SCM thunk
= data
->thunk
, handler
= data
->handler
;
876 t
= SCM_I_CURRENT_THREAD
;
878 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
879 data
->thread
= scm_current_thread ();
880 scm_i_pthread_cond_signal (&data
->cond
);
881 scm_i_pthread_mutex_unlock (&data
->mutex
);
883 if (SCM_UNBNDP (handler
))
884 t
->result
= scm_call_0 (thunk
);
886 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
892 launch_thread (void *d
)
894 launch_data
*data
= (launch_data
*)d
;
895 scm_i_pthread_detach (scm_i_pthread_self ());
896 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
900 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
901 (SCM thunk
, SCM handler
),
902 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
903 "returning a new thread object representing the thread. The procedure\n"
904 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
906 "When @var{handler} is specified, then @var{thunk} is called from\n"
907 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
908 "handler. This catch is established inside the continuation barrier.\n"
910 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
911 "the @emph{exit value} of the thread and the thread is terminated.")
912 #define FUNC_NAME s_scm_call_with_new_thread
918 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
919 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
920 handler
, SCM_ARG2
, FUNC_NAME
);
922 data
.parent
= scm_current_dynamic_state ();
924 data
.handler
= handler
;
925 data
.thread
= SCM_BOOL_F
;
926 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
927 scm_i_pthread_cond_init (&data
.cond
, NULL
);
929 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
930 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
933 scm_i_pthread_mutex_unlock (&data
.mutex
);
937 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
938 scm_i_pthread_mutex_unlock (&data
.mutex
);
946 scm_t_catch_body body
;
948 scm_t_catch_handler handler
;
951 scm_i_pthread_mutex_t mutex
;
952 scm_i_pthread_cond_t cond
;
956 really_spawn (void *d
)
958 spawn_data
*data
= (spawn_data
*)d
;
959 scm_t_catch_body body
= data
->body
;
960 void *body_data
= data
->body_data
;
961 scm_t_catch_handler handler
= data
->handler
;
962 void *handler_data
= data
->handler_data
;
963 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
965 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
966 data
->thread
= scm_current_thread ();
967 scm_i_pthread_cond_signal (&data
->cond
);
968 scm_i_pthread_mutex_unlock (&data
->mutex
);
971 t
->result
= body (body_data
);
973 t
->result
= scm_internal_catch (SCM_BOOL_T
,
975 handler
, handler_data
);
981 spawn_thread (void *d
)
983 spawn_data
*data
= (spawn_data
*)d
;
984 scm_i_pthread_detach (scm_i_pthread_self ());
985 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
990 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
991 scm_t_catch_handler handler
, void *handler_data
)
997 data
.parent
= scm_current_dynamic_state ();
999 data
.body_data
= body_data
;
1000 data
.handler
= handler
;
1001 data
.handler_data
= handler_data
;
1002 data
.thread
= SCM_BOOL_F
;
1003 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1004 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1006 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1007 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1010 scm_i_pthread_mutex_unlock (&data
.mutex
);
1012 scm_syserror (NULL
);
1014 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1015 scm_i_pthread_mutex_unlock (&data
.mutex
);
1020 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1022 "Move the calling thread to the end of the scheduling queue.")
1023 #define FUNC_NAME s_scm_yield
1025 return scm_from_bool (scm_i_sched_yield ());
1029 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1031 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1032 "cannot be the current thread, and if @var{thread} has already terminated or "
1033 "been signaled to terminate, this function is a no-op.")
1034 #define FUNC_NAME s_scm_cancel_thread
1036 scm_i_thread
*t
= NULL
;
1038 SCM_VALIDATE_THREAD (1, thread
);
1039 t
= SCM_I_THREAD_DATA (thread
);
1040 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1044 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1045 scm_i_pthread_cancel (t
->pthread
);
1048 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1050 return SCM_UNSPECIFIED
;
1054 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1055 (SCM thread
, SCM proc
),
1056 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1057 "This handler will be called when the thread exits.")
1058 #define FUNC_NAME s_scm_set_thread_cleanup_x
1062 SCM_VALIDATE_THREAD (1, thread
);
1063 if (!scm_is_false (proc
))
1064 SCM_VALIDATE_THUNK (2, proc
);
1066 t
= SCM_I_THREAD_DATA (thread
);
1067 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1069 if (!(t
->exited
|| t
->canceled
))
1070 t
->cleanup_handler
= proc
;
1072 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1074 return SCM_UNSPECIFIED
;
1078 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1080 "Return the cleanup handler installed for the thread @var{thread}.")
1081 #define FUNC_NAME s_scm_thread_cleanup
1086 SCM_VALIDATE_THREAD (1, thread
);
1088 t
= SCM_I_THREAD_DATA (thread
);
1089 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1090 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1091 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1097 SCM
scm_join_thread (SCM thread
)
1099 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1102 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1103 (SCM thread
, SCM timeout
, SCM timeoutval
),
1104 "Suspend execution of the calling thread until the target @var{thread} "
1105 "terminates, unless the target @var{thread} has already terminated. ")
1106 #define FUNC_NAME s_scm_join_thread_timed
1109 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1110 SCM res
= SCM_BOOL_F
;
1112 if (! (SCM_UNBNDP (timeoutval
)))
1115 SCM_VALIDATE_THREAD (1, thread
);
1116 if (scm_is_eq (scm_current_thread (), thread
))
1117 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1119 t
= SCM_I_THREAD_DATA (thread
);
1120 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1122 if (! SCM_UNBNDP (timeout
))
1124 to_timespec (timeout
, &ctimeout
);
1125 timeout_ptr
= &ctimeout
;
1134 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1144 else if (err
== ETIMEDOUT
)
1147 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1149 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1153 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1159 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1161 "Return @code{#t} if @var{obj} is a thread.")
1162 #define FUNC_NAME s_scm_thread_p
1164 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1170 fat_mutex_free (SCM mx
)
1172 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1173 scm_i_pthread_mutex_destroy (&m
->lock
);
1174 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1179 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1181 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1182 scm_puts ("#<mutex ", port
);
1183 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1184 scm_puts (">", port
);
1189 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1194 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1195 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1196 m
->owner
= SCM_BOOL_F
;
1199 m
->recursive
= recursive
;
1200 m
->unchecked_unlock
= unchecked_unlock
;
1201 m
->allow_external_unlock
= external_unlock
;
1203 m
->waiting
= SCM_EOL
;
1204 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1205 m
->waiting
= make_queue ();
1209 SCM
scm_make_mutex (void)
1211 return scm_make_mutex_with_flags (SCM_EOL
);
1214 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1215 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1216 SCM_SYMBOL (recursive_sym
, "recursive");
1218 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1220 "Create a new mutex. ")
1221 #define FUNC_NAME s_scm_make_mutex_with_flags
1223 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1226 while (! scm_is_null (ptr
))
1228 SCM flag
= SCM_CAR (ptr
);
1229 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1230 unchecked_unlock
= 1;
1231 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1232 external_unlock
= 1;
1233 else if (scm_is_eq (flag
, recursive_sym
))
1236 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1237 ptr
= SCM_CDR (ptr
);
1239 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1243 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1245 "Create a new recursive mutex. ")
1246 #define FUNC_NAME s_scm_make_recursive_mutex
1248 return make_fat_mutex (1, 0, 0);
1252 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1255 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1257 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1259 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1260 SCM err
= SCM_BOOL_F
;
1262 struct timeval current_time
;
1264 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1270 m
->owner
= new_owner
;
1273 if (SCM_I_IS_THREAD (new_owner
))
1275 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1276 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1277 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1278 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1283 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1285 m
->owner
= new_owner
;
1286 err
= scm_cons (scm_abandoned_mutex_error_key
,
1287 scm_from_locale_string ("lock obtained on abandoned "
1292 else if (scm_is_eq (m
->owner
, new_owner
))
1301 err
= scm_cons (scm_misc_error_key
,
1302 scm_from_locale_string ("mutex already locked "
1310 if (timeout
!= NULL
)
1312 gettimeofday (¤t_time
, NULL
);
1313 if (current_time
.tv_sec
> timeout
->tv_sec
||
1314 (current_time
.tv_sec
== timeout
->tv_sec
&&
1315 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1321 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1322 scm_i_pthread_mutex_unlock (&m
->lock
);
1324 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1327 scm_i_pthread_mutex_unlock (&m
->lock
);
1331 SCM
scm_lock_mutex (SCM mx
)
1333 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1336 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1337 (SCM m
, SCM timeout
, SCM owner
),
1338 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1339 "blocks until the mutex becomes available. The function returns when "
1340 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1341 "a thread already owns will succeed right away and will not block the "
1342 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1343 #define FUNC_NAME s_scm_lock_mutex_timed
1347 scm_t_timespec cwaittime
, *waittime
= NULL
;
1349 SCM_VALIDATE_MUTEX (1, m
);
1351 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1353 to_timespec (timeout
, &cwaittime
);
1354 waittime
= &cwaittime
;
1357 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1358 if (!scm_is_false (exception
))
1359 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1360 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1365 scm_dynwind_lock_mutex (SCM mutex
)
1367 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1368 SCM_F_WIND_EXPLICITLY
);
1369 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1370 SCM_F_WIND_EXPLICITLY
);
1373 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1375 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1376 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1377 #define FUNC_NAME s_scm_try_mutex
1381 scm_t_timespec cwaittime
, *waittime
= NULL
;
1383 SCM_VALIDATE_MUTEX (1, mutex
);
1385 to_timespec (scm_from_int(0), &cwaittime
);
1386 waittime
= &cwaittime
;
1388 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1389 if (!scm_is_false (exception
))
1390 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1391 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1395 /*** Fat condition variables */
1398 scm_i_pthread_mutex_t lock
;
1399 SCM waiting
; /* the threads waiting for this condition. */
1402 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1403 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1406 fat_mutex_unlock (SCM mutex
, SCM cond
,
1407 const scm_t_timespec
*waittime
, int relock
)
1409 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1411 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1412 int err
= 0, ret
= 0;
1414 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1416 SCM owner
= m
->owner
;
1418 if (!scm_is_eq (owner
, scm_current_thread ()))
1422 if (!m
->unchecked_unlock
)
1424 scm_i_pthread_mutex_unlock (&m
->lock
);
1425 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1427 owner
= scm_current_thread ();
1429 else if (!m
->allow_external_unlock
)
1431 scm_i_pthread_mutex_unlock (&m
->lock
);
1432 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1436 if (! (SCM_UNBNDP (cond
)))
1438 c
= SCM_CONDVAR_DATA (cond
);
1443 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1447 m
->owner
= unblock_from_queue (m
->waiting
);
1449 scm_i_pthread_mutex_unlock (&m
->lock
);
1453 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1460 else if (err
== ETIMEDOUT
)
1465 else if (err
!= EINTR
)
1468 scm_i_pthread_mutex_unlock (&c
->lock
);
1469 scm_syserror (NULL
);
1475 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1476 scm_i_pthread_mutex_unlock (&c
->lock
);
1480 scm_i_pthread_mutex_unlock (&c
->lock
);
1485 scm_remember_upto_here_2 (cond
, mutex
);
1487 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1495 m
->owner
= unblock_from_queue (m
->waiting
);
1497 scm_i_pthread_mutex_unlock (&m
->lock
);
1504 SCM
scm_unlock_mutex (SCM mx
)
1506 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1509 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1510 (SCM mx
, SCM cond
, SCM timeout
),
1511 "Unlocks @var{mutex} if the calling thread owns the lock on "
1512 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1513 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1514 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1515 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1516 "with a call to @code{unlock-mutex}. Only the last call to "
1517 "@code{unlock-mutex} will actually unlock the mutex. ")
1518 #define FUNC_NAME s_scm_unlock_mutex_timed
1520 scm_t_timespec cwaittime
, *waittime
= NULL
;
1522 SCM_VALIDATE_MUTEX (1, mx
);
1523 if (! (SCM_UNBNDP (cond
)))
1525 SCM_VALIDATE_CONDVAR (2, cond
);
1527 if (! (SCM_UNBNDP (timeout
)))
1529 to_timespec (timeout
, &cwaittime
);
1530 waittime
= &cwaittime
;
1534 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1538 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1540 "Return @code{#t} if @var{obj} is a mutex.")
1541 #define FUNC_NAME s_scm_mutex_p
1543 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1547 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1549 "Return the thread owning @var{mx}, or @code{#f}.")
1550 #define FUNC_NAME s_scm_mutex_owner
1553 fat_mutex
*m
= NULL
;
1555 SCM_VALIDATE_MUTEX (1, mx
);
1556 m
= SCM_MUTEX_DATA (mx
);
1557 scm_i_pthread_mutex_lock (&m
->lock
);
1559 scm_i_pthread_mutex_unlock (&m
->lock
);
1565 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1567 "Return the lock level of mutex @var{mx}.")
1568 #define FUNC_NAME s_scm_mutex_level
1570 SCM_VALIDATE_MUTEX (1, mx
);
1571 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1575 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1577 "Returns @code{#t} if the mutex @var{mx} is locked.")
1578 #define FUNC_NAME s_scm_mutex_locked_p
1580 SCM_VALIDATE_MUTEX (1, mx
);
1581 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1586 fat_cond_free (SCM mx
)
1588 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1589 scm_i_pthread_mutex_destroy (&c
->lock
);
1590 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1595 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1597 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1598 scm_puts ("#<condition-variable ", port
);
1599 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1600 scm_puts (">", port
);
1604 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1606 "Make a new condition variable.")
1607 #define FUNC_NAME s_scm_make_condition_variable
1612 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1613 scm_i_pthread_mutex_init (&c
->lock
, 0);
1614 c
->waiting
= SCM_EOL
;
1615 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1616 c
->waiting
= make_queue ();
1621 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1622 (SCM cv
, SCM mx
, SCM t
),
1623 "Wait until @var{cond-var} has been signalled. While waiting, "
1624 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1625 "is locked again when this function returns. When @var{time} is given, "
1626 "it specifies a point in time where the waiting should be aborted. It "
1627 "can be either a integer as returned by @code{current-time} or a pair "
1628 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1629 "mutex is locked and @code{#f} is returned. When the condition "
1630 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1632 #define FUNC_NAME s_scm_timed_wait_condition_variable
1634 scm_t_timespec waittime
, *waitptr
= NULL
;
1636 SCM_VALIDATE_CONDVAR (1, cv
);
1637 SCM_VALIDATE_MUTEX (2, mx
);
1639 if (!SCM_UNBNDP (t
))
1641 to_timespec (t
, &waittime
);
1642 waitptr
= &waittime
;
1645 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1650 fat_cond_signal (fat_cond
*c
)
1652 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1653 unblock_from_queue (c
->waiting
);
1654 scm_i_pthread_mutex_unlock (&c
->lock
);
1657 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1659 "Wake up one thread that is waiting for @var{cv}")
1660 #define FUNC_NAME s_scm_signal_condition_variable
1662 SCM_VALIDATE_CONDVAR (1, cv
);
1663 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1669 fat_cond_broadcast (fat_cond
*c
)
1671 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1672 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1674 scm_i_pthread_mutex_unlock (&c
->lock
);
1677 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1679 "Wake up all threads that are waiting for @var{cv}. ")
1680 #define FUNC_NAME s_scm_broadcast_condition_variable
1682 SCM_VALIDATE_CONDVAR (1, cv
);
1683 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1688 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1690 "Return @code{#t} if @var{obj} is a condition variable.")
1691 #define FUNC_NAME s_scm_condition_variable_p
1693 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1697 /*** Marking stacks */
1699 /* XXX - what to do with this? Do we need to handle this for blocked
1703 # define SCM_MARK_BACKING_STORE() do { \
1705 SCM_STACKITEM * top, * bot; \
1706 getcontext (&ctx); \
1707 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1708 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1709 / sizeof (SCM_STACKITEM))); \
1710 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1711 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1712 scm_mark_locations (bot, top - bot); } while (0)
1714 # define SCM_MARK_BACKING_STORE()
1722 scm_std_select (int nfds
,
1723 SELECT_TYPE
*readfds
,
1724 SELECT_TYPE
*writefds
,
1725 SELECT_TYPE
*exceptfds
,
1726 struct timeval
*timeout
)
1729 int res
, eno
, wakeup_fd
;
1730 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1731 scm_t_guile_ticket ticket
;
1733 if (readfds
== NULL
)
1735 FD_ZERO (&my_readfds
);
1736 readfds
= &my_readfds
;
1739 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1742 wakeup_fd
= t
->sleep_pipe
[0];
1743 ticket
= scm_leave_guile ();
1744 FD_SET (wakeup_fd
, readfds
);
1745 if (wakeup_fd
>= nfds
)
1747 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1750 scm_enter_guile (ticket
);
1752 scm_i_reset_sleep (t
);
1754 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1757 read (wakeup_fd
, &dummy
, 1);
1758 FD_CLR (wakeup_fd
, readfds
);
1770 /* Convenience API for blocking while in guile mode. */
1772 #if SCM_USE_PTHREAD_THREADS
1775 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1777 scm_t_guile_ticket t
= scm_leave_guile ();
1778 int res
= scm_i_pthread_mutex_lock (mutex
);
1779 scm_enter_guile (t
);
1784 do_unlock (void *data
)
1786 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1790 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1792 scm_i_scm_pthread_mutex_lock (mutex
);
1793 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1797 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1799 scm_t_guile_ticket t
= scm_leave_guile ();
1800 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1801 scm_enter_guile (t
);
1806 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1807 scm_i_pthread_mutex_t
*mutex
,
1808 const scm_t_timespec
*wt
)
1810 scm_t_guile_ticket t
= scm_leave_guile ();
1811 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1812 scm_enter_guile (t
);
1819 scm_std_usleep (unsigned long usecs
)
1822 tv
.tv_usec
= usecs
% 1000000;
1823 tv
.tv_sec
= usecs
/ 1000000;
1824 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1825 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1829 scm_std_sleep (unsigned int secs
)
1834 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1840 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1842 "Return the thread that called this function.")
1843 #define FUNC_NAME s_scm_current_thread
1845 return SCM_I_CURRENT_THREAD
->handle
;
1850 scm_c_make_list (size_t n
, SCM fill
)
1854 res
= scm_cons (fill
, res
);
1858 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1860 "Return a list of all threads.")
1861 #define FUNC_NAME s_scm_all_threads
1863 /* We can not allocate while holding the thread_admin_mutex because
1864 of the way GC is done.
1866 int n
= thread_count
;
1868 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1870 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1872 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1874 if (t
!= scm_i_signal_delivery_thread
)
1876 SCM_SETCAR (*l
, t
->handle
);
1877 l
= SCM_CDRLOC (*l
);
1882 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1887 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1889 "Return @code{#t} iff @var{thread} has exited.\n")
1890 #define FUNC_NAME s_scm_thread_exited_p
1892 return scm_from_bool (scm_c_thread_exited_p (thread
));
1897 scm_c_thread_exited_p (SCM thread
)
1898 #define FUNC_NAME s_scm_thread_exited_p
1901 SCM_VALIDATE_THREAD (1, thread
);
1902 t
= SCM_I_THREAD_DATA (thread
);
1907 static scm_i_pthread_cond_t wake_up_cond
;
1908 static int threads_initialized_p
= 0;
1911 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1913 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1914 int scm_i_critical_section_level
= 0;
1916 static SCM dynwind_critical_section_mutex
;
1919 scm_dynwind_critical_section (SCM mutex
)
1921 if (scm_is_false (mutex
))
1922 mutex
= dynwind_critical_section_mutex
;
1923 scm_dynwind_lock_mutex (mutex
);
1924 scm_dynwind_block_asyncs ();
1927 /*** Initialization */
1929 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1931 #if SCM_USE_PTHREAD_THREADS
1932 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1936 scm_threads_prehistory (SCM_STACKITEM
*base
)
1938 #if SCM_USE_PTHREAD_THREADS
1939 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
1940 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
1941 PTHREAD_MUTEX_RECURSIVE
);
1944 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
1945 scm_i_pthread_mutexattr_recursive
);
1946 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1947 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1949 guilify_self_1 (base
);
1952 scm_t_bits scm_tc16_thread
;
1953 scm_t_bits scm_tc16_mutex
;
1954 scm_t_bits scm_tc16_condvar
;
1959 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1960 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1961 scm_set_smob_free (scm_tc16_thread
, thread_free
); /* XXX: Could be removed */
1963 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1964 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1965 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1967 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1969 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1970 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1972 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1973 guilify_self_2 (SCM_BOOL_F
);
1974 threads_initialized_p
= 1;
1976 dynwind_critical_section_mutex
=
1977 scm_permanent_object (scm_make_recursive_mutex ());
1981 scm_init_threads_default_dynamic_state ()
1983 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
1984 scm_i_default_dynamic_state
= scm_permanent_object (state
);
1988 scm_init_thread_procs ()
1990 #include "libguile/threads.x"