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/_scm.h"
33 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
40 #include "libguile/validate.h"
41 #include "libguile/root.h"
42 #include "libguile/eval.h"
43 #include "libguile/async.h"
44 #include "libguile/ports.h"
45 #include "libguile/threads.h"
46 #include "libguile/dynwind.h"
47 #include "libguile/iselect.h"
48 #include "libguile/fluids.h"
49 #include "libguile/continuations.h"
50 #include "libguile/gc.h"
51 #include "libguile/init.h"
52 #include "libguile/scmsigs.h"
53 #include "libguile/strings.h"
57 # define ETIMEDOUT WSAETIMEDOUT
61 # define pipe(fd) _pipe (fd, 256, O_BINARY)
62 #endif /* __MINGW32__ */
65 to_timespec (SCM t
, scm_t_timespec
*waittime
)
69 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
70 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
74 double time
= scm_to_double (t
);
75 double sec
= scm_c_truncate (time
);
77 waittime
->tv_sec
= (long) sec
;
78 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
84 /* Make an empty queue data structure.
89 return scm_cons (SCM_EOL
, SCM_EOL
);
92 /* Put T at the back of Q and return a handle that can be used with
93 remqueue to remove T from Q again.
96 enqueue (SCM q
, SCM t
)
98 SCM c
= scm_cons (t
, SCM_EOL
);
99 if (scm_is_null (SCM_CDR (q
)))
102 SCM_SETCDR (SCM_CAR (q
), c
);
107 /* Remove the element that the handle C refers to from the queue Q. C
108 must have been returned from a call to enqueue. The return value
109 is zero when the element referred to by C has already been removed.
110 Otherwise, 1 is returned.
113 remqueue (SCM q
, SCM c
)
116 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
118 if (scm_is_eq (p
, c
))
120 if (scm_is_eq (c
, SCM_CAR (q
)))
121 SCM_SETCAR (q
, SCM_CDR (c
));
122 SCM_SETCDR (prev
, SCM_CDR (c
));
130 /* Remove the front-most element from the queue Q and return it.
131 Return SCM_BOOL_F when Q is empty.
141 SCM_SETCDR (q
, SCM_CDR (c
));
142 if (scm_is_null (SCM_CDR (q
)))
143 SCM_SETCAR (q
, SCM_EOL
);
148 /*** Thread smob routines */
151 thread_mark (SCM obj
)
153 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
154 scm_gc_mark (t
->result
);
155 scm_gc_mark (t
->cleanup_handler
);
156 scm_gc_mark (t
->join_queue
);
157 scm_gc_mark (t
->mutexes
);
158 scm_gc_mark (t
->dynwinds
);
159 scm_gc_mark (t
->active_asyncs
);
160 scm_gc_mark (t
->continuation_root
);
161 return t
->dynamic_state
;
165 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
167 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
168 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
169 the struct case, hence we go via a union, and extract according to the
170 size of pthread_t. */
178 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
179 scm_i_pthread_t p
= t
->pthread
;
182 if (sizeof (p
) == sizeof (unsigned short))
184 else if (sizeof (p
) == sizeof (unsigned int))
186 else if (sizeof (p
) == sizeof (unsigned long))
191 scm_puts ("#<thread ", port
);
192 scm_uintprint (id
, 10, port
);
193 scm_puts (" (", port
);
194 scm_uintprint ((scm_t_bits
)t
, 16, port
);
195 scm_puts (")>", port
);
200 thread_free (SCM obj
)
202 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
204 scm_gc_free (t
, sizeof (*t
), "thread");
208 /*** Blocking on queues. */
210 /* See also scm_i_queue_async_cell for how such a block is
214 /* Put the current thread on QUEUE and go to sleep, waiting for it to
215 be woken up by a call to 'unblock_from_queue', or to be
216 interrupted. Upon return of this function, the current thread is
217 no longer on QUEUE, even when the sleep has been interrupted.
219 The QUEUE data structure is assumed to be protected by MUTEX and
220 the caller of block_self must hold MUTEX. It will be atomically
221 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
223 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
226 When WAITTIME is not NULL, the sleep will be aborted at that time.
228 The return value of block_self is an errno value. It will be zero
229 when the sleep has been successfully completed by a call to
230 unblock_from_queue, EINTR when it has been interrupted by the
231 delivery of a system async, and ETIMEDOUT when the timeout has
234 The system asyncs themselves are not executed by block_self.
237 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
238 const scm_t_timespec
*waittime
)
240 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
244 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
249 q_handle
= enqueue (queue
, t
->handle
);
250 if (waittime
== NULL
)
251 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
253 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
255 /* When we are still on QUEUE, we have been interrupted. We
256 report this only when no other error (such as a timeout) has
259 if (remqueue (queue
, q_handle
) && err
== 0)
262 scm_i_reset_sleep (t
);
268 /* Wake up the first thread on QUEUE, if any. The caller must hold
269 the mutex that protects QUEUE. The awoken thread is returned, or
270 #f when the queue was empty.
273 unblock_from_queue (SCM queue
)
275 SCM thread
= dequeue (queue
);
276 if (scm_is_true (thread
))
277 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
281 /* Getting into and out of guile mode.
284 /* Ken Raeburn observes that the implementation of suspend and resume
285 (and the things that build on top of them) are very likely not
286 correct (see below). We will need fix this eventually, and that's
287 why scm_leave_guile/scm_enter_guile are not exported in the API.
291 Consider this sequence:
293 Function foo, called in Guile mode, calls suspend (maybe indirectly
294 through scm_leave_guile), which does this:
296 // record top of stack for the GC
297 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
300 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
301 setjmp (t->regs); // here's most of the magic
305 Function foo has a SCM value X, a handle on a non-immediate object, in
306 a caller-saved register R, and it's the only reference to the object
309 The compiler wants to use R in suspend, so it pushes the current
310 value, X, into a stack slot which will be reloaded on exit from
311 suspend; then it loads stuff into R and goes about its business. The
312 setjmp call saves (some of) the current registers, including R, which
313 no longer contains X. (This isn't a problem for a normal
314 setjmp/longjmp situation, where longjmp would be called before
315 setjmp's caller returns; the old value for X would be loaded back from
316 the stack after the longjmp, before the function returned.)
318 So, suspend returns, loading X back into R (and invalidating the jump
319 buffer) in the process. The caller foo then goes off and calls a
320 bunch of other functions out of Guile mode, occasionally storing X on
321 the stack again, but, say, much deeper on the stack than suspend's
322 stack frame went, and the stack slot where suspend had written X has
323 long since been overwritten with other values.
325 Okay, nothing actively broken so far. Now, let garbage collection
326 run, triggered by another thread.
328 The thread calling foo is out of Guile mode at the time, so the
329 garbage collector just scans a range of stack addresses. Too bad that
330 X isn't stored there. So the pointed-to storage goes onto the free
331 list, and I think you can see where things go from there.
333 Is there anything I'm missing that'll prevent this scenario from
334 happening? I mean, aside from, "well, suspend and scm_leave_guile
335 don't have many local variables, so they probably won't need to save
336 any registers on most systems, so we hope everything will wind up in
337 the jump buffer and we'll just get away with it"?
339 (And, going the other direction, if scm_leave_guile and suspend push
340 the stack pointer over onto a new page, and foo doesn't make further
341 function calls and thus the stack pointer no longer includes that
342 page, are we guaranteed that the kernel cannot release the now-unused
343 stack page that contains the top-of-stack pointer we just saved? I
344 don't know if any OS actually does that. If it does, we could get
345 faults in garbage collection.)
347 I don't think scm_without_guile has to have this problem, as it gets
348 more control over the stack handling -- but it should call setjmp
349 itself. I'd probably try something like:
351 // record top of stack for the GC
352 t->top = SCM_STACK_PTR (&t);
354 SCM_FLUSH_REGISTER_WINDOWS;
359 ... though even that's making some assumptions about the stack
360 ordering of local variables versus caller-saved registers.
362 For something like scm_leave_guile to work, I don't think it can just
363 rely on invalidated jump buffers. A valid jump buffer, and a handle
364 on the stack state at the point when the jump buffer was initialized,
365 together, would work fine, but I think then we're talking about macros
366 invoking setjmp in the caller's stack frame, and requiring that the
367 caller of scm_leave_guile also call scm_enter_guile before returning,
368 kind of like pthread_cleanup_push/pop calls that have to be paired up
369 in a function. (In fact, the pthread ones have to be paired up
370 syntactically, as if they might expand to a compound statement
371 incorporating the user's code, and invoking a compiler's
372 exception-handling primitives. Which might be something to think
373 about for cases where Guile is used with C++ exceptions or
377 scm_i_pthread_key_t scm_i_thread_key
;
380 resume (scm_i_thread
*t
)
383 if (t
->clear_freelists_p
)
385 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
386 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
387 t
->clear_freelists_p
= 0;
391 typedef void* scm_t_guile_ticket
;
394 scm_enter_guile (scm_t_guile_ticket ticket
)
396 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
399 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
404 static scm_i_thread
*
407 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
409 /* record top of stack for the GC */
410 t
->top
= SCM_STACK_PTR (&t
);
411 /* save registers. */
412 SCM_FLUSH_REGISTER_WINDOWS
;
417 static scm_t_guile_ticket
420 scm_i_thread
*t
= suspend ();
421 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
422 return (scm_t_guile_ticket
) t
;
425 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
426 static scm_i_thread
*all_threads
= NULL
;
427 static int thread_count
;
429 static SCM scm_i_default_dynamic_state
;
431 /* Perform first stage of thread initialisation, in non-guile mode.
434 guilify_self_1 (SCM_STACKITEM
*base
)
436 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
438 t
->pthread
= scm_i_pthread_self ();
439 t
->handle
= SCM_BOOL_F
;
440 t
->result
= SCM_BOOL_F
;
441 t
->cleanup_handler
= SCM_BOOL_F
;
442 t
->mutexes
= SCM_EOL
;
443 t
->join_queue
= SCM_EOL
;
444 t
->dynamic_state
= SCM_BOOL_F
;
445 t
->dynwinds
= SCM_EOL
;
446 t
->active_asyncs
= SCM_EOL
;
448 t
->pending_asyncs
= 1;
449 t
->last_debug_frame
= NULL
;
452 /* Calculate and store off the base of this thread's register
453 backing store (RBS). Unfortunately our implementation(s) of
454 scm_ia64_register_backing_store_base are only reliable for the
455 main thread. For other threads, therefore, find out the current
456 top of the RBS, and use that as a maximum. */
457 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
462 bsp
= scm_ia64_ar_bsp (&ctx
);
463 if (t
->register_backing_store_base
> bsp
)
464 t
->register_backing_store_base
= bsp
;
467 t
->continuation_root
= SCM_EOL
;
468 t
->continuation_base
= base
;
469 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
470 t
->sleep_mutex
= NULL
;
471 t
->sleep_object
= SCM_BOOL_F
;
473 /* XXX - check for errors. */
474 pipe (t
->sleep_pipe
);
475 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
476 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
477 t
->clear_freelists_p
= 0;
482 t
->freelist
= SCM_EOL
;
483 t
->freelist2
= SCM_EOL
;
484 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
485 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
487 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
489 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
491 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
492 t
->next_thread
= all_threads
;
495 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
498 /* Perform second stage of thread initialisation, in guile mode.
501 guilify_self_2 (SCM parent
)
503 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
505 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
506 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
507 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
508 t
->continuation_base
= t
->base
;
510 if (scm_is_true (parent
))
511 t
->dynamic_state
= scm_make_dynamic_state (parent
);
513 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
515 t
->join_queue
= make_queue ();
522 /* We implement our own mutex type since we want them to be 'fair', we
523 want to do fancy things while waiting for them (like running
524 asyncs) and we might want to add things that are nice for
529 scm_i_pthread_mutex_t lock
;
531 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
533 int recursive
; /* allow recursive locking? */
534 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
535 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
536 owned by the current thread? */
538 SCM waiting
; /* the threads waiting for this mutex. */
541 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
542 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
544 /* Perform thread tear-down, in guile mode.
547 do_thread_exit (void *v
)
549 scm_i_thread
*t
= (scm_i_thread
*) v
;
551 if (!scm_is_false (t
->cleanup_handler
))
553 SCM ptr
= t
->cleanup_handler
;
555 t
->cleanup_handler
= SCM_BOOL_F
;
556 t
->result
= scm_internal_catch (SCM_BOOL_T
,
557 (scm_t_catch_body
) scm_call_0
, ptr
,
558 scm_handle_by_message_noexit
, NULL
);
561 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
564 close (t
->sleep_pipe
[0]);
565 close (t
->sleep_pipe
[1]);
566 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
569 while (!scm_is_null (t
->mutexes
))
571 SCM mutex
= SCM_CAR (t
->mutexes
);
572 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
573 scm_i_pthread_mutex_lock (&m
->lock
);
575 unblock_from_queue (m
->waiting
);
577 scm_i_pthread_mutex_unlock (&m
->lock
);
578 t
->mutexes
= SCM_CDR (t
->mutexes
);
581 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
587 on_thread_exit (void *v
)
589 /* This handler is executed in non-guile mode. */
590 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
592 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
594 /* Ensure the signal handling thread has been launched, because we might be
596 scm_i_ensure_signal_delivery_thread ();
598 /* Unblocking the joining threads needs to happen in guile mode
599 since the queue is a SCM data structure. */
600 scm_with_guile (do_thread_exit
, v
);
602 /* Removing ourself from the list of all threads needs to happen in
603 non-guile mode since all SCM values on our stack become
604 unprotected once we are no longer in the list. */
605 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
606 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
609 *tp
= t
->next_thread
;
614 /* If there's only one other thread, it could be the signal delivery
615 thread, so we need to notify it to shut down by closing its read pipe.
616 If it's not the signal delivery thread, then closing the read pipe isn't
618 if (thread_count
<= 1)
619 scm_i_close_signal_pipe ();
621 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
623 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
626 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
629 init_thread_key (void)
631 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
634 /* Perform any initializations necessary to bring the current thread
635 into guile mode, initializing Guile itself, if necessary.
637 BASE is the stack base to use with GC.
639 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
640 which case the default dynamic state is used.
642 Return zero when the thread was in guile mode already; otherwise
647 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
651 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
653 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
655 /* This thread has not been guilified yet.
658 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
659 if (scm_initialized_p
== 0)
661 /* First thread ever to enter Guile. Run the full
664 scm_i_init_guile (base
);
665 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
669 /* Guile is already initialized, but this thread enters it for
670 the first time. Only initialize this thread.
672 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
673 guilify_self_1 (base
);
674 guilify_self_2 (parent
);
680 /* This thread is already guilified but not in guile mode, just
683 XXX - base might be lower than when this thread was first
686 scm_enter_guile ((scm_t_guile_ticket
) t
);
691 /* Thread is already in guile mode. Nothing to do.
697 #if SCM_USE_PTHREAD_THREADS
699 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
700 /* This method for GNU/Linux and perhaps some other systems.
701 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
702 available on them. */
703 #define HAVE_GET_THREAD_STACK_BASE
705 static SCM_STACKITEM
*
706 get_thread_stack_base ()
712 pthread_getattr_np (pthread_self (), &attr
);
713 pthread_attr_getstack (&attr
, &start
, &size
);
714 end
= (char *)start
+ size
;
716 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
717 for the main thread, but we can use scm_get_stack_base in that
721 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
722 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
723 return scm_get_stack_base ();
727 #if SCM_STACK_GROWS_UP
735 #elif HAVE_PTHREAD_GET_STACKADDR_NP
736 /* This method for MacOS X.
737 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
738 but as of 2006 there's nothing obvious at apple.com. */
739 #define HAVE_GET_THREAD_STACK_BASE
740 static SCM_STACKITEM
*
741 get_thread_stack_base ()
743 return pthread_get_stackaddr_np (pthread_self ());
746 #elif defined (__MINGW32__)
747 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
748 in any thread. We don't like hard-coding the name of a system, but there
749 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
751 #define HAVE_GET_THREAD_STACK_BASE
752 static SCM_STACKITEM
*
753 get_thread_stack_base ()
755 return scm_get_stack_base ();
758 #endif /* pthread methods of get_thread_stack_base */
760 #else /* !SCM_USE_PTHREAD_THREADS */
762 #define HAVE_GET_THREAD_STACK_BASE
764 static SCM_STACKITEM
*
765 get_thread_stack_base ()
767 return scm_get_stack_base ();
770 #endif /* !SCM_USE_PTHREAD_THREADS */
772 #ifdef HAVE_GET_THREAD_STACK_BASE
777 scm_i_init_thread_for_guile (get_thread_stack_base (),
778 scm_i_default_dynamic_state
);
784 scm_with_guile (void *(*func
)(void *), void *data
)
786 return scm_i_with_guile_and_parent (func
, data
,
787 scm_i_default_dynamic_state
);
790 SCM_UNUSED
static void
791 scm_leave_guile_cleanup (void *x
)
797 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
801 SCM_STACKITEM base_item
;
803 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
806 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
807 res
= scm_c_with_continuation_barrier (func
, data
);
808 scm_i_pthread_cleanup_pop (0);
812 res
= scm_c_with_continuation_barrier (func
, data
);
818 scm_without_guile (void *(*func
)(void *), void *data
)
821 scm_t_guile_ticket t
;
822 t
= scm_leave_guile ();
828 /*** Thread creation */
835 scm_i_pthread_mutex_t mutex
;
836 scm_i_pthread_cond_t cond
;
840 really_launch (void *d
)
842 launch_data
*data
= (launch_data
*)d
;
843 SCM thunk
= data
->thunk
, handler
= data
->handler
;
846 t
= SCM_I_CURRENT_THREAD
;
848 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
849 data
->thread
= scm_current_thread ();
850 scm_i_pthread_cond_signal (&data
->cond
);
851 scm_i_pthread_mutex_unlock (&data
->mutex
);
853 if (SCM_UNBNDP (handler
))
854 t
->result
= scm_call_0 (thunk
);
856 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
862 launch_thread (void *d
)
864 launch_data
*data
= (launch_data
*)d
;
865 scm_i_pthread_detach (scm_i_pthread_self ());
866 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
870 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
871 (SCM thunk
, SCM handler
),
872 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
873 "returning a new thread object representing the thread. The procedure\n"
874 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
876 "When @var{handler} is specified, then @var{thunk} is called from\n"
877 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
878 "handler. This catch is established inside the continuation barrier.\n"
880 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
881 "the @emph{exit value} of the thread and the thread is terminated.")
882 #define FUNC_NAME s_scm_call_with_new_thread
888 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
889 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
890 handler
, SCM_ARG2
, FUNC_NAME
);
892 data
.parent
= scm_current_dynamic_state ();
894 data
.handler
= handler
;
895 data
.thread
= SCM_BOOL_F
;
896 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
897 scm_i_pthread_cond_init (&data
.cond
, NULL
);
899 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
900 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
903 scm_i_pthread_mutex_unlock (&data
.mutex
);
907 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
908 scm_i_pthread_mutex_unlock (&data
.mutex
);
916 scm_t_catch_body body
;
918 scm_t_catch_handler handler
;
921 scm_i_pthread_mutex_t mutex
;
922 scm_i_pthread_cond_t cond
;
926 really_spawn (void *d
)
928 spawn_data
*data
= (spawn_data
*)d
;
929 scm_t_catch_body body
= data
->body
;
930 void *body_data
= data
->body_data
;
931 scm_t_catch_handler handler
= data
->handler
;
932 void *handler_data
= data
->handler_data
;
933 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
935 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
936 data
->thread
= scm_current_thread ();
937 scm_i_pthread_cond_signal (&data
->cond
);
938 scm_i_pthread_mutex_unlock (&data
->mutex
);
941 t
->result
= body (body_data
);
943 t
->result
= scm_internal_catch (SCM_BOOL_T
,
945 handler
, handler_data
);
951 spawn_thread (void *d
)
953 spawn_data
*data
= (spawn_data
*)d
;
954 scm_i_pthread_detach (scm_i_pthread_self ());
955 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
960 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
961 scm_t_catch_handler handler
, void *handler_data
)
967 data
.parent
= scm_current_dynamic_state ();
969 data
.body_data
= body_data
;
970 data
.handler
= handler
;
971 data
.handler_data
= handler_data
;
972 data
.thread
= SCM_BOOL_F
;
973 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
974 scm_i_pthread_cond_init (&data
.cond
, NULL
);
976 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
977 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
980 scm_i_pthread_mutex_unlock (&data
.mutex
);
984 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
985 scm_i_pthread_mutex_unlock (&data
.mutex
);
990 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
992 "Move the calling thread to the end of the scheduling queue.")
993 #define FUNC_NAME s_scm_yield
995 return scm_from_bool (scm_i_sched_yield ());
999 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1001 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1002 "cannot be the current thread, and if @var{thread} has already terminated or "
1003 "been signaled to terminate, this function is a no-op.")
1004 #define FUNC_NAME s_scm_cancel_thread
1006 scm_i_thread
*t
= NULL
;
1008 SCM_VALIDATE_THREAD (1, thread
);
1009 t
= SCM_I_THREAD_DATA (thread
);
1010 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1014 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1015 scm_i_pthread_cancel (t
->pthread
);
1018 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1020 return SCM_UNSPECIFIED
;
1024 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1025 (SCM thread
, SCM proc
),
1026 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1027 "This handler will be called when the thread exits.")
1028 #define FUNC_NAME s_scm_set_thread_cleanup_x
1032 SCM_VALIDATE_THREAD (1, thread
);
1033 if (!scm_is_false (proc
))
1034 SCM_VALIDATE_THUNK (2, proc
);
1036 t
= SCM_I_THREAD_DATA (thread
);
1037 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1039 if (!(t
->exited
|| t
->canceled
))
1040 t
->cleanup_handler
= proc
;
1042 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1044 return SCM_UNSPECIFIED
;
1048 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1050 "Return the cleanup handler installed for the thread @var{thread}.")
1051 #define FUNC_NAME s_scm_thread_cleanup
1056 SCM_VALIDATE_THREAD (1, thread
);
1058 t
= SCM_I_THREAD_DATA (thread
);
1059 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1060 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1061 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1067 SCM
scm_join_thread (SCM thread
)
1069 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1072 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1073 (SCM thread
, SCM timeout
, SCM timeoutval
),
1074 "Suspend execution of the calling thread until the target @var{thread} "
1075 "terminates, unless the target @var{thread} has already terminated. ")
1076 #define FUNC_NAME s_scm_join_thread_timed
1079 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1080 SCM res
= SCM_BOOL_F
;
1082 if (! (SCM_UNBNDP (timeoutval
)))
1085 SCM_VALIDATE_THREAD (1, thread
);
1086 if (scm_is_eq (scm_current_thread (), thread
))
1087 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1089 t
= SCM_I_THREAD_DATA (thread
);
1090 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1092 if (! SCM_UNBNDP (timeout
))
1094 to_timespec (timeout
, &ctimeout
);
1095 timeout_ptr
= &ctimeout
;
1104 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1114 else if (err
== ETIMEDOUT
)
1117 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1119 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1123 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1129 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1131 "Return @code{#t} if @var{obj} is a thread.")
1132 #define FUNC_NAME s_scm_thread_p
1134 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1139 fat_mutex_mark (SCM mx
)
1141 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1142 scm_gc_mark (m
->owner
);
1147 fat_mutex_free (SCM mx
)
1149 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1150 scm_i_pthread_mutex_destroy (&m
->lock
);
1151 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1156 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1158 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1159 scm_puts ("#<mutex ", port
);
1160 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1161 scm_puts (">", port
);
1166 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1171 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1172 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1173 m
->owner
= SCM_BOOL_F
;
1176 m
->recursive
= recursive
;
1177 m
->unchecked_unlock
= unchecked_unlock
;
1178 m
->allow_external_unlock
= external_unlock
;
1180 m
->waiting
= SCM_EOL
;
1181 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1182 m
->waiting
= make_queue ();
1186 SCM
scm_make_mutex (void)
1188 return scm_make_mutex_with_flags (SCM_EOL
);
1191 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1192 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1193 SCM_SYMBOL (recursive_sym
, "recursive");
1195 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1197 "Create a new mutex. ")
1198 #define FUNC_NAME s_scm_make_mutex_with_flags
1200 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1203 while (! scm_is_null (ptr
))
1205 SCM flag
= SCM_CAR (ptr
);
1206 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1207 unchecked_unlock
= 1;
1208 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1209 external_unlock
= 1;
1210 else if (scm_is_eq (flag
, recursive_sym
))
1213 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1214 ptr
= SCM_CDR (ptr
);
1216 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1220 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1222 "Create a new recursive mutex. ")
1223 #define FUNC_NAME s_scm_make_recursive_mutex
1225 return make_fat_mutex (1, 0, 0);
1229 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1232 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1234 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1236 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1237 SCM err
= SCM_BOOL_F
;
1239 struct timeval current_time
;
1241 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1247 m
->owner
= new_owner
;
1250 if (SCM_I_IS_THREAD (new_owner
))
1252 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1253 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1254 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1255 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1260 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1262 m
->owner
= new_owner
;
1263 err
= scm_cons (scm_abandoned_mutex_error_key
,
1264 scm_from_locale_string ("lock obtained on abandoned "
1269 else if (scm_is_eq (m
->owner
, new_owner
))
1278 err
= scm_cons (scm_misc_error_key
,
1279 scm_from_locale_string ("mutex already locked "
1287 if (timeout
!= NULL
)
1289 gettimeofday (¤t_time
, NULL
);
1290 if (current_time
.tv_sec
> timeout
->tv_sec
||
1291 (current_time
.tv_sec
== timeout
->tv_sec
&&
1292 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1298 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1299 scm_i_pthread_mutex_unlock (&m
->lock
);
1301 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1304 scm_i_pthread_mutex_unlock (&m
->lock
);
1308 SCM
scm_lock_mutex (SCM mx
)
1310 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1313 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1314 (SCM m
, SCM timeout
, SCM owner
),
1315 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1316 "blocks until the mutex becomes available. The function returns when "
1317 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1318 "a thread already owns will succeed right away and will not block the "
1319 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1320 #define FUNC_NAME s_scm_lock_mutex_timed
1324 scm_t_timespec cwaittime
, *waittime
= NULL
;
1326 SCM_VALIDATE_MUTEX (1, m
);
1328 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1330 to_timespec (timeout
, &cwaittime
);
1331 waittime
= &cwaittime
;
1334 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1335 if (!scm_is_false (exception
))
1336 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1337 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1342 scm_dynwind_lock_mutex (SCM mutex
)
1344 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1345 SCM_F_WIND_EXPLICITLY
);
1346 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1347 SCM_F_WIND_EXPLICITLY
);
1350 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1352 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1353 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1354 #define FUNC_NAME s_scm_try_mutex
1358 scm_t_timespec cwaittime
, *waittime
= NULL
;
1360 SCM_VALIDATE_MUTEX (1, mutex
);
1362 to_timespec (scm_from_int(0), &cwaittime
);
1363 waittime
= &cwaittime
;
1365 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1366 if (!scm_is_false (exception
))
1367 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1368 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1372 /*** Fat condition variables */
1375 scm_i_pthread_mutex_t lock
;
1376 SCM waiting
; /* the threads waiting for this condition. */
1379 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1380 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1383 fat_mutex_unlock (SCM mutex
, SCM cond
,
1384 const scm_t_timespec
*waittime
, int relock
)
1386 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1388 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1389 int err
= 0, ret
= 0;
1391 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1393 SCM owner
= m
->owner
;
1395 if (!scm_is_eq (owner
, scm_current_thread ()))
1399 if (!m
->unchecked_unlock
)
1401 scm_i_pthread_mutex_unlock (&m
->lock
);
1402 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1404 owner
= scm_current_thread ();
1406 else if (!m
->allow_external_unlock
)
1408 scm_i_pthread_mutex_unlock (&m
->lock
);
1409 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1413 if (! (SCM_UNBNDP (cond
)))
1415 c
= SCM_CONDVAR_DATA (cond
);
1420 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1424 m
->owner
= unblock_from_queue (m
->waiting
);
1426 scm_i_pthread_mutex_unlock (&m
->lock
);
1430 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1437 else if (err
== ETIMEDOUT
)
1442 else if (err
!= EINTR
)
1445 scm_i_pthread_mutex_unlock (&c
->lock
);
1446 scm_syserror (NULL
);
1452 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1453 scm_i_pthread_mutex_unlock (&c
->lock
);
1457 scm_i_pthread_mutex_unlock (&c
->lock
);
1462 scm_remember_upto_here_2 (cond
, mutex
);
1464 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1472 m
->owner
= unblock_from_queue (m
->waiting
);
1474 scm_i_pthread_mutex_unlock (&m
->lock
);
1481 SCM
scm_unlock_mutex (SCM mx
)
1483 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1486 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1487 (SCM mx
, SCM cond
, SCM timeout
),
1488 "Unlocks @var{mutex} if the calling thread owns the lock on "
1489 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1490 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1491 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1492 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1493 "with a call to @code{unlock-mutex}. Only the last call to "
1494 "@code{unlock-mutex} will actually unlock the mutex. ")
1495 #define FUNC_NAME s_scm_unlock_mutex_timed
1497 scm_t_timespec cwaittime
, *waittime
= NULL
;
1499 SCM_VALIDATE_MUTEX (1, mx
);
1500 if (! (SCM_UNBNDP (cond
)))
1502 SCM_VALIDATE_CONDVAR (2, cond
);
1504 if (! (SCM_UNBNDP (timeout
)))
1506 to_timespec (timeout
, &cwaittime
);
1507 waittime
= &cwaittime
;
1511 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1515 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1517 "Return @code{#t} if @var{obj} is a mutex.")
1518 #define FUNC_NAME s_scm_mutex_p
1520 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1524 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1526 "Return the thread owning @var{mx}, or @code{#f}.")
1527 #define FUNC_NAME s_scm_mutex_owner
1530 fat_mutex
*m
= NULL
;
1532 SCM_VALIDATE_MUTEX (1, mx
);
1533 m
= SCM_MUTEX_DATA (mx
);
1534 scm_i_pthread_mutex_lock (&m
->lock
);
1536 scm_i_pthread_mutex_unlock (&m
->lock
);
1542 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1544 "Return the lock level of mutex @var{mx}.")
1545 #define FUNC_NAME s_scm_mutex_level
1547 SCM_VALIDATE_MUTEX (1, mx
);
1548 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1552 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1554 "Returns @code{#t} if the mutex @var{mx} is locked.")
1555 #define FUNC_NAME s_scm_mutex_locked_p
1557 SCM_VALIDATE_MUTEX (1, mx
);
1558 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1563 fat_cond_mark (SCM cv
)
1565 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1570 fat_cond_free (SCM mx
)
1572 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1573 scm_i_pthread_mutex_destroy (&c
->lock
);
1574 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1579 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1581 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1582 scm_puts ("#<condition-variable ", port
);
1583 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1584 scm_puts (">", port
);
1588 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1590 "Make a new condition variable.")
1591 #define FUNC_NAME s_scm_make_condition_variable
1596 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1597 scm_i_pthread_mutex_init (&c
->lock
, 0);
1598 c
->waiting
= SCM_EOL
;
1599 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1600 c
->waiting
= make_queue ();
1605 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1606 (SCM cv
, SCM mx
, SCM t
),
1607 "Wait until @var{cond-var} has been signalled. While waiting, "
1608 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1609 "is locked again when this function returns. When @var{time} is given, "
1610 "it specifies a point in time where the waiting should be aborted. It "
1611 "can be either a integer as returned by @code{current-time} or a pair "
1612 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1613 "mutex is locked and @code{#f} is returned. When the condition "
1614 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1616 #define FUNC_NAME s_scm_timed_wait_condition_variable
1618 scm_t_timespec waittime
, *waitptr
= NULL
;
1620 SCM_VALIDATE_CONDVAR (1, cv
);
1621 SCM_VALIDATE_MUTEX (2, mx
);
1623 if (!SCM_UNBNDP (t
))
1625 to_timespec (t
, &waittime
);
1626 waitptr
= &waittime
;
1629 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1634 fat_cond_signal (fat_cond
*c
)
1636 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1637 unblock_from_queue (c
->waiting
);
1638 scm_i_pthread_mutex_unlock (&c
->lock
);
1641 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1643 "Wake up one thread that is waiting for @var{cv}")
1644 #define FUNC_NAME s_scm_signal_condition_variable
1646 SCM_VALIDATE_CONDVAR (1, cv
);
1647 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1653 fat_cond_broadcast (fat_cond
*c
)
1655 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1656 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1658 scm_i_pthread_mutex_unlock (&c
->lock
);
1661 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1663 "Wake up all threads that are waiting for @var{cv}. ")
1664 #define FUNC_NAME s_scm_broadcast_condition_variable
1666 SCM_VALIDATE_CONDVAR (1, cv
);
1667 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1672 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1674 "Return @code{#t} if @var{obj} is a condition variable.")
1675 #define FUNC_NAME s_scm_condition_variable_p
1677 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1681 /*** Marking stacks */
1683 /* XXX - what to do with this? Do we need to handle this for blocked
1687 # define SCM_MARK_BACKING_STORE() do { \
1689 SCM_STACKITEM * top, * bot; \
1690 getcontext (&ctx); \
1691 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1692 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1693 / sizeof (SCM_STACKITEM))); \
1694 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1695 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1696 scm_mark_locations (bot, top - bot); } while (0)
1698 # define SCM_MARK_BACKING_STORE()
1702 scm_threads_mark_stacks (void)
1705 for (t
= all_threads
; t
; t
= t
->next_thread
)
1707 /* Check that thread has indeed been suspended.
1711 scm_gc_mark (t
->handle
);
1713 #if SCM_STACK_GROWS_UP
1714 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1716 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1718 scm_mark_locations ((void *) &t
->regs
,
1719 ((size_t) sizeof(t
->regs
)
1720 / sizeof (SCM_STACKITEM
)));
1723 SCM_MARK_BACKING_STORE ();
1729 scm_std_select (int nfds
,
1730 SELECT_TYPE
*readfds
,
1731 SELECT_TYPE
*writefds
,
1732 SELECT_TYPE
*exceptfds
,
1733 struct timeval
*timeout
)
1736 int res
, eno
, wakeup_fd
;
1737 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1738 scm_t_guile_ticket ticket
;
1740 if (readfds
== NULL
)
1742 FD_ZERO (&my_readfds
);
1743 readfds
= &my_readfds
;
1746 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1749 wakeup_fd
= t
->sleep_pipe
[0];
1750 ticket
= scm_leave_guile ();
1751 FD_SET (wakeup_fd
, readfds
);
1752 if (wakeup_fd
>= nfds
)
1754 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1757 scm_enter_guile (ticket
);
1759 scm_i_reset_sleep (t
);
1761 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1764 read (wakeup_fd
, &dummy
, 1);
1765 FD_CLR (wakeup_fd
, readfds
);
1777 /* Convenience API for blocking while in guile mode. */
1779 #if SCM_USE_PTHREAD_THREADS
1782 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1784 scm_t_guile_ticket t
= scm_leave_guile ();
1785 int res
= scm_i_pthread_mutex_lock (mutex
);
1786 scm_enter_guile (t
);
1791 do_unlock (void *data
)
1793 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1797 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1799 scm_i_scm_pthread_mutex_lock (mutex
);
1800 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1804 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1806 scm_t_guile_ticket t
= scm_leave_guile ();
1807 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1808 scm_enter_guile (t
);
1813 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1814 scm_i_pthread_mutex_t
*mutex
,
1815 const scm_t_timespec
*wt
)
1817 scm_t_guile_ticket t
= scm_leave_guile ();
1818 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1819 scm_enter_guile (t
);
1826 scm_std_usleep (unsigned long usecs
)
1829 tv
.tv_usec
= usecs
% 1000000;
1830 tv
.tv_sec
= usecs
/ 1000000;
1831 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1832 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1836 scm_std_sleep (unsigned int secs
)
1841 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1847 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1849 "Return the thread that called this function.")
1850 #define FUNC_NAME s_scm_current_thread
1852 return SCM_I_CURRENT_THREAD
->handle
;
1857 scm_c_make_list (size_t n
, SCM fill
)
1861 res
= scm_cons (fill
, res
);
1865 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1867 "Return a list of all threads.")
1868 #define FUNC_NAME s_scm_all_threads
1870 /* We can not allocate while holding the thread_admin_mutex because
1871 of the way GC is done.
1873 int n
= thread_count
;
1875 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1877 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1879 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1881 if (t
!= scm_i_signal_delivery_thread
)
1883 SCM_SETCAR (*l
, t
->handle
);
1884 l
= SCM_CDRLOC (*l
);
1889 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1894 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1896 "Return @code{#t} iff @var{thread} has exited.\n")
1897 #define FUNC_NAME s_scm_thread_exited_p
1899 return scm_from_bool (scm_c_thread_exited_p (thread
));
1904 scm_c_thread_exited_p (SCM thread
)
1905 #define FUNC_NAME s_scm_thread_exited_p
1908 SCM_VALIDATE_THREAD (1, thread
);
1909 t
= SCM_I_THREAD_DATA (thread
);
1914 static scm_i_pthread_cond_t wake_up_cond
;
1915 int scm_i_thread_go_to_sleep
;
1916 static int threads_initialized_p
= 0;
1919 scm_i_thread_put_to_sleep ()
1921 if (threads_initialized_p
)
1926 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1928 /* Signal all threads to go to sleep
1930 scm_i_thread_go_to_sleep
= 1;
1931 for (t
= all_threads
; t
; t
= t
->next_thread
)
1932 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1933 scm_i_thread_go_to_sleep
= 0;
1938 scm_i_thread_invalidate_freelists ()
1940 /* thread_admin_mutex is already locked. */
1943 for (t
= all_threads
; t
; t
= t
->next_thread
)
1944 if (t
!= SCM_I_CURRENT_THREAD
)
1945 t
->clear_freelists_p
= 1;
1949 scm_i_thread_wake_up ()
1951 if (threads_initialized_p
)
1955 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1956 for (t
= all_threads
; t
; t
= t
->next_thread
)
1957 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1958 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1959 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1964 scm_i_thread_sleep_for_gc ()
1966 scm_i_thread
*t
= suspend ();
1967 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1971 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1973 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1974 int scm_i_critical_section_level
= 0;
1976 static SCM dynwind_critical_section_mutex
;
1979 scm_dynwind_critical_section (SCM mutex
)
1981 if (scm_is_false (mutex
))
1982 mutex
= dynwind_critical_section_mutex
;
1983 scm_dynwind_lock_mutex (mutex
);
1984 scm_dynwind_block_asyncs ();
1987 /*** Initialization */
1989 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1990 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1992 #if SCM_USE_PTHREAD_THREADS
1993 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1997 scm_threads_prehistory (SCM_STACKITEM
*base
)
1999 #if SCM_USE_PTHREAD_THREADS
2000 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2001 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2002 PTHREAD_MUTEX_RECURSIVE
);
2005 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2006 scm_i_pthread_mutexattr_recursive
);
2007 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2008 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2009 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
2010 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
2012 guilify_self_1 (base
);
2015 scm_t_bits scm_tc16_thread
;
2016 scm_t_bits scm_tc16_mutex
;
2017 scm_t_bits scm_tc16_condvar
;
2022 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2023 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
2024 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2025 scm_set_smob_free (scm_tc16_thread
, thread_free
);
2027 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2028 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
2029 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2030 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2032 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2034 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
2035 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2036 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2038 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2039 guilify_self_2 (SCM_BOOL_F
);
2040 threads_initialized_p
= 1;
2042 dynwind_critical_section_mutex
=
2043 scm_permanent_object (scm_make_recursive_mutex ());
2047 scm_init_threads_default_dynamic_state ()
2049 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2050 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2054 scm_init_thread_procs ()
2056 #include "libguile/threads.x"