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 SCM_CRITICAL_SECTION_START
;
100 if (scm_is_null (SCM_CDR (q
)))
103 SCM_SETCDR (SCM_CAR (q
), c
);
105 SCM_CRITICAL_SECTION_END
;
109 /* Remove the element that the handle C refers to from the queue Q. C
110 must have been returned from a call to enqueue. The return value
111 is zero when the element referred to by C has already been removed.
112 Otherwise, 1 is returned.
115 remqueue (SCM q
, SCM c
)
118 SCM_CRITICAL_SECTION_START
;
119 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
121 if (scm_is_eq (p
, c
))
123 if (scm_is_eq (c
, SCM_CAR (q
)))
124 SCM_SETCAR (q
, SCM_CDR (c
));
125 SCM_SETCDR (prev
, SCM_CDR (c
));
126 SCM_CRITICAL_SECTION_END
;
131 SCM_CRITICAL_SECTION_END
;
135 /* Remove the front-most element from the queue Q and return it.
136 Return SCM_BOOL_F when Q is empty.
142 SCM_CRITICAL_SECTION_START
;
146 SCM_CRITICAL_SECTION_END
;
151 SCM_SETCDR (q
, SCM_CDR (c
));
152 if (scm_is_null (SCM_CDR (q
)))
153 SCM_SETCAR (q
, SCM_EOL
);
154 SCM_CRITICAL_SECTION_END
;
159 /*** Thread smob routines */
162 thread_mark (SCM obj
)
164 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
165 scm_gc_mark (t
->result
);
166 scm_gc_mark (t
->cleanup_handler
);
167 scm_gc_mark (t
->join_queue
);
168 scm_gc_mark (t
->mutexes
);
169 scm_gc_mark (t
->dynwinds
);
170 scm_gc_mark (t
->active_asyncs
);
171 scm_gc_mark (t
->continuation_root
);
173 return t
->dynamic_state
;
177 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
179 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
180 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
181 the struct case, hence we go via a union, and extract according to the
182 size of pthread_t. */
190 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
191 scm_i_pthread_t p
= t
->pthread
;
194 if (sizeof (p
) == sizeof (unsigned short))
196 else if (sizeof (p
) == sizeof (unsigned int))
198 else if (sizeof (p
) == sizeof (unsigned long))
203 scm_puts ("#<thread ", port
);
204 scm_uintprint (id
, 10, port
);
205 scm_puts (" (", port
);
206 scm_uintprint ((scm_t_bits
)t
, 16, port
);
207 scm_puts (")>", port
);
212 thread_free (SCM obj
)
214 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
216 scm_gc_free (t
, sizeof (*t
), "thread");
220 /*** Blocking on queues. */
222 /* See also scm_i_queue_async_cell for how such a block is
226 /* Put the current thread on QUEUE and go to sleep, waiting for it to
227 be woken up by a call to 'unblock_from_queue', or to be
228 interrupted. Upon return of this function, the current thread is
229 no longer on QUEUE, even when the sleep has been interrupted.
231 The caller of block_self must hold MUTEX. It will be atomically
232 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
234 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
237 When WAITTIME is not NULL, the sleep will be aborted at that time.
239 The return value of block_self is an errno value. It will be zero
240 when the sleep has been successfully completed by a call to
241 unblock_from_queue, EINTR when it has been interrupted by the
242 delivery of a system async, and ETIMEDOUT when the timeout has
245 The system asyncs themselves are not executed by block_self.
248 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
249 const scm_t_timespec
*waittime
)
251 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
255 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
260 q_handle
= enqueue (queue
, t
->handle
);
261 if (waittime
== NULL
)
262 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
264 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
266 /* When we are still on QUEUE, we have been interrupted. We
267 report this only when no other error (such as a timeout) has
270 if (remqueue (queue
, q_handle
) && err
== 0)
273 scm_i_reset_sleep (t
);
279 /* Wake up the first thread on QUEUE, if any. The awoken thread is
280 returned, or #f if the queue was empty.
283 unblock_from_queue (SCM queue
)
285 SCM thread
= dequeue (queue
);
286 if (scm_is_true (thread
))
287 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
291 /* Getting into and out of guile mode.
294 /* Ken Raeburn observes that the implementation of suspend and resume
295 (and the things that build on top of them) are very likely not
296 correct (see below). We will need fix this eventually, and that's
297 why scm_leave_guile/scm_enter_guile are not exported in the API.
301 Consider this sequence:
303 Function foo, called in Guile mode, calls suspend (maybe indirectly
304 through scm_leave_guile), which does this:
306 // record top of stack for the GC
307 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
310 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
311 setjmp (t->regs); // here's most of the magic
315 Function foo has a SCM value X, a handle on a non-immediate object, in
316 a caller-saved register R, and it's the only reference to the object
319 The compiler wants to use R in suspend, so it pushes the current
320 value, X, into a stack slot which will be reloaded on exit from
321 suspend; then it loads stuff into R and goes about its business. The
322 setjmp call saves (some of) the current registers, including R, which
323 no longer contains X. (This isn't a problem for a normal
324 setjmp/longjmp situation, where longjmp would be called before
325 setjmp's caller returns; the old value for X would be loaded back from
326 the stack after the longjmp, before the function returned.)
328 So, suspend returns, loading X back into R (and invalidating the jump
329 buffer) in the process. The caller foo then goes off and calls a
330 bunch of other functions out of Guile mode, occasionally storing X on
331 the stack again, but, say, much deeper on the stack than suspend's
332 stack frame went, and the stack slot where suspend had written X has
333 long since been overwritten with other values.
335 Okay, nothing actively broken so far. Now, let garbage collection
336 run, triggered by another thread.
338 The thread calling foo is out of Guile mode at the time, so the
339 garbage collector just scans a range of stack addresses. Too bad that
340 X isn't stored there. So the pointed-to storage goes onto the free
341 list, and I think you can see where things go from there.
343 Is there anything I'm missing that'll prevent this scenario from
344 happening? I mean, aside from, "well, suspend and scm_leave_guile
345 don't have many local variables, so they probably won't need to save
346 any registers on most systems, so we hope everything will wind up in
347 the jump buffer and we'll just get away with it"?
349 (And, going the other direction, if scm_leave_guile and suspend push
350 the stack pointer over onto a new page, and foo doesn't make further
351 function calls and thus the stack pointer no longer includes that
352 page, are we guaranteed that the kernel cannot release the now-unused
353 stack page that contains the top-of-stack pointer we just saved? I
354 don't know if any OS actually does that. If it does, we could get
355 faults in garbage collection.)
357 I don't think scm_without_guile has to have this problem, as it gets
358 more control over the stack handling -- but it should call setjmp
359 itself. I'd probably try something like:
361 // record top of stack for the GC
362 t->top = SCM_STACK_PTR (&t);
364 SCM_FLUSH_REGISTER_WINDOWS;
369 ... though even that's making some assumptions about the stack
370 ordering of local variables versus caller-saved registers.
372 For something like scm_leave_guile to work, I don't think it can just
373 rely on invalidated jump buffers. A valid jump buffer, and a handle
374 on the stack state at the point when the jump buffer was initialized,
375 together, would work fine, but I think then we're talking about macros
376 invoking setjmp in the caller's stack frame, and requiring that the
377 caller of scm_leave_guile also call scm_enter_guile before returning,
378 kind of like pthread_cleanup_push/pop calls that have to be paired up
379 in a function. (In fact, the pthread ones have to be paired up
380 syntactically, as if they might expand to a compound statement
381 incorporating the user's code, and invoking a compiler's
382 exception-handling primitives. Which might be something to think
383 about for cases where Guile is used with C++ exceptions or
387 scm_i_pthread_key_t scm_i_thread_key
;
390 resume (scm_i_thread
*t
)
393 if (t
->clear_freelists_p
)
395 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
396 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
397 t
->clear_freelists_p
= 0;
401 typedef void* scm_t_guile_ticket
;
404 scm_enter_guile (scm_t_guile_ticket ticket
)
406 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
409 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
414 static scm_i_thread
*
417 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
419 /* record top of stack for the GC */
420 t
->top
= SCM_STACK_PTR (&t
);
421 /* save registers. */
422 SCM_FLUSH_REGISTER_WINDOWS
;
427 static scm_t_guile_ticket
430 scm_i_thread
*t
= suspend ();
431 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
432 return (scm_t_guile_ticket
) t
;
435 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
436 static scm_i_thread
*all_threads
= NULL
;
437 static int thread_count
;
439 static SCM scm_i_default_dynamic_state
;
441 /* Perform first stage of thread initialisation, in non-guile mode.
444 guilify_self_1 (SCM_STACKITEM
*base
)
446 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
448 t
->pthread
= scm_i_pthread_self ();
449 t
->handle
= SCM_BOOL_F
;
450 t
->result
= SCM_BOOL_F
;
451 t
->cleanup_handler
= SCM_BOOL_F
;
452 t
->mutexes
= SCM_EOL
;
453 t
->held_mutex
= NULL
;
454 t
->join_queue
= SCM_EOL
;
455 t
->dynamic_state
= SCM_BOOL_F
;
456 t
->dynwinds
= SCM_EOL
;
457 t
->active_asyncs
= SCM_EOL
;
459 t
->pending_asyncs
= 1;
460 t
->last_debug_frame
= NULL
;
463 /* Calculate and store off the base of this thread's register
464 backing store (RBS). Unfortunately our implementation(s) of
465 scm_ia64_register_backing_store_base are only reliable for the
466 main thread. For other threads, therefore, find out the current
467 top of the RBS, and use that as a maximum. */
468 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
473 bsp
= scm_ia64_ar_bsp (&ctx
);
474 if (t
->register_backing_store_base
> bsp
)
475 t
->register_backing_store_base
= bsp
;
478 t
->continuation_root
= SCM_EOL
;
479 t
->continuation_base
= base
;
480 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
481 t
->sleep_mutex
= NULL
;
482 t
->sleep_object
= SCM_BOOL_F
;
484 /* XXX - check for errors. */
485 pipe (t
->sleep_pipe
);
486 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
487 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
488 t
->clear_freelists_p
= 0;
493 t
->freelist
= SCM_EOL
;
494 t
->freelist2
= SCM_EOL
;
495 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
496 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
498 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
500 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
502 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
503 t
->next_thread
= all_threads
;
506 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
509 /* Perform second stage of thread initialisation, in guile mode.
512 guilify_self_2 (SCM parent
)
514 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
516 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
517 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
518 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
519 t
->continuation_base
= t
->base
;
522 if (scm_is_true (parent
))
523 t
->dynamic_state
= scm_make_dynamic_state (parent
);
525 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
527 t
->join_queue
= make_queue ();
534 /* We implement our own mutex type since we want them to be 'fair', we
535 want to do fancy things while waiting for them (like running
536 asyncs) and we might want to add things that are nice for
541 scm_i_pthread_mutex_t lock
;
543 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
545 int recursive
; /* allow recursive locking? */
546 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
547 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
548 owned by the current thread? */
550 SCM waiting
; /* the threads waiting for this mutex. */
553 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
554 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
556 /* Perform thread tear-down, in guile mode.
559 do_thread_exit (void *v
)
561 scm_i_thread
*t
= (scm_i_thread
*) v
;
563 if (!scm_is_false (t
->cleanup_handler
))
565 SCM ptr
= t
->cleanup_handler
;
567 t
->cleanup_handler
= SCM_BOOL_F
;
568 t
->result
= scm_internal_catch (SCM_BOOL_T
,
569 (scm_t_catch_body
) scm_call_0
, ptr
,
570 scm_handle_by_message_noexit
, NULL
);
573 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
576 close (t
->sleep_pipe
[0]);
577 close (t
->sleep_pipe
[1]);
578 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
581 while (!scm_is_null (t
->mutexes
))
583 SCM mutex
= SCM_CAR (t
->mutexes
);
584 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
585 scm_i_pthread_mutex_lock (&m
->lock
);
587 unblock_from_queue (m
->waiting
);
589 scm_i_pthread_mutex_unlock (&m
->lock
);
590 t
->mutexes
= SCM_CDR (t
->mutexes
);
593 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
599 on_thread_exit (void *v
)
601 /* This handler is executed in non-guile mode. */
602 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
604 /* If this thread was cancelled while doing a cond wait, it will
605 still have a mutex locked, so we unlock it here. */
608 scm_i_pthread_mutex_unlock (t
->held_mutex
);
609 t
->held_mutex
= NULL
;
612 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
614 /* Ensure the signal handling thread has been launched, because we might be
616 scm_i_ensure_signal_delivery_thread ();
618 /* Unblocking the joining threads needs to happen in guile mode
619 since the queue is a SCM data structure. */
620 scm_with_guile (do_thread_exit
, v
);
622 /* Removing ourself from the list of all threads needs to happen in
623 non-guile mode since all SCM values on our stack become
624 unprotected once we are no longer in the list. */
625 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
626 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
629 *tp
= t
->next_thread
;
634 /* If there's only one other thread, it could be the signal delivery
635 thread, so we need to notify it to shut down by closing its read pipe.
636 If it's not the signal delivery thread, then closing the read pipe isn't
638 if (thread_count
<= 1)
639 scm_i_close_signal_pipe ();
641 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
643 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
646 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
649 init_thread_key (void)
651 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
654 /* Perform any initializations necessary to bring the current thread
655 into guile mode, initializing Guile itself, if necessary.
657 BASE is the stack base to use with GC.
659 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
660 which case the default dynamic state is used.
662 Return zero when the thread was in guile mode already; otherwise
667 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
671 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
673 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
675 /* This thread has not been guilified yet.
678 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
679 if (scm_initialized_p
== 0)
681 /* First thread ever to enter Guile. Run the full
684 scm_i_init_guile (base
);
685 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
689 /* Guile is already initialized, but this thread enters it for
690 the first time. Only initialize this thread.
692 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
693 guilify_self_1 (base
);
694 guilify_self_2 (parent
);
700 /* This thread is already guilified but not in guile mode, just
703 XXX - base might be lower than when this thread was first
706 scm_enter_guile ((scm_t_guile_ticket
) t
);
711 /* Thread is already in guile mode. Nothing to do.
717 #if SCM_USE_PTHREAD_THREADS
719 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
720 /* This method for GNU/Linux and perhaps some other systems.
721 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
722 available on them. */
723 #define HAVE_GET_THREAD_STACK_BASE
725 static SCM_STACKITEM
*
726 get_thread_stack_base ()
732 pthread_getattr_np (pthread_self (), &attr
);
733 pthread_attr_getstack (&attr
, &start
, &size
);
734 end
= (char *)start
+ size
;
736 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
737 for the main thread, but we can use scm_get_stack_base in that
741 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
742 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
743 return scm_get_stack_base ();
747 #if SCM_STACK_GROWS_UP
755 #elif HAVE_PTHREAD_GET_STACKADDR_NP
756 /* This method for MacOS X.
757 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
758 but as of 2006 there's nothing obvious at apple.com. */
759 #define HAVE_GET_THREAD_STACK_BASE
760 static SCM_STACKITEM
*
761 get_thread_stack_base ()
763 return pthread_get_stackaddr_np (pthread_self ());
766 #elif defined (__MINGW32__)
767 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
768 in any thread. We don't like hard-coding the name of a system, but there
769 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
771 #define HAVE_GET_THREAD_STACK_BASE
772 static SCM_STACKITEM
*
773 get_thread_stack_base ()
775 return scm_get_stack_base ();
778 #endif /* pthread methods of get_thread_stack_base */
780 #else /* !SCM_USE_PTHREAD_THREADS */
782 #define HAVE_GET_THREAD_STACK_BASE
784 static SCM_STACKITEM
*
785 get_thread_stack_base ()
787 return scm_get_stack_base ();
790 #endif /* !SCM_USE_PTHREAD_THREADS */
792 #ifdef HAVE_GET_THREAD_STACK_BASE
797 scm_i_init_thread_for_guile (get_thread_stack_base (),
798 scm_i_default_dynamic_state
);
804 scm_with_guile (void *(*func
)(void *), void *data
)
806 return scm_i_with_guile_and_parent (func
, data
,
807 scm_i_default_dynamic_state
);
810 SCM_UNUSED
static void
811 scm_leave_guile_cleanup (void *x
)
817 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
821 SCM_STACKITEM base_item
;
823 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
826 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
827 res
= scm_c_with_continuation_barrier (func
, data
);
828 scm_i_pthread_cleanup_pop (0);
832 res
= scm_c_with_continuation_barrier (func
, data
);
838 scm_without_guile (void *(*func
)(void *), void *data
)
841 scm_t_guile_ticket t
;
842 t
= scm_leave_guile ();
848 /*** Thread creation */
855 scm_i_pthread_mutex_t mutex
;
856 scm_i_pthread_cond_t cond
;
860 really_launch (void *d
)
862 launch_data
*data
= (launch_data
*)d
;
863 SCM thunk
= data
->thunk
, handler
= data
->handler
;
866 t
= SCM_I_CURRENT_THREAD
;
868 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
869 data
->thread
= scm_current_thread ();
870 scm_i_pthread_cond_signal (&data
->cond
);
871 scm_i_pthread_mutex_unlock (&data
->mutex
);
873 if (SCM_UNBNDP (handler
))
874 t
->result
= scm_call_0 (thunk
);
876 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
882 launch_thread (void *d
)
884 launch_data
*data
= (launch_data
*)d
;
885 scm_i_pthread_detach (scm_i_pthread_self ());
886 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
890 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
891 (SCM thunk
, SCM handler
),
892 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
893 "returning a new thread object representing the thread. The procedure\n"
894 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
896 "When @var{handler} is specified, then @var{thunk} is called from\n"
897 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
898 "handler. This catch is established inside the continuation barrier.\n"
900 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
901 "the @emph{exit value} of the thread and the thread is terminated.")
902 #define FUNC_NAME s_scm_call_with_new_thread
908 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
909 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
910 handler
, SCM_ARG2
, FUNC_NAME
);
912 data
.parent
= scm_current_dynamic_state ();
914 data
.handler
= handler
;
915 data
.thread
= SCM_BOOL_F
;
916 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
917 scm_i_pthread_cond_init (&data
.cond
, NULL
);
919 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
920 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
923 scm_i_pthread_mutex_unlock (&data
.mutex
);
927 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
928 scm_i_pthread_mutex_unlock (&data
.mutex
);
936 scm_t_catch_body body
;
938 scm_t_catch_handler handler
;
941 scm_i_pthread_mutex_t mutex
;
942 scm_i_pthread_cond_t cond
;
946 really_spawn (void *d
)
948 spawn_data
*data
= (spawn_data
*)d
;
949 scm_t_catch_body body
= data
->body
;
950 void *body_data
= data
->body_data
;
951 scm_t_catch_handler handler
= data
->handler
;
952 void *handler_data
= data
->handler_data
;
953 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
955 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
956 data
->thread
= scm_current_thread ();
957 scm_i_pthread_cond_signal (&data
->cond
);
958 scm_i_pthread_mutex_unlock (&data
->mutex
);
961 t
->result
= body (body_data
);
963 t
->result
= scm_internal_catch (SCM_BOOL_T
,
965 handler
, handler_data
);
971 spawn_thread (void *d
)
973 spawn_data
*data
= (spawn_data
*)d
;
974 scm_i_pthread_detach (scm_i_pthread_self ());
975 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
980 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
981 scm_t_catch_handler handler
, void *handler_data
)
987 data
.parent
= scm_current_dynamic_state ();
989 data
.body_data
= body_data
;
990 data
.handler
= handler
;
991 data
.handler_data
= handler_data
;
992 data
.thread
= SCM_BOOL_F
;
993 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
994 scm_i_pthread_cond_init (&data
.cond
, NULL
);
996 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
997 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1000 scm_i_pthread_mutex_unlock (&data
.mutex
);
1002 scm_syserror (NULL
);
1004 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1005 scm_i_pthread_mutex_unlock (&data
.mutex
);
1010 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1012 "Move the calling thread to the end of the scheduling queue.")
1013 #define FUNC_NAME s_scm_yield
1015 return scm_from_bool (scm_i_sched_yield ());
1019 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1021 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1022 "cannot be the current thread, and if @var{thread} has already terminated or "
1023 "been signaled to terminate, this function is a no-op.")
1024 #define FUNC_NAME s_scm_cancel_thread
1026 scm_i_thread
*t
= NULL
;
1028 SCM_VALIDATE_THREAD (1, thread
);
1029 t
= SCM_I_THREAD_DATA (thread
);
1030 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1034 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1035 scm_i_pthread_cancel (t
->pthread
);
1038 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1040 return SCM_UNSPECIFIED
;
1044 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1045 (SCM thread
, SCM proc
),
1046 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1047 "This handler will be called when the thread exits.")
1048 #define FUNC_NAME s_scm_set_thread_cleanup_x
1052 SCM_VALIDATE_THREAD (1, thread
);
1053 if (!scm_is_false (proc
))
1054 SCM_VALIDATE_THUNK (2, proc
);
1056 t
= SCM_I_THREAD_DATA (thread
);
1057 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1059 if (!(t
->exited
|| t
->canceled
))
1060 t
->cleanup_handler
= proc
;
1062 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1064 return SCM_UNSPECIFIED
;
1068 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1070 "Return the cleanup handler installed for the thread @var{thread}.")
1071 #define FUNC_NAME s_scm_thread_cleanup
1076 SCM_VALIDATE_THREAD (1, thread
);
1078 t
= SCM_I_THREAD_DATA (thread
);
1079 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1080 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1081 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1087 SCM
scm_join_thread (SCM thread
)
1089 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1092 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1093 (SCM thread
, SCM timeout
, SCM timeoutval
),
1094 "Suspend execution of the calling thread until the target @var{thread} "
1095 "terminates, unless the target @var{thread} has already terminated. ")
1096 #define FUNC_NAME s_scm_join_thread_timed
1099 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1100 SCM res
= SCM_BOOL_F
;
1102 if (! (SCM_UNBNDP (timeoutval
)))
1105 SCM_VALIDATE_THREAD (1, thread
);
1106 if (scm_is_eq (scm_current_thread (), thread
))
1107 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1109 t
= SCM_I_THREAD_DATA (thread
);
1110 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1112 if (! SCM_UNBNDP (timeout
))
1114 to_timespec (timeout
, &ctimeout
);
1115 timeout_ptr
= &ctimeout
;
1124 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1134 else if (err
== ETIMEDOUT
)
1137 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1139 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1143 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1149 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1151 "Return @code{#t} if @var{obj} is a thread.")
1152 #define FUNC_NAME s_scm_thread_p
1154 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1159 fat_mutex_mark (SCM mx
)
1161 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1162 scm_gc_mark (m
->owner
);
1167 fat_mutex_free (SCM mx
)
1169 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1170 scm_i_pthread_mutex_destroy (&m
->lock
);
1171 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1176 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1178 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1179 scm_puts ("#<mutex ", port
);
1180 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1181 scm_puts (">", port
);
1186 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1191 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1192 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1193 m
->owner
= SCM_BOOL_F
;
1196 m
->recursive
= recursive
;
1197 m
->unchecked_unlock
= unchecked_unlock
;
1198 m
->allow_external_unlock
= external_unlock
;
1200 m
->waiting
= SCM_EOL
;
1201 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1202 m
->waiting
= make_queue ();
1206 SCM
scm_make_mutex (void)
1208 return scm_make_mutex_with_flags (SCM_EOL
);
1211 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1212 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1213 SCM_SYMBOL (recursive_sym
, "recursive");
1215 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1217 "Create a new mutex. ")
1218 #define FUNC_NAME s_scm_make_mutex_with_flags
1220 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1223 while (! scm_is_null (ptr
))
1225 SCM flag
= SCM_CAR (ptr
);
1226 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1227 unchecked_unlock
= 1;
1228 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1229 external_unlock
= 1;
1230 else if (scm_is_eq (flag
, recursive_sym
))
1233 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1234 ptr
= SCM_CDR (ptr
);
1236 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1240 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1242 "Create a new recursive mutex. ")
1243 #define FUNC_NAME s_scm_make_recursive_mutex
1245 return make_fat_mutex (1, 0, 0);
1249 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1252 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1254 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1256 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1257 SCM err
= SCM_BOOL_F
;
1259 struct timeval current_time
;
1261 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1267 m
->owner
= new_owner
;
1270 if (SCM_I_IS_THREAD (new_owner
))
1272 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1273 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1274 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1275 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1280 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1282 m
->owner
= new_owner
;
1283 err
= scm_cons (scm_abandoned_mutex_error_key
,
1284 scm_from_locale_string ("lock obtained on abandoned "
1289 else if (scm_is_eq (m
->owner
, new_owner
))
1298 err
= scm_cons (scm_misc_error_key
,
1299 scm_from_locale_string ("mutex already locked "
1307 if (timeout
!= NULL
)
1309 gettimeofday (¤t_time
, NULL
);
1310 if (current_time
.tv_sec
> timeout
->tv_sec
||
1311 (current_time
.tv_sec
== timeout
->tv_sec
&&
1312 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1318 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1319 scm_i_pthread_mutex_unlock (&m
->lock
);
1321 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1324 scm_i_pthread_mutex_unlock (&m
->lock
);
1328 SCM
scm_lock_mutex (SCM mx
)
1330 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1333 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1334 (SCM m
, SCM timeout
, SCM owner
),
1335 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1336 "blocks until the mutex becomes available. The function returns when "
1337 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1338 "a thread already owns will succeed right away and will not block the "
1339 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1340 #define FUNC_NAME s_scm_lock_mutex_timed
1344 scm_t_timespec cwaittime
, *waittime
= NULL
;
1346 SCM_VALIDATE_MUTEX (1, m
);
1348 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1350 to_timespec (timeout
, &cwaittime
);
1351 waittime
= &cwaittime
;
1354 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1355 if (!scm_is_false (exception
))
1356 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1357 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1362 scm_dynwind_lock_mutex (SCM mutex
)
1364 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1365 SCM_F_WIND_EXPLICITLY
);
1366 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1367 SCM_F_WIND_EXPLICITLY
);
1370 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1372 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1373 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1374 #define FUNC_NAME s_scm_try_mutex
1378 scm_t_timespec cwaittime
, *waittime
= NULL
;
1380 SCM_VALIDATE_MUTEX (1, mutex
);
1382 to_timespec (scm_from_int(0), &cwaittime
);
1383 waittime
= &cwaittime
;
1385 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1386 if (!scm_is_false (exception
))
1387 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1388 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1392 /*** Fat condition variables */
1395 scm_i_pthread_mutex_t lock
;
1396 SCM waiting
; /* the threads waiting for this condition. */
1399 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1400 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1403 fat_mutex_unlock (SCM mutex
, SCM cond
,
1404 const scm_t_timespec
*waittime
, int relock
)
1406 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1408 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1409 int err
= 0, ret
= 0;
1411 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1413 SCM owner
= m
->owner
;
1415 if (!scm_is_eq (owner
, scm_current_thread ()))
1419 if (!m
->unchecked_unlock
)
1421 scm_i_pthread_mutex_unlock (&m
->lock
);
1422 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1424 owner
= scm_current_thread ();
1426 else if (!m
->allow_external_unlock
)
1428 scm_i_pthread_mutex_unlock (&m
->lock
);
1429 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1433 if (! (SCM_UNBNDP (cond
)))
1435 c
= SCM_CONDVAR_DATA (cond
);
1443 m
->owner
= unblock_from_queue (m
->waiting
);
1447 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1448 scm_i_pthread_mutex_unlock (&m
->lock
);
1455 else if (err
== ETIMEDOUT
)
1460 else if (err
!= EINTR
)
1463 scm_syserror (NULL
);
1469 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1476 scm_remember_upto_here_2 (cond
, mutex
);
1478 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1486 m
->owner
= unblock_from_queue (m
->waiting
);
1488 scm_i_pthread_mutex_unlock (&m
->lock
);
1495 SCM
scm_unlock_mutex (SCM mx
)
1497 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1500 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1501 (SCM mx
, SCM cond
, SCM timeout
),
1502 "Unlocks @var{mutex} if the calling thread owns the lock on "
1503 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1504 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1505 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1506 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1507 "with a call to @code{unlock-mutex}. Only the last call to "
1508 "@code{unlock-mutex} will actually unlock the mutex. ")
1509 #define FUNC_NAME s_scm_unlock_mutex_timed
1511 scm_t_timespec cwaittime
, *waittime
= NULL
;
1513 SCM_VALIDATE_MUTEX (1, mx
);
1514 if (! (SCM_UNBNDP (cond
)))
1516 SCM_VALIDATE_CONDVAR (2, cond
);
1518 if (! (SCM_UNBNDP (timeout
)))
1520 to_timespec (timeout
, &cwaittime
);
1521 waittime
= &cwaittime
;
1525 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1529 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1531 "Return @code{#t} if @var{obj} is a mutex.")
1532 #define FUNC_NAME s_scm_mutex_p
1534 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1538 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1540 "Return the thread owning @var{mx}, or @code{#f}.")
1541 #define FUNC_NAME s_scm_mutex_owner
1544 fat_mutex
*m
= NULL
;
1546 SCM_VALIDATE_MUTEX (1, mx
);
1547 m
= SCM_MUTEX_DATA (mx
);
1548 scm_i_pthread_mutex_lock (&m
->lock
);
1550 scm_i_pthread_mutex_unlock (&m
->lock
);
1556 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1558 "Return the lock level of mutex @var{mx}.")
1559 #define FUNC_NAME s_scm_mutex_level
1561 SCM_VALIDATE_MUTEX (1, mx
);
1562 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1566 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1568 "Returns @code{#t} if the mutex @var{mx} is locked.")
1569 #define FUNC_NAME s_scm_mutex_locked_p
1571 SCM_VALIDATE_MUTEX (1, mx
);
1572 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1577 fat_cond_mark (SCM cv
)
1579 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1584 fat_cond_free (SCM mx
)
1586 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1587 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1592 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1594 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1595 scm_puts ("#<condition-variable ", port
);
1596 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1597 scm_puts (">", port
);
1601 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1603 "Make a new condition variable.")
1604 #define FUNC_NAME s_scm_make_condition_variable
1609 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1610 c
->waiting
= SCM_EOL
;
1611 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1612 c
->waiting
= make_queue ();
1617 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1618 (SCM cv
, SCM mx
, SCM t
),
1619 "Wait until @var{cond-var} has been signalled. While waiting, "
1620 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1621 "is locked again when this function returns. When @var{time} is given, "
1622 "it specifies a point in time where the waiting should be aborted. It "
1623 "can be either a integer as returned by @code{current-time} or a pair "
1624 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1625 "mutex is locked and @code{#f} is returned. When the condition "
1626 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1628 #define FUNC_NAME s_scm_timed_wait_condition_variable
1630 scm_t_timespec waittime
, *waitptr
= NULL
;
1632 SCM_VALIDATE_CONDVAR (1, cv
);
1633 SCM_VALIDATE_MUTEX (2, mx
);
1635 if (!SCM_UNBNDP (t
))
1637 to_timespec (t
, &waittime
);
1638 waitptr
= &waittime
;
1641 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1646 fat_cond_signal (fat_cond
*c
)
1648 unblock_from_queue (c
->waiting
);
1651 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1653 "Wake up one thread that is waiting for @var{cv}")
1654 #define FUNC_NAME s_scm_signal_condition_variable
1656 SCM_VALIDATE_CONDVAR (1, cv
);
1657 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1663 fat_cond_broadcast (fat_cond
*c
)
1665 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1669 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1671 "Wake up all threads that are waiting for @var{cv}. ")
1672 #define FUNC_NAME s_scm_broadcast_condition_variable
1674 SCM_VALIDATE_CONDVAR (1, cv
);
1675 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1680 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1682 "Return @code{#t} if @var{obj} is a condition variable.")
1683 #define FUNC_NAME s_scm_condition_variable_p
1685 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1689 /*** Marking stacks */
1691 /* XXX - what to do with this? Do we need to handle this for blocked
1695 # define SCM_MARK_BACKING_STORE() do { \
1697 SCM_STACKITEM * top, * bot; \
1698 getcontext (&ctx); \
1699 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1700 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1701 / sizeof (SCM_STACKITEM))); \
1702 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1703 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1704 scm_mark_locations (bot, top - bot); } while (0)
1706 # define SCM_MARK_BACKING_STORE()
1710 scm_threads_mark_stacks (void)
1713 for (t
= all_threads
; t
; t
= t
->next_thread
)
1715 /* Check that thread has indeed been suspended.
1719 scm_gc_mark (t
->handle
);
1721 #if SCM_STACK_GROWS_UP
1722 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1724 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1726 scm_mark_locations ((SCM_STACKITEM
*) &t
->regs
,
1727 ((size_t) sizeof(t
->regs
)
1728 / sizeof (SCM_STACKITEM
)));
1731 SCM_MARK_BACKING_STORE ();
1737 scm_std_select (int nfds
,
1738 SELECT_TYPE
*readfds
,
1739 SELECT_TYPE
*writefds
,
1740 SELECT_TYPE
*exceptfds
,
1741 struct timeval
*timeout
)
1744 int res
, eno
, wakeup_fd
;
1745 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1746 scm_t_guile_ticket ticket
;
1748 if (readfds
== NULL
)
1750 FD_ZERO (&my_readfds
);
1751 readfds
= &my_readfds
;
1754 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1757 wakeup_fd
= t
->sleep_pipe
[0];
1758 ticket
= scm_leave_guile ();
1759 FD_SET (wakeup_fd
, readfds
);
1760 if (wakeup_fd
>= nfds
)
1762 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1765 scm_enter_guile (ticket
);
1767 scm_i_reset_sleep (t
);
1769 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1772 read (wakeup_fd
, &dummy
, 1);
1773 FD_CLR (wakeup_fd
, readfds
);
1785 /* Convenience API for blocking while in guile mode. */
1787 #if SCM_USE_PTHREAD_THREADS
1790 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1792 scm_t_guile_ticket t
= scm_leave_guile ();
1793 int res
= scm_i_pthread_mutex_lock (mutex
);
1794 scm_enter_guile (t
);
1799 do_unlock (void *data
)
1801 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1805 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1807 scm_i_scm_pthread_mutex_lock (mutex
);
1808 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1812 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1814 scm_t_guile_ticket t
= scm_leave_guile ();
1815 ((scm_i_thread
*)t
)->held_mutex
= mutex
;
1816 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1817 ((scm_i_thread
*)t
)->held_mutex
= NULL
;
1818 scm_enter_guile (t
);
1823 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1824 scm_i_pthread_mutex_t
*mutex
,
1825 const scm_t_timespec
*wt
)
1827 scm_t_guile_ticket t
= scm_leave_guile ();
1828 ((scm_i_thread
*)t
)->held_mutex
= mutex
;
1829 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1830 ((scm_i_thread
*)t
)->held_mutex
= NULL
;
1831 scm_enter_guile (t
);
1838 scm_std_usleep (unsigned long usecs
)
1841 tv
.tv_usec
= usecs
% 1000000;
1842 tv
.tv_sec
= usecs
/ 1000000;
1843 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1844 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1848 scm_std_sleep (unsigned int secs
)
1853 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1859 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1861 "Return the thread that called this function.")
1862 #define FUNC_NAME s_scm_current_thread
1864 return SCM_I_CURRENT_THREAD
->handle
;
1869 scm_c_make_list (size_t n
, SCM fill
)
1873 res
= scm_cons (fill
, res
);
1877 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1879 "Return a list of all threads.")
1880 #define FUNC_NAME s_scm_all_threads
1882 /* We can not allocate while holding the thread_admin_mutex because
1883 of the way GC is done.
1885 int n
= thread_count
;
1887 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1889 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1891 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1893 if (t
!= scm_i_signal_delivery_thread
)
1895 SCM_SETCAR (*l
, t
->handle
);
1896 l
= SCM_CDRLOC (*l
);
1901 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1906 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1908 "Return @code{#t} iff @var{thread} has exited.\n")
1909 #define FUNC_NAME s_scm_thread_exited_p
1911 return scm_from_bool (scm_c_thread_exited_p (thread
));
1916 scm_c_thread_exited_p (SCM thread
)
1917 #define FUNC_NAME s_scm_thread_exited_p
1920 SCM_VALIDATE_THREAD (1, thread
);
1921 t
= SCM_I_THREAD_DATA (thread
);
1926 static scm_i_pthread_cond_t wake_up_cond
;
1927 int scm_i_thread_go_to_sleep
;
1928 static int threads_initialized_p
= 0;
1931 scm_i_thread_put_to_sleep ()
1933 if (threads_initialized_p
)
1938 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1940 /* Signal all threads to go to sleep
1942 scm_i_thread_go_to_sleep
= 1;
1943 for (t
= all_threads
; t
; t
= t
->next_thread
)
1944 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1945 scm_i_thread_go_to_sleep
= 0;
1950 scm_i_thread_invalidate_freelists ()
1952 /* thread_admin_mutex is already locked. */
1955 for (t
= all_threads
; t
; t
= t
->next_thread
)
1956 if (t
!= SCM_I_CURRENT_THREAD
)
1957 t
->clear_freelists_p
= 1;
1961 scm_i_thread_wake_up ()
1963 if (threads_initialized_p
)
1967 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1968 for (t
= all_threads
; t
; t
= t
->next_thread
)
1969 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1970 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1971 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1976 scm_i_thread_sleep_for_gc ()
1978 scm_i_thread
*t
= suspend ();
1979 t
->held_mutex
= &t
->heap_mutex
;
1980 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1981 t
->held_mutex
= NULL
;
1985 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1987 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1988 int scm_i_critical_section_level
= 0;
1990 static SCM dynwind_critical_section_mutex
;
1993 scm_dynwind_critical_section (SCM mutex
)
1995 if (scm_is_false (mutex
))
1996 mutex
= dynwind_critical_section_mutex
;
1997 scm_dynwind_lock_mutex (mutex
);
1998 scm_dynwind_block_asyncs ();
2001 /*** Initialization */
2003 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
2004 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2006 #if SCM_USE_PTHREAD_THREADS
2007 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2011 scm_threads_prehistory (SCM_STACKITEM
*base
)
2013 #if SCM_USE_PTHREAD_THREADS
2014 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2015 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2016 PTHREAD_MUTEX_RECURSIVE
);
2019 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2020 scm_i_pthread_mutexattr_recursive
);
2021 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2022 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2023 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
2024 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
2026 guilify_self_1 (base
);
2029 scm_t_bits scm_tc16_thread
;
2030 scm_t_bits scm_tc16_mutex
;
2031 scm_t_bits scm_tc16_condvar
;
2036 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2037 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
2038 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2039 scm_set_smob_free (scm_tc16_thread
, thread_free
);
2041 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2042 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
2043 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2044 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2046 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2048 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
2049 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2050 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2052 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2053 guilify_self_2 (SCM_BOOL_F
);
2054 threads_initialized_p
= 1;
2056 dynwind_critical_section_mutex
=
2057 scm_permanent_object (scm_make_recursive_mutex ());
2061 scm_init_threads_default_dynamic_state ()
2063 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2064 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2068 scm_init_thread_procs ()
2070 #include "libguile/threads.x"