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
23 #include "libguile/_scm.h"
32 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
39 #include "libguile/validate.h"
40 #include "libguile/root.h"
41 #include "libguile/eval.h"
42 #include "libguile/async.h"
43 #include "libguile/ports.h"
44 #include "libguile/threads.h"
45 #include "libguile/dynwind.h"
46 #include "libguile/iselect.h"
47 #include "libguile/fluids.h"
48 #include "libguile/continuations.h"
49 #include "libguile/gc.h"
50 #include "libguile/init.h"
51 #include "libguile/scmsigs.h"
52 #include "libguile/strings.h"
56 # define ETIMEDOUT WSAETIMEDOUT
60 # define pipe(fd) _pipe (fd, 256, O_BINARY)
61 #endif /* __MINGW32__ */
64 to_timespec (SCM t
, scm_t_timespec
*waittime
)
68 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
69 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
73 double time
= scm_to_double (t
);
74 double sec
= scm_c_truncate (time
);
76 waittime
->tv_sec
= (long) sec
;
77 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000);
83 /* Make an empty queue data structure.
88 return scm_cons (SCM_EOL
, SCM_EOL
);
91 /* Put T at the back of Q and return a handle that can be used with
92 remqueue to remove T from Q again.
95 enqueue (SCM q
, SCM t
)
97 SCM c
= scm_cons (t
, SCM_EOL
);
98 if (scm_is_null (SCM_CDR (q
)))
101 SCM_SETCDR (SCM_CAR (q
), c
);
106 /* Remove the element that the handle C refers to from the queue Q. C
107 must have been returned from a call to enqueue. The return value
108 is zero when the element referred to by C has already been removed.
109 Otherwise, 1 is returned.
112 remqueue (SCM q
, SCM c
)
115 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
117 if (scm_is_eq (p
, c
))
119 if (scm_is_eq (c
, SCM_CAR (q
)))
120 SCM_SETCAR (q
, SCM_CDR (c
));
121 SCM_SETCDR (prev
, SCM_CDR (c
));
129 /* Remove the front-most element from the queue Q and return it.
130 Return SCM_BOOL_F when Q is empty.
140 SCM_SETCDR (q
, SCM_CDR (c
));
141 if (scm_is_null (SCM_CDR (q
)))
142 SCM_SETCAR (q
, SCM_EOL
);
147 /*** Thread smob routines */
150 thread_mark (SCM obj
)
152 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
153 scm_gc_mark (t
->result
);
154 scm_gc_mark (t
->cleanup_handler
);
155 scm_gc_mark (t
->join_queue
);
156 scm_gc_mark (t
->mutexes
);
157 scm_gc_mark (t
->dynwinds
);
158 scm_gc_mark (t
->active_asyncs
);
159 scm_gc_mark (t
->continuation_root
);
160 return t
->dynamic_state
;
164 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
166 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
167 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
168 the struct case, hence we go via a union, and extract according to the
169 size of pthread_t. */
177 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
178 scm_i_pthread_t p
= t
->pthread
;
181 if (sizeof (p
) == sizeof (unsigned short))
183 else if (sizeof (p
) == sizeof (unsigned int))
185 else if (sizeof (p
) == sizeof (unsigned long))
190 scm_puts ("#<thread ", port
);
191 scm_uintprint (id
, 10, port
);
192 scm_puts (" (", port
);
193 scm_uintprint ((scm_t_bits
)t
, 16, port
);
194 scm_puts (")>", port
);
199 thread_free (SCM obj
)
201 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
203 scm_gc_free (t
, sizeof (*t
), "thread");
207 /*** Blocking on queues. */
209 /* See also scm_i_queue_async_cell for how such a block is
213 /* Put the current thread on QUEUE and go to sleep, waiting for it to
214 be woken up by a call to 'unblock_from_queue', or to be
215 interrupted. Upon return of this function, the current thread is
216 no longer on QUEUE, even when the sleep has been interrupted.
218 The QUEUE data structure is assumed to be protected by MUTEX and
219 the caller of block_self must hold MUTEX. It will be atomically
220 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
222 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
225 When WAITTIME is not NULL, the sleep will be aborted at that time.
227 The return value of block_self is an errno value. It will be zero
228 when the sleep has been successfully completed by a call to
229 unblock_from_queue, EINTR when it has been interrupted by the
230 delivery of a system async, and ETIMEDOUT when the timeout has
233 The system asyncs themselves are not executed by block_self.
236 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
237 const scm_t_timespec
*waittime
)
239 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
243 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
248 q_handle
= enqueue (queue
, t
->handle
);
249 if (waittime
== NULL
)
250 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
252 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
254 /* When we are still on QUEUE, we have been interrupted. We
255 report this only when no other error (such as a timeout) has
258 if (remqueue (queue
, q_handle
) && err
== 0)
261 scm_i_reset_sleep (t
);
267 /* Wake up the first thread on QUEUE, if any. The caller must hold
268 the mutex that protects QUEUE. The awoken thread is returned, or
269 #f when the queue was empty.
272 unblock_from_queue (SCM queue
)
274 SCM thread
= dequeue (queue
);
275 if (scm_is_true (thread
))
276 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
280 /* Getting into and out of guile mode.
283 /* Ken Raeburn observes that the implementation of suspend and resume
284 (and the things that build on top of them) are very likely not
285 correct (see below). We will need fix this eventually, and that's
286 why scm_leave_guile/scm_enter_guile are not exported in the API.
290 Consider this sequence:
292 Function foo, called in Guile mode, calls suspend (maybe indirectly
293 through scm_leave_guile), which does this:
295 // record top of stack for the GC
296 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
299 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
300 setjmp (t->regs); // here's most of the magic
304 Function foo has a SCM value X, a handle on a non-immediate object, in
305 a caller-saved register R, and it's the only reference to the object
308 The compiler wants to use R in suspend, so it pushes the current
309 value, X, into a stack slot which will be reloaded on exit from
310 suspend; then it loads stuff into R and goes about its business. The
311 setjmp call saves (some of) the current registers, including R, which
312 no longer contains X. (This isn't a problem for a normal
313 setjmp/longjmp situation, where longjmp would be called before
314 setjmp's caller returns; the old value for X would be loaded back from
315 the stack after the longjmp, before the function returned.)
317 So, suspend returns, loading X back into R (and invalidating the jump
318 buffer) in the process. The caller foo then goes off and calls a
319 bunch of other functions out of Guile mode, occasionally storing X on
320 the stack again, but, say, much deeper on the stack than suspend's
321 stack frame went, and the stack slot where suspend had written X has
322 long since been overwritten with other values.
324 Okay, nothing actively broken so far. Now, let garbage collection
325 run, triggered by another thread.
327 The thread calling foo is out of Guile mode at the time, so the
328 garbage collector just scans a range of stack addresses. Too bad that
329 X isn't stored there. So the pointed-to storage goes onto the free
330 list, and I think you can see where things go from there.
332 Is there anything I'm missing that'll prevent this scenario from
333 happening? I mean, aside from, "well, suspend and scm_leave_guile
334 don't have many local variables, so they probably won't need to save
335 any registers on most systems, so we hope everything will wind up in
336 the jump buffer and we'll just get away with it"?
338 (And, going the other direction, if scm_leave_guile and suspend push
339 the stack pointer over onto a new page, and foo doesn't make further
340 function calls and thus the stack pointer no longer includes that
341 page, are we guaranteed that the kernel cannot release the now-unused
342 stack page that contains the top-of-stack pointer we just saved? I
343 don't know if any OS actually does that. If it does, we could get
344 faults in garbage collection.)
346 I don't think scm_without_guile has to have this problem, as it gets
347 more control over the stack handling -- but it should call setjmp
348 itself. I'd probably try something like:
350 // record top of stack for the GC
351 t->top = SCM_STACK_PTR (&t);
353 SCM_FLUSH_REGISTER_WINDOWS;
358 ... though even that's making some assumptions about the stack
359 ordering of local variables versus caller-saved registers.
361 For something like scm_leave_guile to work, I don't think it can just
362 rely on invalidated jump buffers. A valid jump buffer, and a handle
363 on the stack state at the point when the jump buffer was initialized,
364 together, would work fine, but I think then we're talking about macros
365 invoking setjmp in the caller's stack frame, and requiring that the
366 caller of scm_leave_guile also call scm_enter_guile before returning,
367 kind of like pthread_cleanup_push/pop calls that have to be paired up
368 in a function. (In fact, the pthread ones have to be paired up
369 syntactically, as if they might expand to a compound statement
370 incorporating the user's code, and invoking a compiler's
371 exception-handling primitives. Which might be something to think
372 about for cases where Guile is used with C++ exceptions or
376 scm_i_pthread_key_t scm_i_thread_key
;
379 resume (scm_i_thread
*t
)
382 if (t
->clear_freelists_p
)
384 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
385 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
386 t
->clear_freelists_p
= 0;
390 typedef void* scm_t_guile_ticket
;
393 scm_enter_guile (scm_t_guile_ticket ticket
)
395 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
398 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
403 static scm_i_thread
*
406 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
408 /* record top of stack for the GC */
409 t
->top
= SCM_STACK_PTR (&t
);
410 /* save registers. */
411 SCM_FLUSH_REGISTER_WINDOWS
;
416 static scm_t_guile_ticket
419 scm_i_thread
*t
= suspend ();
420 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
421 return (scm_t_guile_ticket
) t
;
424 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
425 static scm_i_thread
*all_threads
= NULL
;
426 static int thread_count
;
428 static SCM scm_i_default_dynamic_state
;
430 /* Perform first stage of thread initialisation, in non-guile mode.
433 guilify_self_1 (SCM_STACKITEM
*base
)
435 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
437 t
->pthread
= scm_i_pthread_self ();
438 t
->handle
= SCM_BOOL_F
;
439 t
->result
= SCM_BOOL_F
;
440 t
->cleanup_handler
= SCM_BOOL_F
;
441 t
->mutexes
= SCM_EOL
;
442 t
->join_queue
= SCM_EOL
;
443 t
->dynamic_state
= SCM_BOOL_F
;
444 t
->dynwinds
= SCM_EOL
;
445 t
->active_asyncs
= SCM_EOL
;
447 t
->pending_asyncs
= 1;
448 t
->last_debug_frame
= NULL
;
450 t
->continuation_root
= SCM_EOL
;
451 t
->continuation_base
= base
;
452 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
453 t
->sleep_mutex
= NULL
;
454 t
->sleep_object
= SCM_BOOL_F
;
456 /* XXX - check for errors. */
457 pipe (t
->sleep_pipe
);
458 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
459 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
460 t
->clear_freelists_p
= 0;
465 t
->freelist
= SCM_EOL
;
466 t
->freelist2
= SCM_EOL
;
467 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
468 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
470 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
472 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
474 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
475 t
->next_thread
= all_threads
;
478 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
481 /* Perform second stage of thread initialisation, in guile mode.
484 guilify_self_2 (SCM parent
)
486 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
488 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
489 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
490 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
491 t
->continuation_base
= t
->base
;
493 if (scm_is_true (parent
))
494 t
->dynamic_state
= scm_make_dynamic_state (parent
);
496 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
498 t
->join_queue
= make_queue ();
505 /* We implement our own mutex type since we want them to be 'fair', we
506 want to do fancy things while waiting for them (like running
507 asyncs) and we might want to add things that are nice for
512 scm_i_pthread_mutex_t lock
;
514 int level
; /* how much the owner owns us.
515 < 0 for non-recursive mutexes */
517 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
518 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
519 owned by the current thread? */
521 SCM waiting
; /* the threads waiting for this mutex. */
524 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
525 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
527 /* Perform thread tear-down, in guile mode.
530 do_thread_exit (void *v
)
532 scm_i_thread
*t
= (scm_i_thread
*) v
;
534 if (!scm_is_false (t
->cleanup_handler
))
536 SCM ptr
= t
->cleanup_handler
;
538 t
->cleanup_handler
= SCM_BOOL_F
;
539 t
->result
= scm_internal_catch (SCM_BOOL_T
,
540 (scm_t_catch_body
) scm_call_0
, ptr
,
541 scm_handle_by_message_noexit
, NULL
);
544 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
547 close (t
->sleep_pipe
[0]);
548 close (t
->sleep_pipe
[1]);
549 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
552 while (!scm_is_null (t
->mutexes
))
554 SCM mutex
= SCM_CAR (t
->mutexes
);
555 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
556 scm_i_pthread_mutex_lock (&m
->lock
);
558 unblock_from_queue (m
->waiting
);
560 scm_i_pthread_mutex_unlock (&m
->lock
);
561 t
->mutexes
= SCM_CDR (t
->mutexes
);
564 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
570 on_thread_exit (void *v
)
572 /* This handler is executed in non-guile mode. */
573 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
575 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
577 /* Ensure the signal handling thread has been launched, because we might be
579 scm_i_ensure_signal_delivery_thread ();
581 /* Unblocking the joining threads needs to happen in guile mode
582 since the queue is a SCM data structure. */
583 scm_with_guile (do_thread_exit
, v
);
585 /* Removing ourself from the list of all threads needs to happen in
586 non-guile mode since all SCM values on our stack become
587 unprotected once we are no longer in the list. */
588 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
589 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
592 *tp
= t
->next_thread
;
597 /* If there's only one other thread, it could be the signal delivery
598 thread, so we need to notify it to shut down by closing its read pipe.
599 If it's not the signal delivery thread, then closing the read pipe isn't
601 if (thread_count
<= 1)
602 scm_i_close_signal_pipe ();
604 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
606 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
609 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
612 init_thread_key (void)
614 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
617 /* Perform any initializations necessary to bring the current thread
618 into guile mode, initializing Guile itself, if necessary.
620 BASE is the stack base to use with GC.
622 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
623 which case the default dynamic state is used.
625 Return zero when the thread was in guile mode already; otherwise
630 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
634 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
636 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
638 /* This thread has not been guilified yet.
641 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
642 if (scm_initialized_p
== 0)
644 /* First thread ever to enter Guile. Run the full
647 scm_i_init_guile (base
);
648 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
652 /* Guile is already initialized, but this thread enters it for
653 the first time. Only initialize this thread.
655 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
656 guilify_self_1 (base
);
657 guilify_self_2 (parent
);
663 /* This thread is already guilified but not in guile mode, just
666 XXX - base might be lower than when this thread was first
669 scm_enter_guile ((scm_t_guile_ticket
) t
);
674 /* Thread is already in guile mode. Nothing to do.
680 #if SCM_USE_PTHREAD_THREADS
682 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
683 /* This method for GNU/Linux and perhaps some other systems.
684 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
685 available on them. */
686 #define HAVE_GET_THREAD_STACK_BASE
688 static SCM_STACKITEM
*
689 get_thread_stack_base ()
695 pthread_getattr_np (pthread_self (), &attr
);
696 pthread_attr_getstack (&attr
, &start
, &size
);
697 end
= (char *)start
+ size
;
699 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
700 for the main thread, but we can use scm_get_stack_base in that
704 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
705 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
706 return scm_get_stack_base ();
710 #if SCM_STACK_GROWS_UP
718 #elif HAVE_PTHREAD_GET_STACKADDR_NP
719 /* This method for MacOS X.
720 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
721 but as of 2006 there's nothing obvious at apple.com. */
722 #define HAVE_GET_THREAD_STACK_BASE
723 static SCM_STACKITEM
*
724 get_thread_stack_base ()
726 return pthread_get_stackaddr_np (pthread_self ());
729 #elif defined (__MINGW32__)
730 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
731 in any thread. We don't like hard-coding the name of a system, but there
732 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
734 #define HAVE_GET_THREAD_STACK_BASE
735 static SCM_STACKITEM
*
736 get_thread_stack_base ()
738 return scm_get_stack_base ();
741 #endif /* pthread methods of get_thread_stack_base */
743 #else /* !SCM_USE_PTHREAD_THREADS */
745 #define HAVE_GET_THREAD_STACK_BASE
747 static SCM_STACKITEM
*
748 get_thread_stack_base ()
750 return scm_get_stack_base ();
753 #endif /* !SCM_USE_PTHREAD_THREADS */
755 #ifdef HAVE_GET_THREAD_STACK_BASE
760 scm_i_init_thread_for_guile (get_thread_stack_base (),
761 scm_i_default_dynamic_state
);
767 scm_with_guile (void *(*func
)(void *), void *data
)
769 return scm_i_with_guile_and_parent (func
, data
,
770 scm_i_default_dynamic_state
);
774 scm_leave_guile_cleanup (void *x
)
780 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
784 SCM_STACKITEM base_item
;
786 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
789 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
790 res
= scm_c_with_continuation_barrier (func
, data
);
791 scm_i_pthread_cleanup_pop (0);
795 res
= scm_c_with_continuation_barrier (func
, data
);
801 scm_without_guile (void *(*func
)(void *), void *data
)
804 scm_t_guile_ticket t
;
805 t
= scm_leave_guile ();
811 /*** Thread creation */
818 scm_i_pthread_mutex_t mutex
;
819 scm_i_pthread_cond_t cond
;
823 really_launch (void *d
)
825 launch_data
*data
= (launch_data
*)d
;
826 SCM thunk
= data
->thunk
, handler
= data
->handler
;
829 t
= SCM_I_CURRENT_THREAD
;
831 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
832 data
->thread
= scm_current_thread ();
833 scm_i_pthread_cond_signal (&data
->cond
);
834 scm_i_pthread_mutex_unlock (&data
->mutex
);
836 if (SCM_UNBNDP (handler
))
837 t
->result
= scm_call_0 (thunk
);
839 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
845 launch_thread (void *d
)
847 launch_data
*data
= (launch_data
*)d
;
848 scm_i_pthread_detach (scm_i_pthread_self ());
849 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
853 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
854 (SCM thunk
, SCM handler
),
855 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
856 "returning a new thread object representing the thread. The procedure\n"
857 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
859 "When @var{handler} is specified, then @var{thunk} is called from\n"
860 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
861 "handler. This catch is established inside the continuation barrier.\n"
863 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
864 "the @emph{exit value} of the thread and the thread is terminated.")
865 #define FUNC_NAME s_scm_call_with_new_thread
871 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
872 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
873 handler
, SCM_ARG2
, FUNC_NAME
);
875 data
.parent
= scm_current_dynamic_state ();
877 data
.handler
= handler
;
878 data
.thread
= SCM_BOOL_F
;
879 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
880 scm_i_pthread_cond_init (&data
.cond
, NULL
);
882 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
883 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
886 scm_i_pthread_mutex_unlock (&data
.mutex
);
890 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
891 scm_i_pthread_mutex_unlock (&data
.mutex
);
899 scm_t_catch_body body
;
901 scm_t_catch_handler handler
;
904 scm_i_pthread_mutex_t mutex
;
905 scm_i_pthread_cond_t cond
;
909 really_spawn (void *d
)
911 spawn_data
*data
= (spawn_data
*)d
;
912 scm_t_catch_body body
= data
->body
;
913 void *body_data
= data
->body_data
;
914 scm_t_catch_handler handler
= data
->handler
;
915 void *handler_data
= data
->handler_data
;
916 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
918 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
919 data
->thread
= scm_current_thread ();
920 scm_i_pthread_cond_signal (&data
->cond
);
921 scm_i_pthread_mutex_unlock (&data
->mutex
);
924 t
->result
= body (body_data
);
926 t
->result
= scm_internal_catch (SCM_BOOL_T
,
928 handler
, handler_data
);
934 spawn_thread (void *d
)
936 spawn_data
*data
= (spawn_data
*)d
;
937 scm_i_pthread_detach (scm_i_pthread_self ());
938 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
943 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
944 scm_t_catch_handler handler
, void *handler_data
)
950 data
.parent
= scm_current_dynamic_state ();
952 data
.body_data
= body_data
;
953 data
.handler
= handler
;
954 data
.handler_data
= handler_data
;
955 data
.thread
= SCM_BOOL_F
;
956 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
957 scm_i_pthread_cond_init (&data
.cond
, NULL
);
959 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
960 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
963 scm_i_pthread_mutex_unlock (&data
.mutex
);
967 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
968 scm_i_pthread_mutex_unlock (&data
.mutex
);
973 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
975 "Move the calling thread to the end of the scheduling queue.")
976 #define FUNC_NAME s_scm_yield
978 return scm_from_bool (scm_i_sched_yield ());
982 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
984 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
985 "cannot be the current thread, and if @var{thread} has already terminated or "
986 "been signaled to terminate, this function is a no-op.")
987 #define FUNC_NAME s_scm_cancel_thread
989 scm_i_thread
*t
= NULL
;
991 SCM_VALIDATE_THREAD (1, thread
);
992 t
= SCM_I_THREAD_DATA (thread
);
993 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
997 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
998 scm_i_pthread_cancel (t
->pthread
);
1001 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1003 return SCM_UNSPECIFIED
;
1007 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1008 (SCM thread
, SCM proc
),
1009 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1010 "This handler will be called when the thread exits.")
1011 #define FUNC_NAME s_scm_set_thread_cleanup_x
1015 SCM_VALIDATE_THREAD (1, thread
);
1016 if (!scm_is_false (proc
))
1017 SCM_VALIDATE_THUNK (2, proc
);
1019 t
= SCM_I_THREAD_DATA (thread
);
1020 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1022 if (!(t
->exited
|| t
->canceled
))
1023 t
->cleanup_handler
= proc
;
1025 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1027 return SCM_UNSPECIFIED
;
1031 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1033 "Return the cleanup handler installed for the thread @var{thread}.")
1034 #define FUNC_NAME s_scm_thread_cleanup
1039 SCM_VALIDATE_THREAD (1, thread
);
1041 t
= SCM_I_THREAD_DATA (thread
);
1042 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1043 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1044 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1050 SCM
scm_join_thread (SCM thread
)
1052 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1055 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1056 (SCM thread
, SCM timeout
, SCM timeoutval
),
1057 "Suspend execution of the calling thread until the target @var{thread} "
1058 "terminates, unless the target @var{thread} has already terminated. ")
1059 #define FUNC_NAME s_scm_join_thread_timed
1062 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1063 SCM res
= SCM_BOOL_F
;
1065 if (! (SCM_UNBNDP (timeoutval
)))
1068 SCM_VALIDATE_THREAD (1, thread
);
1069 if (scm_is_eq (scm_current_thread (), thread
))
1070 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1072 t
= SCM_I_THREAD_DATA (thread
);
1073 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1075 if (! SCM_UNBNDP (timeout
))
1077 to_timespec (timeout
, &ctimeout
);
1078 timeout_ptr
= &ctimeout
;
1087 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1097 else if (err
== ETIMEDOUT
)
1100 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1102 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1106 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1112 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1114 "Return @code{#t} if @var{obj} is a thread.")
1115 #define FUNC_NAME s_scm_thread_p
1117 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1122 fat_mutex_mark (SCM mx
)
1124 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1125 scm_gc_mark (m
->owner
);
1130 fat_mutex_free (SCM mx
)
1132 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1133 scm_i_pthread_mutex_destroy (&m
->lock
);
1134 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1139 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1141 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1142 scm_puts ("#<mutex ", port
);
1143 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1144 scm_puts (">", port
);
1149 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1154 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1155 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1156 m
->owner
= SCM_BOOL_F
;
1157 m
->level
= recursive
? 0 : -1;
1159 m
->unchecked_unlock
= unchecked_unlock
;
1160 m
->allow_external_unlock
= external_unlock
;
1162 m
->waiting
= SCM_EOL
;
1163 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1164 m
->waiting
= make_queue ();
1168 SCM
scm_make_mutex (void)
1170 return scm_make_mutex_with_flags (SCM_EOL
);
1173 static SCM unchecked_unlock_sym
;
1174 static SCM allow_external_unlock_sym
;
1175 static SCM recursive_sym
;
1177 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1179 "Create a new mutex. ")
1180 #define FUNC_NAME s_scm_make_mutex_with_flags
1182 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1185 while (! scm_is_null (ptr
))
1187 SCM flag
= SCM_CAR (ptr
);
1188 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1189 unchecked_unlock
= 1;
1190 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1191 external_unlock
= 1;
1192 else if (scm_is_eq (flag
, recursive_sym
))
1195 SCM_MISC_ERROR ("unsupported mutex option", SCM_EOL
);
1196 ptr
= SCM_CDR (ptr
);
1198 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1202 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1204 "Create a new recursive mutex. ")
1205 #define FUNC_NAME s_scm_make_recursive_mutex
1207 return make_fat_mutex (1, 0, 0);
1211 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1214 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, int *ret
)
1216 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1218 SCM thread
= scm_current_thread ();
1219 scm_i_thread
*t
= SCM_I_THREAD_DATA (thread
);
1221 SCM err
= SCM_BOOL_F
;
1223 struct timeval current_time
;
1225 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1226 if (scm_is_false (m
->owner
))
1229 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1230 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1231 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1234 else if (scm_is_eq (m
->owner
, thread
))
1242 err
= scm_cons (scm_misc_error_key
,
1243 scm_from_locale_string ("mutex already locked by "
1248 int first_iteration
= 1;
1251 if (scm_is_eq (m
->owner
, thread
) || scm_c_thread_exited_p (m
->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
);
1257 if (scm_c_thread_exited_p (m
->owner
))
1260 err
= scm_cons (scm_abandoned_mutex_error_key
,
1261 scm_from_locale_string ("lock obtained on "
1262 "abandoned mutex"));
1266 else if (!first_iteration
)
1268 if (timeout
!= NULL
)
1270 gettimeofday (¤t_time
, NULL
);
1271 if (current_time
.tv_sec
> timeout
->tv_sec
||
1272 (current_time
.tv_sec
== timeout
->tv_sec
&&
1273 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1279 scm_i_pthread_mutex_unlock (&m
->lock
);
1281 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1284 first_iteration
= 0;
1285 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1288 scm_i_pthread_mutex_unlock (&m
->lock
);
1292 SCM
scm_lock_mutex (SCM mx
)
1294 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
);
1297 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 1, 0,
1298 (SCM m
, SCM timeout
),
1299 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1300 "blocks until the mutex becomes available. The function returns when "
1301 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1302 "a thread already owns will succeed right away and will not block the "
1303 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1304 #define FUNC_NAME s_scm_lock_mutex_timed
1308 scm_t_timespec cwaittime
, *waittime
= NULL
;
1310 SCM_VALIDATE_MUTEX (1, m
);
1312 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1314 to_timespec (timeout
, &cwaittime
);
1315 waittime
= &cwaittime
;
1318 exception
= fat_mutex_lock (m
, waittime
, &ret
);
1319 if (!scm_is_false (exception
))
1320 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1321 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1326 scm_dynwind_lock_mutex (SCM mutex
)
1328 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1329 SCM_F_WIND_EXPLICITLY
);
1330 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1331 SCM_F_WIND_EXPLICITLY
);
1334 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1336 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1337 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1338 #define FUNC_NAME s_scm_try_mutex
1342 scm_t_timespec cwaittime
, *waittime
= NULL
;
1344 SCM_VALIDATE_MUTEX (1, mutex
);
1346 to_timespec (scm_from_int(0), &cwaittime
);
1347 waittime
= &cwaittime
;
1349 exception
= fat_mutex_lock (mutex
, waittime
, &ret
);
1350 if (!scm_is_false (exception
))
1351 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1352 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1356 /*** Fat condition variables */
1359 scm_i_pthread_mutex_t lock
;
1360 SCM waiting
; /* the threads waiting for this condition. */
1363 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1364 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1367 fat_mutex_unlock (SCM mutex
, SCM cond
,
1368 const scm_t_timespec
*waittime
, int relock
)
1370 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1372 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1373 int err
= 0, ret
= 0;
1375 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1376 if (!scm_is_eq (m
->owner
, scm_current_thread ()))
1378 if (scm_is_false (m
->owner
))
1380 if (!m
->unchecked_unlock
)
1381 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1383 else if (!m
->allow_external_unlock
)
1384 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1387 if (! (SCM_UNBNDP (cond
)))
1391 c
= SCM_CONDVAR_DATA (cond
);
1396 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1400 m
->owner
= unblock_from_queue (m
->waiting
);
1401 scm_i_pthread_mutex_unlock (&m
->lock
);
1405 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1412 else if (err
== ETIMEDOUT
)
1417 else if (err
!= EINTR
)
1420 scm_i_pthread_mutex_unlock (&c
->lock
);
1421 scm_syserror (NULL
);
1427 fat_mutex_lock (mutex
, NULL
, &lock_ret
);
1428 scm_i_pthread_mutex_unlock (&c
->lock
);
1432 scm_i_pthread_mutex_unlock (&c
->lock
);
1437 scm_remember_upto_here_2 (cond
, mutex
);
1439 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1447 m
->owner
= unblock_from_queue (m
->waiting
);
1448 scm_i_pthread_mutex_unlock (&m
->lock
);
1455 SCM
scm_unlock_mutex (SCM mx
)
1457 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1460 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1461 (SCM mx
, SCM cond
, SCM timeout
),
1462 "Unlocks @var{mutex} if the calling thread owns the lock on "
1463 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1464 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1465 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1466 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1467 "with a call to @code{unlock-mutex}. Only the last call to "
1468 "@code{unlock-mutex} will actually unlock the mutex. ")
1469 #define FUNC_NAME s_scm_unlock_mutex_timed
1471 scm_t_timespec cwaittime
, *waittime
= NULL
;
1473 SCM_VALIDATE_MUTEX (1, mx
);
1474 if (! (SCM_UNBNDP (cond
)))
1476 SCM_VALIDATE_CONDVAR (2, cond
);
1478 if (! (SCM_UNBNDP (timeout
)))
1480 to_timespec (timeout
, &cwaittime
);
1481 waittime
= &cwaittime
;
1485 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1489 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1491 "Return @code{#t} if @var{obj} is a mutex.")
1492 #define FUNC_NAME s_scm_mutex_p
1494 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1500 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1502 "Return the thread owning @var{mx}, or @code{#f}.")
1503 #define FUNC_NAME s_scm_mutex_owner
1505 SCM_VALIDATE_MUTEX (1, mx
);
1506 return (SCM_MUTEX_DATA(mx
))->owner
;
1510 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1512 "Return the lock level of a recursive mutex, or -1\n"
1513 "for a standard mutex.")
1514 #define FUNC_NAME s_scm_mutex_level
1516 SCM_VALIDATE_MUTEX (1, mx
);
1517 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1524 fat_cond_mark (SCM cv
)
1526 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1531 fat_cond_free (SCM mx
)
1533 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1534 scm_i_pthread_mutex_destroy (&c
->lock
);
1535 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1540 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1542 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1543 scm_puts ("#<condition-variable ", port
);
1544 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1545 scm_puts (">", port
);
1549 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1551 "Make a new condition variable.")
1552 #define FUNC_NAME s_scm_make_condition_variable
1557 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1558 scm_i_pthread_mutex_init (&c
->lock
, 0);
1559 c
->waiting
= SCM_EOL
;
1560 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1561 c
->waiting
= make_queue ();
1567 fat_cond_timedwait (SCM cond
, SCM mutex
,
1568 const scm_t_timespec
*waittime
)
1570 return fat_mutex_unlock (mutex
, cond
, waittime
, 1);
1573 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1574 (SCM cv
, SCM mx
, SCM t
),
1575 "Wait until @var{cond-var} has been signalled. While waiting, "
1576 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1577 "is locked again when this function returns. When @var{time} is given, "
1578 "it specifies a point in time where the waiting should be aborted. It "
1579 "can be either a integer as returned by @code{current-time} or a pair "
1580 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1581 "mutex is locked and @code{#f} is returned. When the condition "
1582 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1584 #define FUNC_NAME s_scm_timed_wait_condition_variable
1586 scm_t_timespec waittime
, *waitptr
= NULL
;
1588 SCM_VALIDATE_CONDVAR (1, cv
);
1589 SCM_VALIDATE_MUTEX (2, mx
);
1591 if (!SCM_UNBNDP (t
))
1593 to_timespec (t
, &waittime
);
1594 waitptr
= &waittime
;
1597 return fat_cond_timedwait (cv
, mx
, waitptr
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1602 fat_cond_signal (fat_cond
*c
)
1604 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1605 unblock_from_queue (c
->waiting
);
1606 scm_i_pthread_mutex_unlock (&c
->lock
);
1609 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1611 "Wake up one thread that is waiting for @var{cv}")
1612 #define FUNC_NAME s_scm_signal_condition_variable
1614 SCM_VALIDATE_CONDVAR (1, cv
);
1615 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1621 fat_cond_broadcast (fat_cond
*c
)
1623 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1624 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1626 scm_i_pthread_mutex_unlock (&c
->lock
);
1629 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1631 "Wake up all threads that are waiting for @var{cv}. ")
1632 #define FUNC_NAME s_scm_broadcast_condition_variable
1634 SCM_VALIDATE_CONDVAR (1, cv
);
1635 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1640 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1642 "Return @code{#t} if @var{obj} is a condition variable.")
1643 #define FUNC_NAME s_scm_condition_variable_p
1645 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1649 /*** Marking stacks */
1651 /* XXX - what to do with this? Do we need to handle this for blocked
1655 # define SCM_MARK_BACKING_STORE() do { \
1657 SCM_STACKITEM * top, * bot; \
1658 getcontext (&ctx); \
1659 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1660 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1661 / sizeof (SCM_STACKITEM))); \
1662 bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
1663 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1664 scm_mark_locations (bot, top - bot); } while (0)
1666 # define SCM_MARK_BACKING_STORE()
1670 scm_threads_mark_stacks (void)
1673 for (t
= all_threads
; t
; t
= t
->next_thread
)
1675 /* Check that thread has indeed been suspended.
1679 scm_gc_mark (t
->handle
);
1681 #if SCM_STACK_GROWS_UP
1682 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1684 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1686 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1687 ((size_t) sizeof(t
->regs
)
1688 / sizeof (SCM_STACKITEM
)));
1691 SCM_MARK_BACKING_STORE ();
1697 scm_std_select (int nfds
,
1698 SELECT_TYPE
*readfds
,
1699 SELECT_TYPE
*writefds
,
1700 SELECT_TYPE
*exceptfds
,
1701 struct timeval
*timeout
)
1704 int res
, eno
, wakeup_fd
;
1705 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1706 scm_t_guile_ticket ticket
;
1708 if (readfds
== NULL
)
1710 FD_ZERO (&my_readfds
);
1711 readfds
= &my_readfds
;
1714 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1717 wakeup_fd
= t
->sleep_pipe
[0];
1718 ticket
= scm_leave_guile ();
1719 FD_SET (wakeup_fd
, readfds
);
1720 if (wakeup_fd
>= nfds
)
1722 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1725 scm_enter_guile (ticket
);
1727 scm_i_reset_sleep (t
);
1729 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1732 read (wakeup_fd
, &dummy
, 1);
1733 FD_CLR (wakeup_fd
, readfds
);
1745 /* Convenience API for blocking while in guile mode. */
1747 #if SCM_USE_PTHREAD_THREADS
1750 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1752 scm_t_guile_ticket t
= scm_leave_guile ();
1753 int res
= scm_i_pthread_mutex_lock (mutex
);
1754 scm_enter_guile (t
);
1759 do_unlock (void *data
)
1761 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1765 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1767 scm_i_scm_pthread_mutex_lock (mutex
);
1768 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1772 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1774 scm_t_guile_ticket t
= scm_leave_guile ();
1775 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1776 scm_enter_guile (t
);
1781 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1782 scm_i_pthread_mutex_t
*mutex
,
1783 const scm_t_timespec
*wt
)
1785 scm_t_guile_ticket t
= scm_leave_guile ();
1786 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1787 scm_enter_guile (t
);
1794 scm_std_usleep (unsigned long usecs
)
1797 tv
.tv_usec
= usecs
% 1000000;
1798 tv
.tv_sec
= usecs
/ 1000000;
1799 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1800 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1804 scm_std_sleep (unsigned int secs
)
1809 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1815 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1817 "Return the thread that called this function.")
1818 #define FUNC_NAME s_scm_current_thread
1820 return SCM_I_CURRENT_THREAD
->handle
;
1825 scm_c_make_list (size_t n
, SCM fill
)
1829 res
= scm_cons (fill
, res
);
1833 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1835 "Return a list of all threads.")
1836 #define FUNC_NAME s_scm_all_threads
1838 /* We can not allocate while holding the thread_admin_mutex because
1839 of the way GC is done.
1841 int n
= thread_count
;
1843 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1845 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1847 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1849 if (t
!= scm_i_signal_delivery_thread
)
1851 SCM_SETCAR (*l
, t
->handle
);
1852 l
= SCM_CDRLOC (*l
);
1857 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1862 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1864 "Return @code{#t} iff @var{thread} has exited.\n")
1865 #define FUNC_NAME s_scm_thread_exited_p
1867 return scm_from_bool (scm_c_thread_exited_p (thread
));
1872 scm_c_thread_exited_p (SCM thread
)
1873 #define FUNC_NAME s_scm_thread_exited_p
1876 SCM_VALIDATE_THREAD (1, thread
);
1877 t
= SCM_I_THREAD_DATA (thread
);
1882 static scm_i_pthread_cond_t wake_up_cond
;
1883 int scm_i_thread_go_to_sleep
;
1884 static int threads_initialized_p
= 0;
1887 scm_i_thread_put_to_sleep ()
1889 if (threads_initialized_p
)
1894 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1896 /* Signal all threads to go to sleep
1898 scm_i_thread_go_to_sleep
= 1;
1899 for (t
= all_threads
; t
; t
= t
->next_thread
)
1900 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1901 scm_i_thread_go_to_sleep
= 0;
1906 scm_i_thread_invalidate_freelists ()
1908 /* thread_admin_mutex is already locked. */
1911 for (t
= all_threads
; t
; t
= t
->next_thread
)
1912 if (t
!= SCM_I_CURRENT_THREAD
)
1913 t
->clear_freelists_p
= 1;
1917 scm_i_thread_wake_up ()
1919 if (threads_initialized_p
)
1923 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1924 for (t
= all_threads
; t
; t
= t
->next_thread
)
1925 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1926 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1927 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1932 scm_i_thread_sleep_for_gc ()
1934 scm_i_thread
*t
= suspend ();
1935 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1939 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1941 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1942 int scm_i_critical_section_level
= 0;
1944 static SCM dynwind_critical_section_mutex
;
1947 scm_dynwind_critical_section (SCM mutex
)
1949 if (scm_is_false (mutex
))
1950 mutex
= dynwind_critical_section_mutex
;
1951 scm_dynwind_lock_mutex (mutex
);
1952 scm_dynwind_block_asyncs ();
1955 /*** Initialization */
1957 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1958 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1960 #if SCM_USE_PTHREAD_THREADS
1961 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1965 scm_threads_prehistory (SCM_STACKITEM
*base
)
1967 #if SCM_USE_PTHREAD_THREADS
1968 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
1969 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
1970 PTHREAD_MUTEX_RECURSIVE
);
1973 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
1974 scm_i_pthread_mutexattr_recursive
);
1975 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1976 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1977 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1978 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1980 guilify_self_1 (base
);
1983 scm_t_bits scm_tc16_thread
;
1984 scm_t_bits scm_tc16_mutex
;
1985 scm_t_bits scm_tc16_condvar
;
1990 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1991 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1992 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1993 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1995 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1996 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
1997 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1998 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2000 unchecked_unlock_sym
=
2001 scm_permanent_object (scm_from_locale_symbol ("unchecked-unlock"));
2002 allow_external_unlock_sym
=
2003 scm_permanent_object (scm_from_locale_symbol ("allow-external-unlock"));
2004 recursive_sym
= scm_permanent_object (scm_from_locale_symbol ("recursive"));
2006 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2008 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
2009 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2010 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2012 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2013 guilify_self_2 (SCM_BOOL_F
);
2014 threads_initialized_p
= 1;
2016 dynwind_critical_section_mutex
=
2017 scm_permanent_object (scm_make_recursive_mutex ());
2021 scm_init_threads_default_dynamic_state ()
2023 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2024 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2028 scm_init_thread_procs ()
2030 #include "libguile/threads.x"