1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
24 #include "libguile/_scm.h"
33 #include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
40 #include "libguile/validate.h"
41 #include "libguile/root.h"
42 #include "libguile/eval.h"
43 #include "libguile/async.h"
44 #include "libguile/ports.h"
45 #include "libguile/threads.h"
46 #include "libguile/dynwind.h"
47 #include "libguile/iselect.h"
48 #include "libguile/fluids.h"
49 #include "libguile/continuations.h"
50 #include "libguile/gc.h"
51 #include "libguile/init.h"
52 #include "libguile/scmsigs.h"
53 #include "libguile/strings.h"
57 # define ETIMEDOUT WSAETIMEDOUT
61 # define pipe(fd) _pipe (fd, 256, O_BINARY)
62 #endif /* __MINGW32__ */
65 to_timespec (SCM t
, scm_t_timespec
*waittime
)
69 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
70 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
74 double time
= scm_to_double (t
);
75 double sec
= scm_c_truncate (time
);
77 waittime
->tv_sec
= (long) sec
;
78 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
84 /* Make an empty queue data structure.
89 return scm_cons (SCM_EOL
, SCM_EOL
);
92 /* Put T at the back of Q and return a handle that can be used with
93 remqueue to remove T from Q again.
96 enqueue (SCM q
, SCM t
)
98 SCM c
= scm_cons (t
, SCM_EOL
);
99 if (scm_is_null (SCM_CDR (q
)))
102 SCM_SETCDR (SCM_CAR (q
), c
);
107 /* Remove the element that the handle C refers to from the queue Q. C
108 must have been returned from a call to enqueue. The return value
109 is zero when the element referred to by C has already been removed.
110 Otherwise, 1 is returned.
113 remqueue (SCM q
, SCM c
)
116 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
118 if (scm_is_eq (p
, c
))
120 if (scm_is_eq (c
, SCM_CAR (q
)))
121 SCM_SETCAR (q
, SCM_CDR (c
));
122 SCM_SETCDR (prev
, SCM_CDR (c
));
130 /* Remove the front-most element from the queue Q and return it.
131 Return SCM_BOOL_F when Q is empty.
141 SCM_SETCDR (q
, SCM_CDR (c
));
142 if (scm_is_null (SCM_CDR (q
)))
143 SCM_SETCAR (q
, SCM_EOL
);
148 /*** Thread smob routines */
151 thread_mark (SCM obj
)
153 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
154 scm_gc_mark (t
->result
);
155 scm_gc_mark (t
->cleanup_handler
);
156 scm_gc_mark (t
->join_queue
);
157 scm_gc_mark (t
->mutexes
);
158 scm_gc_mark (t
->dynwinds
);
159 scm_gc_mark (t
->active_asyncs
);
160 scm_gc_mark (t
->continuation_root
);
162 return t
->dynamic_state
;
166 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
168 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
169 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
170 the struct case, hence we go via a union, and extract according to the
171 size of pthread_t. */
179 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
180 scm_i_pthread_t p
= t
->pthread
;
183 if (sizeof (p
) == sizeof (unsigned short))
185 else if (sizeof (p
) == sizeof (unsigned int))
187 else if (sizeof (p
) == sizeof (unsigned long))
192 scm_puts ("#<thread ", port
);
193 scm_uintprint (id
, 10, port
);
194 scm_puts (" (", port
);
195 scm_uintprint ((scm_t_bits
)t
, 16, port
);
196 scm_puts (")>", port
);
201 thread_free (SCM obj
)
203 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
205 scm_gc_free (t
, sizeof (*t
), "thread");
209 /*** Blocking on queues. */
211 /* See also scm_i_queue_async_cell for how such a block is
215 /* Put the current thread on QUEUE and go to sleep, waiting for it to
216 be woken up by a call to 'unblock_from_queue', or to be
217 interrupted. Upon return of this function, the current thread is
218 no longer on QUEUE, even when the sleep has been interrupted.
220 The QUEUE data structure is assumed to be protected by MUTEX and
221 the caller of block_self must hold MUTEX. It will be atomically
222 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
224 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
227 When WAITTIME is not NULL, the sleep will be aborted at that time.
229 The return value of block_self is an errno value. It will be zero
230 when the sleep has been successfully completed by a call to
231 unblock_from_queue, EINTR when it has been interrupted by the
232 delivery of a system async, and ETIMEDOUT when the timeout has
235 The system asyncs themselves are not executed by block_self.
238 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
239 const scm_t_timespec
*waittime
)
241 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
245 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
250 q_handle
= enqueue (queue
, t
->handle
);
251 if (waittime
== NULL
)
252 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
254 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
256 /* When we are still on QUEUE, we have been interrupted. We
257 report this only when no other error (such as a timeout) has
260 if (remqueue (queue
, q_handle
) && err
== 0)
263 scm_i_reset_sleep (t
);
269 /* Wake up the first thread on QUEUE, if any. The caller must hold
270 the mutex that protects QUEUE. The awoken thread is returned, or
271 #f when the queue was empty.
274 unblock_from_queue (SCM queue
)
276 SCM thread
= dequeue (queue
);
277 if (scm_is_true (thread
))
278 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
282 /* Getting into and out of guile mode.
285 /* Ken Raeburn observes that the implementation of suspend and resume
286 (and the things that build on top of them) are very likely not
287 correct (see below). We will need fix this eventually, and that's
288 why scm_leave_guile/scm_enter_guile are not exported in the API.
292 Consider this sequence:
294 Function foo, called in Guile mode, calls suspend (maybe indirectly
295 through scm_leave_guile), which does this:
297 // record top of stack for the GC
298 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
301 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
302 setjmp (t->regs); // here's most of the magic
306 Function foo has a SCM value X, a handle on a non-immediate object, in
307 a caller-saved register R, and it's the only reference to the object
310 The compiler wants to use R in suspend, so it pushes the current
311 value, X, into a stack slot which will be reloaded on exit from
312 suspend; then it loads stuff into R and goes about its business. The
313 setjmp call saves (some of) the current registers, including R, which
314 no longer contains X. (This isn't a problem for a normal
315 setjmp/longjmp situation, where longjmp would be called before
316 setjmp's caller returns; the old value for X would be loaded back from
317 the stack after the longjmp, before the function returned.)
319 So, suspend returns, loading X back into R (and invalidating the jump
320 buffer) in the process. The caller foo then goes off and calls a
321 bunch of other functions out of Guile mode, occasionally storing X on
322 the stack again, but, say, much deeper on the stack than suspend's
323 stack frame went, and the stack slot where suspend had written X has
324 long since been overwritten with other values.
326 Okay, nothing actively broken so far. Now, let garbage collection
327 run, triggered by another thread.
329 The thread calling foo is out of Guile mode at the time, so the
330 garbage collector just scans a range of stack addresses. Too bad that
331 X isn't stored there. So the pointed-to storage goes onto the free
332 list, and I think you can see where things go from there.
334 Is there anything I'm missing that'll prevent this scenario from
335 happening? I mean, aside from, "well, suspend and scm_leave_guile
336 don't have many local variables, so they probably won't need to save
337 any registers on most systems, so we hope everything will wind up in
338 the jump buffer and we'll just get away with it"?
340 (And, going the other direction, if scm_leave_guile and suspend push
341 the stack pointer over onto a new page, and foo doesn't make further
342 function calls and thus the stack pointer no longer includes that
343 page, are we guaranteed that the kernel cannot release the now-unused
344 stack page that contains the top-of-stack pointer we just saved? I
345 don't know if any OS actually does that. If it does, we could get
346 faults in garbage collection.)
348 I don't think scm_without_guile has to have this problem, as it gets
349 more control over the stack handling -- but it should call setjmp
350 itself. I'd probably try something like:
352 // record top of stack for the GC
353 t->top = SCM_STACK_PTR (&t);
355 SCM_FLUSH_REGISTER_WINDOWS;
360 ... though even that's making some assumptions about the stack
361 ordering of local variables versus caller-saved registers.
363 For something like scm_leave_guile to work, I don't think it can just
364 rely on invalidated jump buffers. A valid jump buffer, and a handle
365 on the stack state at the point when the jump buffer was initialized,
366 together, would work fine, but I think then we're talking about macros
367 invoking setjmp in the caller's stack frame, and requiring that the
368 caller of scm_leave_guile also call scm_enter_guile before returning,
369 kind of like pthread_cleanup_push/pop calls that have to be paired up
370 in a function. (In fact, the pthread ones have to be paired up
371 syntactically, as if they might expand to a compound statement
372 incorporating the user's code, and invoking a compiler's
373 exception-handling primitives. Which might be something to think
374 about for cases where Guile is used with C++ exceptions or
378 scm_i_pthread_key_t scm_i_thread_key
;
381 resume (scm_i_thread
*t
)
384 if (t
->clear_freelists_p
)
386 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
387 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
388 t
->clear_freelists_p
= 0;
392 typedef void* scm_t_guile_ticket
;
395 scm_enter_guile (scm_t_guile_ticket ticket
)
397 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
400 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
405 static scm_i_thread
*
408 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
410 /* record top of stack for the GC */
411 t
->top
= SCM_STACK_PTR (&t
);
412 /* save registers. */
413 SCM_FLUSH_REGISTER_WINDOWS
;
418 static scm_t_guile_ticket
421 scm_i_thread
*t
= suspend ();
422 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
423 return (scm_t_guile_ticket
) t
;
426 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
427 static scm_i_thread
*all_threads
= NULL
;
428 static int thread_count
;
430 static SCM scm_i_default_dynamic_state
;
432 /* Perform first stage of thread initialisation, in non-guile mode.
435 guilify_self_1 (SCM_STACKITEM
*base
)
437 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
439 t
->pthread
= scm_i_pthread_self ();
440 t
->handle
= SCM_BOOL_F
;
441 t
->result
= SCM_BOOL_F
;
442 t
->cleanup_handler
= SCM_BOOL_F
;
443 t
->mutexes
= SCM_EOL
;
444 t
->join_queue
= SCM_EOL
;
445 t
->dynamic_state
= SCM_BOOL_F
;
446 t
->dynwinds
= SCM_EOL
;
447 t
->active_asyncs
= SCM_EOL
;
449 t
->pending_asyncs
= 1;
450 t
->last_debug_frame
= NULL
;
453 /* Calculate and store off the base of this thread's register
454 backing store (RBS). Unfortunately our implementation(s) of
455 scm_ia64_register_backing_store_base are only reliable for the
456 main thread. For other threads, therefore, find out the current
457 top of the RBS, and use that as a maximum. */
458 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
463 bsp
= scm_ia64_ar_bsp (&ctx
);
464 if (t
->register_backing_store_base
> bsp
)
465 t
->register_backing_store_base
= bsp
;
468 t
->continuation_root
= SCM_EOL
;
469 t
->continuation_base
= base
;
470 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
471 t
->sleep_mutex
= NULL
;
472 t
->sleep_object
= SCM_BOOL_F
;
474 /* XXX - check for errors. */
475 pipe (t
->sleep_pipe
);
476 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
477 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
478 t
->clear_freelists_p
= 0;
483 t
->freelist
= SCM_EOL
;
484 t
->freelist2
= SCM_EOL
;
485 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
486 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
488 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
490 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
492 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
493 t
->next_thread
= all_threads
;
496 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
499 /* Perform second stage of thread initialisation, in guile mode.
502 guilify_self_2 (SCM parent
)
504 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
506 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
507 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
508 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
509 t
->continuation_base
= t
->base
;
512 if (scm_is_true (parent
))
513 t
->dynamic_state
= scm_make_dynamic_state (parent
);
515 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
517 t
->join_queue
= make_queue ();
524 /* We implement our own mutex type since we want them to be 'fair', we
525 want to do fancy things while waiting for them (like running
526 asyncs) and we might want to add things that are nice for
531 scm_i_pthread_mutex_t lock
;
533 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
535 int recursive
; /* allow recursive locking? */
536 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
537 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
538 owned by the current thread? */
540 SCM waiting
; /* the threads waiting for this mutex. */
543 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
544 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
546 /* Perform thread tear-down, in guile mode.
549 do_thread_exit (void *v
)
551 scm_i_thread
*t
= (scm_i_thread
*) v
;
553 if (!scm_is_false (t
->cleanup_handler
))
555 SCM ptr
= t
->cleanup_handler
;
557 t
->cleanup_handler
= SCM_BOOL_F
;
558 t
->result
= scm_internal_catch (SCM_BOOL_T
,
559 (scm_t_catch_body
) scm_call_0
, ptr
,
560 scm_handle_by_message_noexit
, NULL
);
563 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
566 close (t
->sleep_pipe
[0]);
567 close (t
->sleep_pipe
[1]);
568 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
571 while (!scm_is_null (t
->mutexes
))
573 SCM mutex
= SCM_CAR (t
->mutexes
);
574 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
575 scm_i_pthread_mutex_lock (&m
->lock
);
577 unblock_from_queue (m
->waiting
);
579 scm_i_pthread_mutex_unlock (&m
->lock
);
580 t
->mutexes
= SCM_CDR (t
->mutexes
);
583 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
589 on_thread_exit (void *v
)
591 /* This handler is executed in non-guile mode. */
592 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
594 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
596 /* Ensure the signal handling thread has been launched, because we might be
598 scm_i_ensure_signal_delivery_thread ();
600 /* Unblocking the joining threads needs to happen in guile mode
601 since the queue is a SCM data structure. */
602 scm_with_guile (do_thread_exit
, v
);
604 /* Removing ourself from the list of all threads needs to happen in
605 non-guile mode since all SCM values on our stack become
606 unprotected once we are no longer in the list. */
607 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
608 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
611 *tp
= t
->next_thread
;
616 /* If there's only one other thread, it could be the signal delivery
617 thread, so we need to notify it to shut down by closing its read pipe.
618 If it's not the signal delivery thread, then closing the read pipe isn't
620 if (thread_count
<= 1)
621 scm_i_close_signal_pipe ();
623 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
625 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
628 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
631 init_thread_key (void)
633 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
636 /* Perform any initializations necessary to bring the current thread
637 into guile mode, initializing Guile itself, if necessary.
639 BASE is the stack base to use with GC.
641 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
642 which case the default dynamic state is used.
644 Return zero when the thread was in guile mode already; otherwise
649 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
653 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
655 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
657 /* This thread has not been guilified yet.
660 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
661 if (scm_initialized_p
== 0)
663 /* First thread ever to enter Guile. Run the full
666 scm_i_init_guile (base
);
667 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
671 /* Guile is already initialized, but this thread enters it for
672 the first time. Only initialize this thread.
674 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
675 guilify_self_1 (base
);
676 guilify_self_2 (parent
);
682 /* This thread is already guilified but not in guile mode, just
685 XXX - base might be lower than when this thread was first
688 scm_enter_guile ((scm_t_guile_ticket
) t
);
693 /* Thread is already in guile mode. Nothing to do.
699 #if SCM_USE_PTHREAD_THREADS
701 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
702 /* This method for GNU/Linux and perhaps some other systems.
703 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
704 available on them. */
705 #define HAVE_GET_THREAD_STACK_BASE
707 static SCM_STACKITEM
*
708 get_thread_stack_base ()
714 pthread_getattr_np (pthread_self (), &attr
);
715 pthread_attr_getstack (&attr
, &start
, &size
);
716 end
= (char *)start
+ size
;
718 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
719 for the main thread, but we can use scm_get_stack_base in that
723 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
724 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
725 return scm_get_stack_base ();
729 #if SCM_STACK_GROWS_UP
737 #elif HAVE_PTHREAD_GET_STACKADDR_NP
738 /* This method for MacOS X.
739 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
740 but as of 2006 there's nothing obvious at apple.com. */
741 #define HAVE_GET_THREAD_STACK_BASE
742 static SCM_STACKITEM
*
743 get_thread_stack_base ()
745 return pthread_get_stackaddr_np (pthread_self ());
748 #elif defined (__MINGW32__)
749 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
750 in any thread. We don't like hard-coding the name of a system, but there
751 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
753 #define HAVE_GET_THREAD_STACK_BASE
754 static SCM_STACKITEM
*
755 get_thread_stack_base ()
757 return scm_get_stack_base ();
760 #endif /* pthread methods of get_thread_stack_base */
762 #else /* !SCM_USE_PTHREAD_THREADS */
764 #define HAVE_GET_THREAD_STACK_BASE
766 static SCM_STACKITEM
*
767 get_thread_stack_base ()
769 return scm_get_stack_base ();
772 #endif /* !SCM_USE_PTHREAD_THREADS */
774 #ifdef HAVE_GET_THREAD_STACK_BASE
779 scm_i_init_thread_for_guile (get_thread_stack_base (),
780 scm_i_default_dynamic_state
);
786 scm_with_guile (void *(*func
)(void *), void *data
)
788 return scm_i_with_guile_and_parent (func
, data
,
789 scm_i_default_dynamic_state
);
792 SCM_UNUSED
static void
793 scm_leave_guile_cleanup (void *x
)
799 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
803 SCM_STACKITEM base_item
;
805 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
808 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
809 res
= scm_c_with_continuation_barrier (func
, data
);
810 scm_i_pthread_cleanup_pop (0);
814 res
= scm_c_with_continuation_barrier (func
, data
);
820 scm_without_guile (void *(*func
)(void *), void *data
)
823 scm_t_guile_ticket t
;
824 t
= scm_leave_guile ();
830 /*** Thread creation */
837 scm_i_pthread_mutex_t mutex
;
838 scm_i_pthread_cond_t cond
;
842 really_launch (void *d
)
844 launch_data
*data
= (launch_data
*)d
;
845 SCM thunk
= data
->thunk
, handler
= data
->handler
;
848 t
= SCM_I_CURRENT_THREAD
;
850 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
851 data
->thread
= scm_current_thread ();
852 scm_i_pthread_cond_signal (&data
->cond
);
853 scm_i_pthread_mutex_unlock (&data
->mutex
);
855 if (SCM_UNBNDP (handler
))
856 t
->result
= scm_call_0 (thunk
);
858 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
864 launch_thread (void *d
)
866 launch_data
*data
= (launch_data
*)d
;
867 scm_i_pthread_detach (scm_i_pthread_self ());
868 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
872 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
873 (SCM thunk
, SCM handler
),
874 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
875 "returning a new thread object representing the thread. The procedure\n"
876 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
878 "When @var{handler} is specified, then @var{thunk} is called from\n"
879 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
880 "handler. This catch is established inside the continuation barrier.\n"
882 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
883 "the @emph{exit value} of the thread and the thread is terminated.")
884 #define FUNC_NAME s_scm_call_with_new_thread
890 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
891 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
892 handler
, SCM_ARG2
, FUNC_NAME
);
894 data
.parent
= scm_current_dynamic_state ();
896 data
.handler
= handler
;
897 data
.thread
= SCM_BOOL_F
;
898 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
899 scm_i_pthread_cond_init (&data
.cond
, NULL
);
901 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
902 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
905 scm_i_pthread_mutex_unlock (&data
.mutex
);
909 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
910 scm_i_pthread_mutex_unlock (&data
.mutex
);
918 scm_t_catch_body body
;
920 scm_t_catch_handler handler
;
923 scm_i_pthread_mutex_t mutex
;
924 scm_i_pthread_cond_t cond
;
928 really_spawn (void *d
)
930 spawn_data
*data
= (spawn_data
*)d
;
931 scm_t_catch_body body
= data
->body
;
932 void *body_data
= data
->body_data
;
933 scm_t_catch_handler handler
= data
->handler
;
934 void *handler_data
= data
->handler_data
;
935 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
937 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
938 data
->thread
= scm_current_thread ();
939 scm_i_pthread_cond_signal (&data
->cond
);
940 scm_i_pthread_mutex_unlock (&data
->mutex
);
943 t
->result
= body (body_data
);
945 t
->result
= scm_internal_catch (SCM_BOOL_T
,
947 handler
, handler_data
);
953 spawn_thread (void *d
)
955 spawn_data
*data
= (spawn_data
*)d
;
956 scm_i_pthread_detach (scm_i_pthread_self ());
957 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
962 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
963 scm_t_catch_handler handler
, void *handler_data
)
969 data
.parent
= scm_current_dynamic_state ();
971 data
.body_data
= body_data
;
972 data
.handler
= handler
;
973 data
.handler_data
= handler_data
;
974 data
.thread
= SCM_BOOL_F
;
975 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
976 scm_i_pthread_cond_init (&data
.cond
, NULL
);
978 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
979 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
982 scm_i_pthread_mutex_unlock (&data
.mutex
);
986 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
987 scm_i_pthread_mutex_unlock (&data
.mutex
);
992 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
994 "Move the calling thread to the end of the scheduling queue.")
995 #define FUNC_NAME s_scm_yield
997 return scm_from_bool (scm_i_sched_yield ());
1001 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1003 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1004 "cannot be the current thread, and if @var{thread} has already terminated or "
1005 "been signaled to terminate, this function is a no-op.")
1006 #define FUNC_NAME s_scm_cancel_thread
1008 scm_i_thread
*t
= NULL
;
1010 SCM_VALIDATE_THREAD (1, thread
);
1011 t
= SCM_I_THREAD_DATA (thread
);
1012 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1016 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1017 scm_i_pthread_cancel (t
->pthread
);
1020 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1022 return SCM_UNSPECIFIED
;
1026 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1027 (SCM thread
, SCM proc
),
1028 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1029 "This handler will be called when the thread exits.")
1030 #define FUNC_NAME s_scm_set_thread_cleanup_x
1034 SCM_VALIDATE_THREAD (1, thread
);
1035 if (!scm_is_false (proc
))
1036 SCM_VALIDATE_THUNK (2, proc
);
1038 t
= SCM_I_THREAD_DATA (thread
);
1039 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1041 if (!(t
->exited
|| t
->canceled
))
1042 t
->cleanup_handler
= proc
;
1044 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1046 return SCM_UNSPECIFIED
;
1050 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1052 "Return the cleanup handler installed for the thread @var{thread}.")
1053 #define FUNC_NAME s_scm_thread_cleanup
1058 SCM_VALIDATE_THREAD (1, thread
);
1060 t
= SCM_I_THREAD_DATA (thread
);
1061 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1062 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1063 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1069 SCM
scm_join_thread (SCM thread
)
1071 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1074 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1075 (SCM thread
, SCM timeout
, SCM timeoutval
),
1076 "Suspend execution of the calling thread until the target @var{thread} "
1077 "terminates, unless the target @var{thread} has already terminated. ")
1078 #define FUNC_NAME s_scm_join_thread_timed
1081 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1082 SCM res
= SCM_BOOL_F
;
1084 if (! (SCM_UNBNDP (timeoutval
)))
1087 SCM_VALIDATE_THREAD (1, thread
);
1088 if (scm_is_eq (scm_current_thread (), thread
))
1089 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1091 t
= SCM_I_THREAD_DATA (thread
);
1092 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1094 if (! SCM_UNBNDP (timeout
))
1096 to_timespec (timeout
, &ctimeout
);
1097 timeout_ptr
= &ctimeout
;
1106 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1116 else if (err
== ETIMEDOUT
)
1119 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1121 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1125 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1131 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1133 "Return @code{#t} if @var{obj} is a thread.")
1134 #define FUNC_NAME s_scm_thread_p
1136 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1141 fat_mutex_mark (SCM mx
)
1143 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1144 scm_gc_mark (m
->owner
);
1149 fat_mutex_free (SCM mx
)
1151 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1152 scm_i_pthread_mutex_destroy (&m
->lock
);
1153 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1158 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1160 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1161 scm_puts ("#<mutex ", port
);
1162 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1163 scm_puts (">", port
);
1168 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1173 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1174 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1175 m
->owner
= SCM_BOOL_F
;
1178 m
->recursive
= recursive
;
1179 m
->unchecked_unlock
= unchecked_unlock
;
1180 m
->allow_external_unlock
= external_unlock
;
1182 m
->waiting
= SCM_EOL
;
1183 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1184 m
->waiting
= make_queue ();
1188 SCM
scm_make_mutex (void)
1190 return scm_make_mutex_with_flags (SCM_EOL
);
1193 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1194 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1195 SCM_SYMBOL (recursive_sym
, "recursive");
1197 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1199 "Create a new mutex. ")
1200 #define FUNC_NAME s_scm_make_mutex_with_flags
1202 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1205 while (! scm_is_null (ptr
))
1207 SCM flag
= SCM_CAR (ptr
);
1208 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1209 unchecked_unlock
= 1;
1210 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1211 external_unlock
= 1;
1212 else if (scm_is_eq (flag
, recursive_sym
))
1215 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1216 ptr
= SCM_CDR (ptr
);
1218 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1222 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1224 "Create a new recursive mutex. ")
1225 #define FUNC_NAME s_scm_make_recursive_mutex
1227 return make_fat_mutex (1, 0, 0);
1231 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1234 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1236 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1238 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1239 SCM err
= SCM_BOOL_F
;
1241 struct timeval current_time
;
1243 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1249 m
->owner
= new_owner
;
1252 if (SCM_I_IS_THREAD (new_owner
))
1254 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1255 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1256 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1257 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1262 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1264 m
->owner
= new_owner
;
1265 err
= scm_cons (scm_abandoned_mutex_error_key
,
1266 scm_from_locale_string ("lock obtained on abandoned "
1271 else if (scm_is_eq (m
->owner
, new_owner
))
1280 err
= scm_cons (scm_misc_error_key
,
1281 scm_from_locale_string ("mutex already locked "
1289 if (timeout
!= NULL
)
1291 gettimeofday (¤t_time
, NULL
);
1292 if (current_time
.tv_sec
> timeout
->tv_sec
||
1293 (current_time
.tv_sec
== timeout
->tv_sec
&&
1294 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1300 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1301 scm_i_pthread_mutex_unlock (&m
->lock
);
1303 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1306 scm_i_pthread_mutex_unlock (&m
->lock
);
1310 SCM
scm_lock_mutex (SCM mx
)
1312 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1315 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1316 (SCM m
, SCM timeout
, SCM owner
),
1317 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1318 "blocks until the mutex becomes available. The function returns when "
1319 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1320 "a thread already owns will succeed right away and will not block the "
1321 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1322 #define FUNC_NAME s_scm_lock_mutex_timed
1326 scm_t_timespec cwaittime
, *waittime
= NULL
;
1328 SCM_VALIDATE_MUTEX (1, m
);
1330 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1332 to_timespec (timeout
, &cwaittime
);
1333 waittime
= &cwaittime
;
1336 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1337 if (!scm_is_false (exception
))
1338 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1339 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1344 scm_dynwind_lock_mutex (SCM mutex
)
1346 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1347 SCM_F_WIND_EXPLICITLY
);
1348 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1349 SCM_F_WIND_EXPLICITLY
);
1352 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1354 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1355 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1356 #define FUNC_NAME s_scm_try_mutex
1360 scm_t_timespec cwaittime
, *waittime
= NULL
;
1362 SCM_VALIDATE_MUTEX (1, mutex
);
1364 to_timespec (scm_from_int(0), &cwaittime
);
1365 waittime
= &cwaittime
;
1367 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1368 if (!scm_is_false (exception
))
1369 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1370 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1374 /*** Fat condition variables */
1377 scm_i_pthread_mutex_t lock
;
1378 SCM waiting
; /* the threads waiting for this condition. */
1381 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1382 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1385 fat_mutex_unlock (SCM mutex
, SCM cond
,
1386 const scm_t_timespec
*waittime
, int relock
)
1388 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1390 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1391 int err
= 0, ret
= 0;
1393 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1395 SCM owner
= m
->owner
;
1397 if (!scm_is_eq (owner
, scm_current_thread ()))
1401 if (!m
->unchecked_unlock
)
1403 scm_i_pthread_mutex_unlock (&m
->lock
);
1404 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1406 owner
= scm_current_thread ();
1408 else if (!m
->allow_external_unlock
)
1410 scm_i_pthread_mutex_unlock (&m
->lock
);
1411 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1415 if (! (SCM_UNBNDP (cond
)))
1417 c
= SCM_CONDVAR_DATA (cond
);
1422 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1426 m
->owner
= unblock_from_queue (m
->waiting
);
1428 scm_i_pthread_mutex_unlock (&m
->lock
);
1432 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1439 else if (err
== ETIMEDOUT
)
1444 else if (err
!= EINTR
)
1447 scm_i_pthread_mutex_unlock (&c
->lock
);
1448 scm_syserror (NULL
);
1454 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1455 scm_i_pthread_mutex_unlock (&c
->lock
);
1459 scm_i_pthread_mutex_unlock (&c
->lock
);
1464 scm_remember_upto_here_2 (cond
, mutex
);
1466 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1474 m
->owner
= unblock_from_queue (m
->waiting
);
1476 scm_i_pthread_mutex_unlock (&m
->lock
);
1483 SCM
scm_unlock_mutex (SCM mx
)
1485 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1488 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1489 (SCM mx
, SCM cond
, SCM timeout
),
1490 "Unlocks @var{mutex} if the calling thread owns the lock on "
1491 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1492 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1493 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1494 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1495 "with a call to @code{unlock-mutex}. Only the last call to "
1496 "@code{unlock-mutex} will actually unlock the mutex. ")
1497 #define FUNC_NAME s_scm_unlock_mutex_timed
1499 scm_t_timespec cwaittime
, *waittime
= NULL
;
1501 SCM_VALIDATE_MUTEX (1, mx
);
1502 if (! (SCM_UNBNDP (cond
)))
1504 SCM_VALIDATE_CONDVAR (2, cond
);
1506 if (! (SCM_UNBNDP (timeout
)))
1508 to_timespec (timeout
, &cwaittime
);
1509 waittime
= &cwaittime
;
1513 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1517 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1519 "Return @code{#t} if @var{obj} is a mutex.")
1520 #define FUNC_NAME s_scm_mutex_p
1522 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1526 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1528 "Return the thread owning @var{mx}, or @code{#f}.")
1529 #define FUNC_NAME s_scm_mutex_owner
1532 fat_mutex
*m
= NULL
;
1534 SCM_VALIDATE_MUTEX (1, mx
);
1535 m
= SCM_MUTEX_DATA (mx
);
1536 scm_i_pthread_mutex_lock (&m
->lock
);
1538 scm_i_pthread_mutex_unlock (&m
->lock
);
1544 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1546 "Return the lock level of mutex @var{mx}.")
1547 #define FUNC_NAME s_scm_mutex_level
1549 SCM_VALIDATE_MUTEX (1, mx
);
1550 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1554 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1556 "Returns @code{#t} if the mutex @var{mx} is locked.")
1557 #define FUNC_NAME s_scm_mutex_locked_p
1559 SCM_VALIDATE_MUTEX (1, mx
);
1560 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1565 fat_cond_mark (SCM cv
)
1567 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1572 fat_cond_free (SCM mx
)
1574 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1575 scm_i_pthread_mutex_destroy (&c
->lock
);
1576 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1581 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1583 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1584 scm_puts ("#<condition-variable ", port
);
1585 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1586 scm_puts (">", port
);
1590 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1592 "Make a new condition variable.")
1593 #define FUNC_NAME s_scm_make_condition_variable
1598 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1599 scm_i_pthread_mutex_init (&c
->lock
, 0);
1600 c
->waiting
= SCM_EOL
;
1601 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1602 c
->waiting
= make_queue ();
1607 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1608 (SCM cv
, SCM mx
, SCM t
),
1609 "Wait until @var{cond-var} has been signalled. While waiting, "
1610 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1611 "is locked again when this function returns. When @var{time} is given, "
1612 "it specifies a point in time where the waiting should be aborted. It "
1613 "can be either a integer as returned by @code{current-time} or a pair "
1614 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1615 "mutex is locked and @code{#f} is returned. When the condition "
1616 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1618 #define FUNC_NAME s_scm_timed_wait_condition_variable
1620 scm_t_timespec waittime
, *waitptr
= NULL
;
1622 SCM_VALIDATE_CONDVAR (1, cv
);
1623 SCM_VALIDATE_MUTEX (2, mx
);
1625 if (!SCM_UNBNDP (t
))
1627 to_timespec (t
, &waittime
);
1628 waitptr
= &waittime
;
1631 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1636 fat_cond_signal (fat_cond
*c
)
1638 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1639 unblock_from_queue (c
->waiting
);
1640 scm_i_pthread_mutex_unlock (&c
->lock
);
1643 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1645 "Wake up one thread that is waiting for @var{cv}")
1646 #define FUNC_NAME s_scm_signal_condition_variable
1648 SCM_VALIDATE_CONDVAR (1, cv
);
1649 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1655 fat_cond_broadcast (fat_cond
*c
)
1657 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1658 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1660 scm_i_pthread_mutex_unlock (&c
->lock
);
1663 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1665 "Wake up all threads that are waiting for @var{cv}. ")
1666 #define FUNC_NAME s_scm_broadcast_condition_variable
1668 SCM_VALIDATE_CONDVAR (1, cv
);
1669 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1674 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1676 "Return @code{#t} if @var{obj} is a condition variable.")
1677 #define FUNC_NAME s_scm_condition_variable_p
1679 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1683 /*** Marking stacks */
1685 /* XXX - what to do with this? Do we need to handle this for blocked
1689 # define SCM_MARK_BACKING_STORE() do { \
1691 SCM_STACKITEM * top, * bot; \
1692 getcontext (&ctx); \
1693 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1694 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1695 / sizeof (SCM_STACKITEM))); \
1696 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1697 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1698 scm_mark_locations (bot, top - bot); } while (0)
1700 # define SCM_MARK_BACKING_STORE()
1704 scm_threads_mark_stacks (void)
1707 for (t
= all_threads
; t
; t
= t
->next_thread
)
1709 /* Check that thread has indeed been suspended.
1713 scm_gc_mark (t
->handle
);
1715 #if SCM_STACK_GROWS_UP
1716 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1718 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1720 scm_mark_locations ((SCM_STACKITEM
*) &t
->regs
,
1721 ((size_t) sizeof(t
->regs
)
1722 / sizeof (SCM_STACKITEM
)));
1725 SCM_MARK_BACKING_STORE ();
1731 scm_std_select (int nfds
,
1732 SELECT_TYPE
*readfds
,
1733 SELECT_TYPE
*writefds
,
1734 SELECT_TYPE
*exceptfds
,
1735 struct timeval
*timeout
)
1738 int res
, eno
, wakeup_fd
;
1739 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1740 scm_t_guile_ticket ticket
;
1742 if (readfds
== NULL
)
1744 FD_ZERO (&my_readfds
);
1745 readfds
= &my_readfds
;
1748 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1751 wakeup_fd
= t
->sleep_pipe
[0];
1752 ticket
= scm_leave_guile ();
1753 FD_SET (wakeup_fd
, readfds
);
1754 if (wakeup_fd
>= nfds
)
1756 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1759 scm_enter_guile (ticket
);
1761 scm_i_reset_sleep (t
);
1763 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1766 read (wakeup_fd
, &dummy
, 1);
1767 FD_CLR (wakeup_fd
, readfds
);
1779 /* Convenience API for blocking while in guile mode. */
1781 #if SCM_USE_PTHREAD_THREADS
1784 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1786 scm_t_guile_ticket t
= scm_leave_guile ();
1787 int res
= scm_i_pthread_mutex_lock (mutex
);
1788 scm_enter_guile (t
);
1793 do_unlock (void *data
)
1795 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1799 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1801 scm_i_scm_pthread_mutex_lock (mutex
);
1802 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1806 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1808 scm_t_guile_ticket t
= scm_leave_guile ();
1809 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1810 scm_enter_guile (t
);
1815 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1816 scm_i_pthread_mutex_t
*mutex
,
1817 const scm_t_timespec
*wt
)
1819 scm_t_guile_ticket t
= scm_leave_guile ();
1820 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1821 scm_enter_guile (t
);
1828 scm_std_usleep (unsigned long usecs
)
1831 tv
.tv_usec
= usecs
% 1000000;
1832 tv
.tv_sec
= usecs
/ 1000000;
1833 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1834 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1838 scm_std_sleep (unsigned int secs
)
1843 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1849 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1851 "Return the thread that called this function.")
1852 #define FUNC_NAME s_scm_current_thread
1854 return SCM_I_CURRENT_THREAD
->handle
;
1859 scm_c_make_list (size_t n
, SCM fill
)
1863 res
= scm_cons (fill
, res
);
1867 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1869 "Return a list of all threads.")
1870 #define FUNC_NAME s_scm_all_threads
1872 /* We can not allocate while holding the thread_admin_mutex because
1873 of the way GC is done.
1875 int n
= thread_count
;
1877 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1879 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1881 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1883 if (t
!= scm_i_signal_delivery_thread
)
1885 SCM_SETCAR (*l
, t
->handle
);
1886 l
= SCM_CDRLOC (*l
);
1891 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1896 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1898 "Return @code{#t} iff @var{thread} has exited.\n")
1899 #define FUNC_NAME s_scm_thread_exited_p
1901 return scm_from_bool (scm_c_thread_exited_p (thread
));
1906 scm_c_thread_exited_p (SCM thread
)
1907 #define FUNC_NAME s_scm_thread_exited_p
1910 SCM_VALIDATE_THREAD (1, thread
);
1911 t
= SCM_I_THREAD_DATA (thread
);
1916 static scm_i_pthread_cond_t wake_up_cond
;
1917 int scm_i_thread_go_to_sleep
;
1918 static int threads_initialized_p
= 0;
1921 scm_i_thread_put_to_sleep ()
1923 if (threads_initialized_p
)
1928 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1930 /* Signal all threads to go to sleep
1932 scm_i_thread_go_to_sleep
= 1;
1933 for (t
= all_threads
; t
; t
= t
->next_thread
)
1934 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1935 scm_i_thread_go_to_sleep
= 0;
1940 scm_i_thread_invalidate_freelists ()
1942 /* thread_admin_mutex is already locked. */
1945 for (t
= all_threads
; t
; t
= t
->next_thread
)
1946 if (t
!= SCM_I_CURRENT_THREAD
)
1947 t
->clear_freelists_p
= 1;
1951 scm_i_thread_wake_up ()
1953 if (threads_initialized_p
)
1957 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1958 for (t
= all_threads
; t
; t
= t
->next_thread
)
1959 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1960 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1961 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1966 scm_i_thread_sleep_for_gc ()
1968 scm_i_thread
*t
= suspend ();
1969 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1973 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1975 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
1976 int scm_i_critical_section_level
= 0;
1978 static SCM dynwind_critical_section_mutex
;
1981 scm_dynwind_critical_section (SCM mutex
)
1983 if (scm_is_false (mutex
))
1984 mutex
= dynwind_critical_section_mutex
;
1985 scm_dynwind_lock_mutex (mutex
);
1986 scm_dynwind_block_asyncs ();
1989 /*** Initialization */
1991 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1992 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1994 #if SCM_USE_PTHREAD_THREADS
1995 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
1999 scm_threads_prehistory (SCM_STACKITEM
*base
)
2001 #if SCM_USE_PTHREAD_THREADS
2002 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2003 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2004 PTHREAD_MUTEX_RECURSIVE
);
2007 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2008 scm_i_pthread_mutexattr_recursive
);
2009 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2010 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2011 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
2012 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
2014 guilify_self_1 (base
);
2017 scm_t_bits scm_tc16_thread
;
2018 scm_t_bits scm_tc16_mutex
;
2019 scm_t_bits scm_tc16_condvar
;
2024 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2025 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
2026 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2027 scm_set_smob_free (scm_tc16_thread
, thread_free
);
2029 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2030 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
2031 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2032 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2034 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2036 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
2037 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2038 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2040 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2041 guilify_self_2 (SCM_BOOL_F
);
2042 threads_initialized_p
= 1;
2044 dynwind_critical_section_mutex
=
2045 scm_permanent_object (scm_make_recursive_mutex ());
2049 scm_init_threads_default_dynamic_state ()
2051 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2052 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2056 scm_init_thread_procs ()
2058 #include "libguile/threads.x"