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__ */
64 #include <full-read.h>
68 to_timespec (SCM t
, scm_t_timespec
*waittime
)
72 waittime
->tv_sec
= scm_to_ulong (SCM_CAR (t
));
73 waittime
->tv_nsec
= scm_to_ulong (SCM_CDR (t
)) * 1000;
77 double time
= scm_to_double (t
);
78 double sec
= scm_c_truncate (time
);
80 waittime
->tv_sec
= (long) sec
;
81 waittime
->tv_nsec
= (long) ((time
- sec
) * 1000000000);
87 /* Make an empty queue data structure.
92 return scm_cons (SCM_EOL
, SCM_EOL
);
95 /* Put T at the back of Q and return a handle that can be used with
96 remqueue to remove T from Q again.
99 enqueue (SCM q
, SCM t
)
101 SCM c
= scm_cons (t
, SCM_EOL
);
102 SCM_CRITICAL_SECTION_START
;
103 if (scm_is_null (SCM_CDR (q
)))
106 SCM_SETCDR (SCM_CAR (q
), c
);
108 SCM_CRITICAL_SECTION_END
;
112 /* Remove the element that the handle C refers to from the queue Q. C
113 must have been returned from a call to enqueue. The return value
114 is zero when the element referred to by C has already been removed.
115 Otherwise, 1 is returned.
118 remqueue (SCM q
, SCM c
)
121 SCM_CRITICAL_SECTION_START
;
122 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
124 if (scm_is_eq (p
, c
))
126 if (scm_is_eq (c
, SCM_CAR (q
)))
127 SCM_SETCAR (q
, SCM_CDR (c
));
128 SCM_SETCDR (prev
, SCM_CDR (c
));
129 SCM_CRITICAL_SECTION_END
;
134 SCM_CRITICAL_SECTION_END
;
138 /* Remove the front-most element from the queue Q and return it.
139 Return SCM_BOOL_F when Q is empty.
145 SCM_CRITICAL_SECTION_START
;
149 SCM_CRITICAL_SECTION_END
;
154 SCM_SETCDR (q
, SCM_CDR (c
));
155 if (scm_is_null (SCM_CDR (q
)))
156 SCM_SETCAR (q
, SCM_EOL
);
157 SCM_CRITICAL_SECTION_END
;
162 /*** Thread smob routines */
165 thread_mark (SCM obj
)
167 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
168 scm_gc_mark (t
->result
);
169 scm_gc_mark (t
->cleanup_handler
);
170 scm_gc_mark (t
->join_queue
);
171 scm_gc_mark (t
->mutexes
);
172 scm_gc_mark (t
->dynwinds
);
173 scm_gc_mark (t
->active_asyncs
);
174 scm_gc_mark (t
->continuation_root
);
176 return t
->dynamic_state
;
180 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
182 /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
183 struct. A cast like "(unsigned long) t->pthread" is a syntax error in
184 the struct case, hence we go via a union, and extract according to the
185 size of pthread_t. */
193 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
194 scm_i_pthread_t p
= t
->pthread
;
197 if (sizeof (p
) == sizeof (unsigned short))
199 else if (sizeof (p
) == sizeof (unsigned int))
201 else if (sizeof (p
) == sizeof (unsigned long))
206 scm_puts ("#<thread ", port
);
207 scm_uintprint (id
, 10, port
);
208 scm_puts (" (", port
);
209 scm_uintprint ((scm_t_bits
)t
, 16, port
);
210 scm_puts (")>", port
);
215 thread_free (SCM obj
)
217 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
219 scm_gc_free (t
, sizeof (*t
), "thread");
223 /*** Blocking on queues. */
225 /* See also scm_i_queue_async_cell for how such a block is
229 /* Put the current thread on QUEUE and go to sleep, waiting for it to
230 be woken up by a call to 'unblock_from_queue', or to be
231 interrupted. Upon return of this function, the current thread is
232 no longer on QUEUE, even when the sleep has been interrupted.
234 The caller of block_self must hold MUTEX. It will be atomically
235 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
237 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
240 When WAITTIME is not NULL, the sleep will be aborted at that time.
242 The return value of block_self is an errno value. It will be zero
243 when the sleep has been successfully completed by a call to
244 unblock_from_queue, EINTR when it has been interrupted by the
245 delivery of a system async, and ETIMEDOUT when the timeout has
248 The system asyncs themselves are not executed by block_self.
251 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
252 const scm_t_timespec
*waittime
)
254 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
258 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
263 q_handle
= enqueue (queue
, t
->handle
);
264 if (waittime
== NULL
)
265 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
267 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
269 /* When we are still on QUEUE, we have been interrupted. We
270 report this only when no other error (such as a timeout) has
273 if (remqueue (queue
, q_handle
) && err
== 0)
276 scm_i_reset_sleep (t
);
282 /* Wake up the first thread on QUEUE, if any. The awoken thread is
283 returned, or #f if the queue was empty.
286 unblock_from_queue (SCM queue
)
288 SCM thread
= dequeue (queue
);
289 if (scm_is_true (thread
))
290 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
294 /* Getting into and out of guile mode.
297 /* Ken Raeburn observes that the implementation of suspend and resume
298 (and the things that build on top of them) are very likely not
299 correct (see below). We will need fix this eventually, and that's
300 why scm_leave_guile/scm_enter_guile are not exported in the API.
304 Consider this sequence:
306 Function foo, called in Guile mode, calls suspend (maybe indirectly
307 through scm_leave_guile), which does this:
309 // record top of stack for the GC
310 t->top = SCM_STACK_PTR (&t); // just takes address of automatic
313 SCM_FLUSH_REGISTER_WINDOWS; // sparc only
314 setjmp (t->regs); // here's most of the magic
318 Function foo has a SCM value X, a handle on a non-immediate object, in
319 a caller-saved register R, and it's the only reference to the object
322 The compiler wants to use R in suspend, so it pushes the current
323 value, X, into a stack slot which will be reloaded on exit from
324 suspend; then it loads stuff into R and goes about its business. The
325 setjmp call saves (some of) the current registers, including R, which
326 no longer contains X. (This isn't a problem for a normal
327 setjmp/longjmp situation, where longjmp would be called before
328 setjmp's caller returns; the old value for X would be loaded back from
329 the stack after the longjmp, before the function returned.)
331 So, suspend returns, loading X back into R (and invalidating the jump
332 buffer) in the process. The caller foo then goes off and calls a
333 bunch of other functions out of Guile mode, occasionally storing X on
334 the stack again, but, say, much deeper on the stack than suspend's
335 stack frame went, and the stack slot where suspend had written X has
336 long since been overwritten with other values.
338 Okay, nothing actively broken so far. Now, let garbage collection
339 run, triggered by another thread.
341 The thread calling foo is out of Guile mode at the time, so the
342 garbage collector just scans a range of stack addresses. Too bad that
343 X isn't stored there. So the pointed-to storage goes onto the free
344 list, and I think you can see where things go from there.
346 Is there anything I'm missing that'll prevent this scenario from
347 happening? I mean, aside from, "well, suspend and scm_leave_guile
348 don't have many local variables, so they probably won't need to save
349 any registers on most systems, so we hope everything will wind up in
350 the jump buffer and we'll just get away with it"?
352 (And, going the other direction, if scm_leave_guile and suspend push
353 the stack pointer over onto a new page, and foo doesn't make further
354 function calls and thus the stack pointer no longer includes that
355 page, are we guaranteed that the kernel cannot release the now-unused
356 stack page that contains the top-of-stack pointer we just saved? I
357 don't know if any OS actually does that. If it does, we could get
358 faults in garbage collection.)
360 I don't think scm_without_guile has to have this problem, as it gets
361 more control over the stack handling -- but it should call setjmp
362 itself. I'd probably try something like:
364 // record top of stack for the GC
365 t->top = SCM_STACK_PTR (&t);
367 SCM_FLUSH_REGISTER_WINDOWS;
372 ... though even that's making some assumptions about the stack
373 ordering of local variables versus caller-saved registers.
375 For something like scm_leave_guile to work, I don't think it can just
376 rely on invalidated jump buffers. A valid jump buffer, and a handle
377 on the stack state at the point when the jump buffer was initialized,
378 together, would work fine, but I think then we're talking about macros
379 invoking setjmp in the caller's stack frame, and requiring that the
380 caller of scm_leave_guile also call scm_enter_guile before returning,
381 kind of like pthread_cleanup_push/pop calls that have to be paired up
382 in a function. (In fact, the pthread ones have to be paired up
383 syntactically, as if they might expand to a compound statement
384 incorporating the user's code, and invoking a compiler's
385 exception-handling primitives. Which might be something to think
386 about for cases where Guile is used with C++ exceptions or
390 scm_i_pthread_key_t scm_i_thread_key
;
393 resume (scm_i_thread
*t
)
396 if (t
->clear_freelists_p
)
398 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
399 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
400 t
->clear_freelists_p
= 0;
404 typedef void* scm_t_guile_ticket
;
407 scm_enter_guile (scm_t_guile_ticket ticket
)
409 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
412 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
413 t
->heap_mutex_locked_by_self
= 1;
418 static scm_i_thread
*
421 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
423 /* record top of stack for the GC */
424 t
->top
= SCM_STACK_PTR (&t
);
425 /* save registers. */
426 SCM_FLUSH_REGISTER_WINDOWS
;
431 static scm_t_guile_ticket
434 scm_i_thread
*t
= suspend ();
435 if (t
->heap_mutex_locked_by_self
)
437 t
->heap_mutex_locked_by_self
= 0;
438 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
440 return (scm_t_guile_ticket
) t
;
443 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
444 static scm_i_thread
*all_threads
= NULL
;
445 static int thread_count
;
447 static SCM scm_i_default_dynamic_state
;
449 /* Perform first stage of thread initialisation, in non-guile mode.
452 guilify_self_1 (SCM_STACKITEM
*base
)
454 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
456 t
->pthread
= scm_i_pthread_self ();
457 t
->handle
= SCM_BOOL_F
;
458 t
->result
= SCM_BOOL_F
;
459 t
->cleanup_handler
= SCM_BOOL_F
;
460 t
->mutexes
= SCM_EOL
;
461 t
->held_mutex
= NULL
;
462 t
->join_queue
= SCM_EOL
;
463 t
->dynamic_state
= SCM_BOOL_F
;
464 t
->dynwinds
= SCM_EOL
;
465 t
->active_asyncs
= SCM_EOL
;
467 t
->pending_asyncs
= 1;
468 t
->last_debug_frame
= NULL
;
471 /* Calculate and store off the base of this thread's register
472 backing store (RBS). Unfortunately our implementation(s) of
473 scm_ia64_register_backing_store_base are only reliable for the
474 main thread. For other threads, therefore, find out the current
475 top of the RBS, and use that as a maximum. */
476 t
->register_backing_store_base
= scm_ia64_register_backing_store_base ();
481 bsp
= scm_ia64_ar_bsp (&ctx
);
482 if (t
->register_backing_store_base
> bsp
)
483 t
->register_backing_store_base
= bsp
;
486 t
->continuation_root
= SCM_EOL
;
487 t
->continuation_base
= base
;
488 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
489 t
->sleep_mutex
= NULL
;
490 t
->sleep_object
= SCM_BOOL_F
;
493 if (pipe (t
->sleep_pipe
) != 0)
494 /* FIXME: Error conditions during the initialization phase are handled
495 gracelessly since public functions such as `scm_init_guile ()'
496 currently have type `void'. */
499 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
500 t
->heap_mutex_locked_by_self
= 0;
501 scm_i_pthread_mutex_init (&t
->admin_mutex
, NULL
);
502 t
->clear_freelists_p
= 0;
507 t
->freelist
= SCM_EOL
;
508 t
->freelist2
= SCM_EOL
;
509 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
510 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
512 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
514 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
515 t
->heap_mutex_locked_by_self
= 1;
517 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
518 t
->next_thread
= all_threads
;
521 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
524 /* Perform second stage of thread initialisation, in guile mode.
527 guilify_self_2 (SCM parent
)
529 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
531 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
532 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
533 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
534 t
->continuation_base
= t
->base
;
537 if (scm_is_true (parent
))
538 t
->dynamic_state
= scm_make_dynamic_state (parent
);
540 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
542 t
->join_queue
= make_queue ();
549 /* We implement our own mutex type since we want them to be 'fair', we
550 want to do fancy things while waiting for them (like running
551 asyncs) and we might want to add things that are nice for
556 scm_i_pthread_mutex_t lock
;
558 int level
; /* how much the owner owns us. <= 1 for non-recursive mutexes */
560 int recursive
; /* allow recursive locking? */
561 int unchecked_unlock
; /* is it an error to unlock an unlocked mutex? */
562 int allow_external_unlock
; /* is it an error to unlock a mutex that is not
563 owned by the current thread? */
565 SCM waiting
; /* the threads waiting for this mutex. */
568 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
569 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
571 /* Perform thread tear-down, in guile mode.
574 do_thread_exit (void *v
)
576 scm_i_thread
*t
= (scm_i_thread
*) v
;
578 if (!scm_is_false (t
->cleanup_handler
))
580 SCM ptr
= t
->cleanup_handler
;
582 t
->cleanup_handler
= SCM_BOOL_F
;
583 t
->result
= scm_internal_catch (SCM_BOOL_T
,
584 (scm_t_catch_body
) scm_call_0
, ptr
,
585 scm_handle_by_message_noexit
, NULL
);
588 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
591 close (t
->sleep_pipe
[0]);
592 close (t
->sleep_pipe
[1]);
593 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
596 while (!scm_is_null (t
->mutexes
))
598 SCM mutex
= SCM_CAR (t
->mutexes
);
599 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
600 scm_i_pthread_mutex_lock (&m
->lock
);
602 unblock_from_queue (m
->waiting
);
604 scm_i_pthread_mutex_unlock (&m
->lock
);
605 t
->mutexes
= SCM_CDR (t
->mutexes
);
608 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
614 on_thread_exit (void *v
)
616 /* This handler is executed in non-guile mode. */
617 scm_i_thread
*t
= (scm_i_thread
*) v
, **tp
;
619 /* If this thread was cancelled while doing a cond wait, it will
620 still have a mutex locked, so we unlock it here. */
623 scm_i_pthread_mutex_unlock (t
->held_mutex
);
624 t
->held_mutex
= NULL
;
627 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
629 /* Ensure the signal handling thread has been launched, because we might be
631 scm_i_ensure_signal_delivery_thread ();
633 /* Unblocking the joining threads needs to happen in guile mode
634 since the queue is a SCM data structure. */
635 scm_with_guile (do_thread_exit
, v
);
637 /* Removing ourself from the list of all threads needs to happen in
638 non-guile mode since all SCM values on our stack become
639 unprotected once we are no longer in the list. */
640 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
641 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
644 *tp
= t
->next_thread
;
649 /* If there's only one other thread, it could be the signal delivery
650 thread, so we need to notify it to shut down by closing its read pipe.
651 If it's not the signal delivery thread, then closing the read pipe isn't
653 if (thread_count
<= 1)
654 scm_i_close_signal_pipe ();
656 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
658 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
661 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
664 init_thread_key (void)
666 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
669 /* Perform any initializations necessary to bring the current thread
670 into guile mode, initializing Guile itself, if necessary.
672 BASE is the stack base to use with GC.
674 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
675 which case the default dynamic state is used.
677 Return zero when the thread was in guile mode already; otherwise
682 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
686 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
688 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
690 /* This thread has not been guilified yet.
693 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
694 if (scm_initialized_p
== 0)
696 /* First thread ever to enter Guile. Run the full
699 scm_i_init_guile (base
);
700 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
704 /* Guile is already initialized, but this thread enters it for
705 the first time. Only initialize this thread.
707 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
708 guilify_self_1 (base
);
709 guilify_self_2 (parent
);
715 /* This thread is already guilified but not in guile mode, just
718 A user call to scm_with_guile() will lead us to here. This could
719 happen from anywhere on the stack, and in particular lower on the
720 stack than when it was when this thread was first guilified. Thus,
721 `base' must be updated. */
722 #if SCM_STACK_GROWS_UP
730 scm_enter_guile ((scm_t_guile_ticket
) t
);
735 /* Thread is already in guile mode. Nothing to do.
741 #if SCM_USE_PTHREAD_THREADS
743 #if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
744 /* This method for GNU/Linux and perhaps some other systems.
745 It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
746 available on them. */
747 #define HAVE_GET_THREAD_STACK_BASE
749 static SCM_STACKITEM
*
750 get_thread_stack_base ()
756 pthread_getattr_np (pthread_self (), &attr
);
757 pthread_attr_getstack (&attr
, &start
, &size
);
758 end
= (char *)start
+ size
;
760 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
761 for the main thread, but we can use scm_get_stack_base in that
765 #ifndef PTHREAD_ATTR_GETSTACK_WORKS
766 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
767 return scm_get_stack_base ();
771 #if SCM_STACK_GROWS_UP
779 #elif HAVE_PTHREAD_GET_STACKADDR_NP
780 /* This method for MacOS X.
781 It'd be nice if there was some documentation on pthread_get_stackaddr_np,
782 but as of 2006 there's nothing obvious at apple.com. */
783 #define HAVE_GET_THREAD_STACK_BASE
784 static SCM_STACKITEM
*
785 get_thread_stack_base ()
787 return pthread_get_stackaddr_np (pthread_self ());
790 #elif defined (__MINGW32__)
791 /* This method for mingw. In mingw the basic scm_get_stack_base can be used
792 in any thread. We don't like hard-coding the name of a system, but there
793 doesn't seem to be a cleaner way of knowing scm_get_stack_base can
795 #define HAVE_GET_THREAD_STACK_BASE
796 static SCM_STACKITEM
*
797 get_thread_stack_base ()
799 return scm_get_stack_base ();
802 #endif /* pthread methods of get_thread_stack_base */
804 #else /* !SCM_USE_PTHREAD_THREADS */
806 #define HAVE_GET_THREAD_STACK_BASE
808 static SCM_STACKITEM
*
809 get_thread_stack_base ()
811 return scm_get_stack_base ();
814 #endif /* !SCM_USE_PTHREAD_THREADS */
816 #ifdef HAVE_GET_THREAD_STACK_BASE
821 scm_i_init_thread_for_guile (get_thread_stack_base (),
822 scm_i_default_dynamic_state
);
828 scm_with_guile (void *(*func
)(void *), void *data
)
830 return scm_i_with_guile_and_parent (func
, data
,
831 scm_i_default_dynamic_state
);
834 SCM_UNUSED
static void
835 scm_leave_guile_cleanup (void *x
)
841 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
, SCM parent
)
845 SCM_STACKITEM base_item
;
847 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
850 scm_i_pthread_cleanup_push (scm_leave_guile_cleanup
, NULL
);
851 res
= scm_c_with_continuation_barrier (func
, data
);
852 scm_i_pthread_cleanup_pop (0);
856 res
= scm_c_with_continuation_barrier (func
, data
);
862 scm_without_guile (void *(*func
)(void *), void *data
)
865 scm_t_guile_ticket t
;
866 t
= scm_leave_guile ();
872 /*** Thread creation */
879 scm_i_pthread_mutex_t mutex
;
880 scm_i_pthread_cond_t cond
;
884 really_launch (void *d
)
886 launch_data
*data
= (launch_data
*)d
;
887 SCM thunk
= data
->thunk
, handler
= data
->handler
;
890 t
= SCM_I_CURRENT_THREAD
;
892 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
893 data
->thread
= scm_current_thread ();
894 scm_i_pthread_cond_signal (&data
->cond
);
895 scm_i_pthread_mutex_unlock (&data
->mutex
);
897 if (SCM_UNBNDP (handler
))
898 t
->result
= scm_call_0 (thunk
);
900 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
906 launch_thread (void *d
)
908 launch_data
*data
= (launch_data
*)d
;
909 scm_i_pthread_detach (scm_i_pthread_self ());
910 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
914 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
915 (SCM thunk
, SCM handler
),
916 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
917 "returning a new thread object representing the thread. The procedure\n"
918 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
920 "When @var{handler} is specified, then @var{thunk} is called from\n"
921 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
922 "handler. This catch is established inside the continuation barrier.\n"
924 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
925 "the @emph{exit value} of the thread and the thread is terminated.")
926 #define FUNC_NAME s_scm_call_with_new_thread
932 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
933 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
934 handler
, SCM_ARG2
, FUNC_NAME
);
936 data
.parent
= scm_current_dynamic_state ();
938 data
.handler
= handler
;
939 data
.thread
= SCM_BOOL_F
;
940 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
941 scm_i_pthread_cond_init (&data
.cond
, NULL
);
943 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
944 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
947 scm_i_pthread_mutex_unlock (&data
.mutex
);
951 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
952 scm_i_pthread_mutex_unlock (&data
.mutex
);
960 scm_t_catch_body body
;
962 scm_t_catch_handler handler
;
965 scm_i_pthread_mutex_t mutex
;
966 scm_i_pthread_cond_t cond
;
970 really_spawn (void *d
)
972 spawn_data
*data
= (spawn_data
*)d
;
973 scm_t_catch_body body
= data
->body
;
974 void *body_data
= data
->body_data
;
975 scm_t_catch_handler handler
= data
->handler
;
976 void *handler_data
= data
->handler_data
;
977 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
979 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
980 data
->thread
= scm_current_thread ();
981 scm_i_pthread_cond_signal (&data
->cond
);
982 scm_i_pthread_mutex_unlock (&data
->mutex
);
985 t
->result
= body (body_data
);
987 t
->result
= scm_internal_catch (SCM_BOOL_T
,
989 handler
, handler_data
);
995 spawn_thread (void *d
)
997 spawn_data
*data
= (spawn_data
*)d
;
998 scm_i_pthread_detach (scm_i_pthread_self ());
999 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
1004 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
1005 scm_t_catch_handler handler
, void *handler_data
)
1011 data
.parent
= scm_current_dynamic_state ();
1013 data
.body_data
= body_data
;
1014 data
.handler
= handler
;
1015 data
.handler_data
= handler_data
;
1016 data
.thread
= SCM_BOOL_F
;
1017 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
1018 scm_i_pthread_cond_init (&data
.cond
, NULL
);
1020 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
1021 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
1024 scm_i_pthread_mutex_unlock (&data
.mutex
);
1026 scm_syserror (NULL
);
1028 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
1029 scm_i_pthread_mutex_unlock (&data
.mutex
);
1034 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
1036 "Move the calling thread to the end of the scheduling queue.")
1037 #define FUNC_NAME s_scm_yield
1039 return scm_from_bool (scm_i_sched_yield ());
1043 SCM_DEFINE (scm_cancel_thread
, "cancel-thread", 1, 0, 0,
1045 "Asynchronously force the target @var{thread} to terminate. @var{thread} "
1046 "cannot be the current thread, and if @var{thread} has already terminated or "
1047 "been signaled to terminate, this function is a no-op.")
1048 #define FUNC_NAME s_scm_cancel_thread
1050 scm_i_thread
*t
= NULL
;
1052 SCM_VALIDATE_THREAD (1, thread
);
1053 t
= SCM_I_THREAD_DATA (thread
);
1054 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1058 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1059 scm_i_pthread_cancel (t
->pthread
);
1062 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1064 return SCM_UNSPECIFIED
;
1068 SCM_DEFINE (scm_set_thread_cleanup_x
, "set-thread-cleanup!", 2, 0, 0,
1069 (SCM thread
, SCM proc
),
1070 "Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. "
1071 "This handler will be called when the thread exits.")
1072 #define FUNC_NAME s_scm_set_thread_cleanup_x
1076 SCM_VALIDATE_THREAD (1, thread
);
1077 if (!scm_is_false (proc
))
1078 SCM_VALIDATE_THUNK (2, proc
);
1080 t
= SCM_I_THREAD_DATA (thread
);
1081 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1083 if (!(t
->exited
|| t
->canceled
))
1084 t
->cleanup_handler
= proc
;
1086 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1088 return SCM_UNSPECIFIED
;
1092 SCM_DEFINE (scm_thread_cleanup
, "thread-cleanup", 1, 0, 0,
1094 "Return the cleanup handler installed for the thread @var{thread}.")
1095 #define FUNC_NAME s_scm_thread_cleanup
1100 SCM_VALIDATE_THREAD (1, thread
);
1102 t
= SCM_I_THREAD_DATA (thread
);
1103 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1104 ret
= (t
->exited
|| t
->canceled
) ? SCM_BOOL_F
: t
->cleanup_handler
;
1105 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1111 SCM
scm_join_thread (SCM thread
)
1113 return scm_join_thread_timed (thread
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1116 SCM_DEFINE (scm_join_thread_timed
, "join-thread", 1, 2, 0,
1117 (SCM thread
, SCM timeout
, SCM timeoutval
),
1118 "Suspend execution of the calling thread until the target @var{thread} "
1119 "terminates, unless the target @var{thread} has already terminated. ")
1120 #define FUNC_NAME s_scm_join_thread_timed
1123 scm_t_timespec ctimeout
, *timeout_ptr
= NULL
;
1124 SCM res
= SCM_BOOL_F
;
1126 if (! (SCM_UNBNDP (timeoutval
)))
1129 SCM_VALIDATE_THREAD (1, thread
);
1130 if (scm_is_eq (scm_current_thread (), thread
))
1131 SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL
);
1133 t
= SCM_I_THREAD_DATA (thread
);
1134 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1136 if (! SCM_UNBNDP (timeout
))
1138 to_timespec (timeout
, &ctimeout
);
1139 timeout_ptr
= &ctimeout
;
1148 int err
= block_self (t
->join_queue
, thread
, &t
->admin_mutex
,
1158 else if (err
== ETIMEDOUT
)
1161 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1163 scm_i_scm_pthread_mutex_lock (&t
->admin_mutex
);
1165 /* Check for exit again, since we just released and
1166 reacquired the admin mutex, before the next block_self
1167 call (which would block forever if t has already
1177 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1183 SCM_DEFINE (scm_thread_p
, "thread?", 1, 0, 0,
1185 "Return @code{#t} if @var{obj} is a thread.")
1186 #define FUNC_NAME s_scm_thread_p
1188 return SCM_I_IS_THREAD(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1193 fat_mutex_mark (SCM mx
)
1195 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1196 scm_gc_mark (m
->owner
);
1201 fat_mutex_free (SCM mx
)
1203 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1204 scm_i_pthread_mutex_destroy (&m
->lock
);
1205 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
1210 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1212 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
1213 scm_puts ("#<mutex ", port
);
1214 scm_uintprint ((scm_t_bits
)m
, 16, port
);
1215 scm_puts (">", port
);
1220 make_fat_mutex (int recursive
, int unchecked_unlock
, int external_unlock
)
1225 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
1226 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
1227 m
->owner
= SCM_BOOL_F
;
1230 m
->recursive
= recursive
;
1231 m
->unchecked_unlock
= unchecked_unlock
;
1232 m
->allow_external_unlock
= external_unlock
;
1234 m
->waiting
= SCM_EOL
;
1235 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
1236 m
->waiting
= make_queue ();
1240 SCM
scm_make_mutex (void)
1242 return scm_make_mutex_with_flags (SCM_EOL
);
1245 SCM_SYMBOL (unchecked_unlock_sym
, "unchecked-unlock");
1246 SCM_SYMBOL (allow_external_unlock_sym
, "allow-external-unlock");
1247 SCM_SYMBOL (recursive_sym
, "recursive");
1249 SCM_DEFINE (scm_make_mutex_with_flags
, "make-mutex", 0, 0, 1,
1251 "Create a new mutex. ")
1252 #define FUNC_NAME s_scm_make_mutex_with_flags
1254 int unchecked_unlock
= 0, external_unlock
= 0, recursive
= 0;
1257 while (! scm_is_null (ptr
))
1259 SCM flag
= SCM_CAR (ptr
);
1260 if (scm_is_eq (flag
, unchecked_unlock_sym
))
1261 unchecked_unlock
= 1;
1262 else if (scm_is_eq (flag
, allow_external_unlock_sym
))
1263 external_unlock
= 1;
1264 else if (scm_is_eq (flag
, recursive_sym
))
1267 SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag
));
1268 ptr
= SCM_CDR (ptr
);
1270 return make_fat_mutex (recursive
, unchecked_unlock
, external_unlock
);
1274 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
1276 "Create a new recursive mutex. ")
1277 #define FUNC_NAME s_scm_make_recursive_mutex
1279 return make_fat_mutex (1, 0, 0);
1283 SCM_SYMBOL (scm_abandoned_mutex_error_key
, "abandoned-mutex-error");
1286 fat_mutex_lock (SCM mutex
, scm_t_timespec
*timeout
, SCM owner
, int *ret
)
1288 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1290 SCM new_owner
= SCM_UNBNDP (owner
) ? scm_current_thread() : owner
;
1291 SCM err
= SCM_BOOL_F
;
1293 struct timeval current_time
;
1295 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1301 m
->owner
= new_owner
;
1304 if (SCM_I_IS_THREAD (new_owner
))
1306 scm_i_thread
*t
= SCM_I_THREAD_DATA (new_owner
);
1307 scm_i_pthread_mutex_lock (&t
->admin_mutex
);
1308 t
->mutexes
= scm_cons (mutex
, t
->mutexes
);
1309 scm_i_pthread_mutex_unlock (&t
->admin_mutex
);
1314 else if (SCM_I_IS_THREAD (m
->owner
) && scm_c_thread_exited_p (m
->owner
))
1316 m
->owner
= new_owner
;
1317 err
= scm_cons (scm_abandoned_mutex_error_key
,
1318 scm_from_locale_string ("lock obtained on abandoned "
1323 else if (scm_is_eq (m
->owner
, new_owner
))
1332 err
= scm_cons (scm_misc_error_key
,
1333 scm_from_locale_string ("mutex already locked "
1341 if (timeout
!= NULL
)
1343 gettimeofday (¤t_time
, NULL
);
1344 if (current_time
.tv_sec
> timeout
->tv_sec
||
1345 (current_time
.tv_sec
== timeout
->tv_sec
&&
1346 current_time
.tv_usec
* 1000 > timeout
->tv_nsec
))
1352 block_self (m
->waiting
, mutex
, &m
->lock
, timeout
);
1353 scm_i_pthread_mutex_unlock (&m
->lock
);
1355 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1358 scm_i_pthread_mutex_unlock (&m
->lock
);
1362 SCM
scm_lock_mutex (SCM mx
)
1364 return scm_lock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1367 SCM_DEFINE (scm_lock_mutex_timed
, "lock-mutex", 1, 2, 0,
1368 (SCM m
, SCM timeout
, SCM owner
),
1369 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
1370 "blocks until the mutex becomes available. The function returns when "
1371 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
1372 "a thread already owns will succeed right away and will not block the "
1373 "thread. That is, Guile's mutexes are @emph{recursive}. ")
1374 #define FUNC_NAME s_scm_lock_mutex_timed
1378 scm_t_timespec cwaittime
, *waittime
= NULL
;
1380 SCM_VALIDATE_MUTEX (1, m
);
1382 if (! SCM_UNBNDP (timeout
) && ! scm_is_false (timeout
))
1384 to_timespec (timeout
, &cwaittime
);
1385 waittime
= &cwaittime
;
1388 exception
= fat_mutex_lock (m
, waittime
, owner
, &ret
);
1389 if (!scm_is_false (exception
))
1390 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1391 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1396 scm_dynwind_lock_mutex (SCM mutex
)
1398 scm_dynwind_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
1399 SCM_F_WIND_EXPLICITLY
);
1400 scm_dynwind_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
1401 SCM_F_WIND_EXPLICITLY
);
1404 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
1406 "Try to lock @var{mutex}. If the mutex is already locked by someone "
1407 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
1408 #define FUNC_NAME s_scm_try_mutex
1412 scm_t_timespec cwaittime
, *waittime
= NULL
;
1414 SCM_VALIDATE_MUTEX (1, mutex
);
1416 to_timespec (scm_from_int(0), &cwaittime
);
1417 waittime
= &cwaittime
;
1419 exception
= fat_mutex_lock (mutex
, waittime
, SCM_UNDEFINED
, &ret
);
1420 if (!scm_is_false (exception
))
1421 scm_ithrow (SCM_CAR (exception
), scm_list_1 (SCM_CDR (exception
)), 1);
1422 return ret
? SCM_BOOL_T
: SCM_BOOL_F
;
1426 /*** Fat condition variables */
1429 scm_i_pthread_mutex_t lock
;
1430 SCM waiting
; /* the threads waiting for this condition. */
1433 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1434 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1437 fat_mutex_unlock (SCM mutex
, SCM cond
,
1438 const scm_t_timespec
*waittime
, int relock
)
1440 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1442 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1443 int err
= 0, ret
= 0;
1445 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1447 SCM owner
= m
->owner
;
1449 if (!scm_is_eq (owner
, scm_current_thread ()))
1453 if (!m
->unchecked_unlock
)
1455 scm_i_pthread_mutex_unlock (&m
->lock
);
1456 scm_misc_error (NULL
, "mutex not locked", SCM_EOL
);
1458 owner
= scm_current_thread ();
1460 else if (!m
->allow_external_unlock
)
1462 scm_i_pthread_mutex_unlock (&m
->lock
);
1463 scm_misc_error (NULL
, "mutex not locked by current thread", SCM_EOL
);
1467 if (! (SCM_UNBNDP (cond
)))
1469 c
= SCM_CONDVAR_DATA (cond
);
1477 m
->owner
= unblock_from_queue (m
->waiting
);
1481 err
= block_self (c
->waiting
, cond
, &m
->lock
, waittime
);
1482 scm_i_pthread_mutex_unlock (&m
->lock
);
1489 else if (err
== ETIMEDOUT
)
1494 else if (err
!= EINTR
)
1497 scm_syserror (NULL
);
1503 scm_lock_mutex_timed (mutex
, SCM_UNDEFINED
, owner
);
1511 scm_remember_upto_here_2 (cond
, mutex
);
1513 scm_i_scm_pthread_mutex_lock (&m
->lock
);
1521 m
->owner
= unblock_from_queue (m
->waiting
);
1523 scm_i_pthread_mutex_unlock (&m
->lock
);
1530 SCM
scm_unlock_mutex (SCM mx
)
1532 return scm_unlock_mutex_timed (mx
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1535 SCM_DEFINE (scm_unlock_mutex_timed
, "unlock-mutex", 1, 2, 0,
1536 (SCM mx
, SCM cond
, SCM timeout
),
1537 "Unlocks @var{mutex} if the calling thread owns the lock on "
1538 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
1539 "thread results in undefined behaviour. Once a mutex has been unlocked, "
1540 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
1541 "lock. Every call to @code{lock-mutex} by this thread must be matched "
1542 "with a call to @code{unlock-mutex}. Only the last call to "
1543 "@code{unlock-mutex} will actually unlock the mutex. ")
1544 #define FUNC_NAME s_scm_unlock_mutex_timed
1546 scm_t_timespec cwaittime
, *waittime
= NULL
;
1548 SCM_VALIDATE_MUTEX (1, mx
);
1549 if (! (SCM_UNBNDP (cond
)))
1551 SCM_VALIDATE_CONDVAR (2, cond
);
1553 if (! (SCM_UNBNDP (timeout
)))
1555 to_timespec (timeout
, &cwaittime
);
1556 waittime
= &cwaittime
;
1560 return fat_mutex_unlock (mx
, cond
, waittime
, 0) ? SCM_BOOL_T
: SCM_BOOL_F
;
1564 SCM_DEFINE (scm_mutex_p
, "mutex?", 1, 0, 0,
1566 "Return @code{#t} if @var{obj} is a mutex.")
1567 #define FUNC_NAME s_scm_mutex_p
1569 return SCM_MUTEXP (obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1573 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
1575 "Return the thread owning @var{mx}, or @code{#f}.")
1576 #define FUNC_NAME s_scm_mutex_owner
1579 fat_mutex
*m
= NULL
;
1581 SCM_VALIDATE_MUTEX (1, mx
);
1582 m
= SCM_MUTEX_DATA (mx
);
1583 scm_i_pthread_mutex_lock (&m
->lock
);
1585 scm_i_pthread_mutex_unlock (&m
->lock
);
1591 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1593 "Return the lock level of mutex @var{mx}.")
1594 #define FUNC_NAME s_scm_mutex_level
1596 SCM_VALIDATE_MUTEX (1, mx
);
1597 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1601 SCM_DEFINE (scm_mutex_locked_p
, "mutex-locked?", 1, 0, 0,
1603 "Returns @code{#t} if the mutex @var{mx} is locked.")
1604 #define FUNC_NAME s_scm_mutex_locked_p
1606 SCM_VALIDATE_MUTEX (1, mx
);
1607 return SCM_MUTEX_DATA (mx
)->level
> 0 ? SCM_BOOL_T
: SCM_BOOL_F
;
1612 fat_cond_mark (SCM cv
)
1614 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1619 fat_cond_free (SCM mx
)
1621 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1622 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1627 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1629 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1630 scm_puts ("#<condition-variable ", port
);
1631 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1632 scm_puts (">", port
);
1636 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1638 "Make a new condition variable.")
1639 #define FUNC_NAME s_scm_make_condition_variable
1644 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1645 c
->waiting
= SCM_EOL
;
1646 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1647 c
->waiting
= make_queue ();
1652 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1653 (SCM cv
, SCM mx
, SCM t
),
1654 "Wait until @var{cond-var} has been signalled. While waiting, "
1655 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1656 "is locked again when this function returns. When @var{time} is given, "
1657 "it specifies a point in time where the waiting should be aborted. It "
1658 "can be either a integer as returned by @code{current-time} or a pair "
1659 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1660 "mutex is locked and @code{#f} is returned. When the condition "
1661 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1663 #define FUNC_NAME s_scm_timed_wait_condition_variable
1665 scm_t_timespec waittime
, *waitptr
= NULL
;
1667 SCM_VALIDATE_CONDVAR (1, cv
);
1668 SCM_VALIDATE_MUTEX (2, mx
);
1670 if (!SCM_UNBNDP (t
))
1672 to_timespec (t
, &waittime
);
1673 waitptr
= &waittime
;
1676 return fat_mutex_unlock (mx
, cv
, waitptr
, 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
1681 fat_cond_signal (fat_cond
*c
)
1683 unblock_from_queue (c
->waiting
);
1686 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1688 "Wake up one thread that is waiting for @var{cv}")
1689 #define FUNC_NAME s_scm_signal_condition_variable
1691 SCM_VALIDATE_CONDVAR (1, cv
);
1692 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1698 fat_cond_broadcast (fat_cond
*c
)
1700 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1704 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1706 "Wake up all threads that are waiting for @var{cv}. ")
1707 #define FUNC_NAME s_scm_broadcast_condition_variable
1709 SCM_VALIDATE_CONDVAR (1, cv
);
1710 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1715 SCM_DEFINE (scm_condition_variable_p
, "condition-variable?", 1, 0, 0,
1717 "Return @code{#t} if @var{obj} is a condition variable.")
1718 #define FUNC_NAME s_scm_condition_variable_p
1720 return SCM_CONDVARP(obj
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1724 /*** Marking stacks */
1726 /* XXX - what to do with this? Do we need to handle this for blocked
1730 # define SCM_MARK_BACKING_STORE() do { \
1732 SCM_STACKITEM * top, * bot; \
1733 getcontext (&ctx); \
1734 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1735 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1736 / sizeof (SCM_STACKITEM))); \
1737 bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
1738 top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
1739 scm_mark_locations (bot, top - bot); } while (0)
1741 # define SCM_MARK_BACKING_STORE()
1745 scm_threads_mark_stacks (void)
1748 for (t
= all_threads
; t
; t
= t
->next_thread
)
1750 /* Check that thread has indeed been suspended.
1754 scm_gc_mark (t
->handle
);
1756 #if SCM_STACK_GROWS_UP
1757 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1759 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1761 scm_mark_locations ((void *) &t
->regs
,
1762 ((size_t) sizeof(t
->regs
)
1763 / sizeof (SCM_STACKITEM
)));
1766 SCM_MARK_BACKING_STORE ();
1772 scm_std_select (int nfds
,
1773 SELECT_TYPE
*readfds
,
1774 SELECT_TYPE
*writefds
,
1775 SELECT_TYPE
*exceptfds
,
1776 struct timeval
*timeout
)
1779 int res
, eno
, wakeup_fd
;
1780 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1781 scm_t_guile_ticket ticket
;
1783 if (readfds
== NULL
)
1785 FD_ZERO (&my_readfds
);
1786 readfds
= &my_readfds
;
1789 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1792 wakeup_fd
= t
->sleep_pipe
[0];
1793 ticket
= scm_leave_guile ();
1794 FD_SET (wakeup_fd
, readfds
);
1795 if (wakeup_fd
>= nfds
)
1797 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1800 scm_enter_guile (ticket
);
1802 scm_i_reset_sleep (t
);
1804 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1807 full_read (wakeup_fd
, &dummy
, 1);
1809 FD_CLR (wakeup_fd
, readfds
);
1821 /* Convenience API for blocking while in guile mode. */
1823 #if SCM_USE_PTHREAD_THREADS
1826 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1828 scm_t_guile_ticket t
= scm_leave_guile ();
1829 int res
= scm_i_pthread_mutex_lock (mutex
);
1830 scm_enter_guile (t
);
1835 do_unlock (void *data
)
1837 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1841 scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1843 scm_i_scm_pthread_mutex_lock (mutex
);
1844 scm_dynwind_unwind_handler (do_unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1848 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1850 scm_t_guile_ticket t
= scm_leave_guile ();
1851 ((scm_i_thread
*)t
)->held_mutex
= mutex
;
1852 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1853 ((scm_i_thread
*)t
)->held_mutex
= NULL
;
1854 scm_enter_guile (t
);
1859 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1860 scm_i_pthread_mutex_t
*mutex
,
1861 const scm_t_timespec
*wt
)
1863 scm_t_guile_ticket t
= scm_leave_guile ();
1864 ((scm_i_thread
*)t
)->held_mutex
= mutex
;
1865 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1866 ((scm_i_thread
*)t
)->held_mutex
= NULL
;
1867 scm_enter_guile (t
);
1874 scm_std_usleep (unsigned long usecs
)
1877 tv
.tv_usec
= usecs
% 1000000;
1878 tv
.tv_sec
= usecs
/ 1000000;
1879 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1880 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1884 scm_std_sleep (unsigned int secs
)
1889 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1895 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1897 "Return the thread that called this function.")
1898 #define FUNC_NAME s_scm_current_thread
1900 return SCM_I_CURRENT_THREAD
->handle
;
1905 scm_c_make_list (size_t n
, SCM fill
)
1909 res
= scm_cons (fill
, res
);
1913 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1915 "Return a list of all threads.")
1916 #define FUNC_NAME s_scm_all_threads
1918 /* We can not allocate while holding the thread_admin_mutex because
1919 of the way GC is done.
1921 int n
= thread_count
;
1923 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1925 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1927 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1929 if (t
!= scm_i_signal_delivery_thread
)
1931 SCM_SETCAR (*l
, t
->handle
);
1932 l
= SCM_CDRLOC (*l
);
1937 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1942 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1944 "Return @code{#t} iff @var{thread} has exited.\n")
1945 #define FUNC_NAME s_scm_thread_exited_p
1947 return scm_from_bool (scm_c_thread_exited_p (thread
));
1952 scm_c_thread_exited_p (SCM thread
)
1953 #define FUNC_NAME s_scm_thread_exited_p
1956 SCM_VALIDATE_THREAD (1, thread
);
1957 t
= SCM_I_THREAD_DATA (thread
);
1962 static scm_i_pthread_cond_t wake_up_cond
;
1963 int scm_i_thread_go_to_sleep
;
1964 static int threads_initialized_p
= 0;
1967 scm_i_thread_put_to_sleep ()
1969 if (threads_initialized_p
)
1974 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1976 /* Signal all threads to go to sleep
1978 scm_i_thread_go_to_sleep
= 1;
1979 for (t
= all_threads
; t
; t
= t
->next_thread
)
1980 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1981 scm_i_thread_go_to_sleep
= 0;
1986 scm_i_thread_invalidate_freelists ()
1988 /* thread_admin_mutex is already locked. */
1991 for (t
= all_threads
; t
; t
= t
->next_thread
)
1992 if (t
!= SCM_I_CURRENT_THREAD
)
1993 t
->clear_freelists_p
= 1;
1997 scm_i_thread_wake_up ()
1999 if (threads_initialized_p
)
2003 scm_i_pthread_cond_broadcast (&wake_up_cond
);
2004 for (t
= all_threads
; t
; t
= t
->next_thread
)
2005 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
2006 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
2007 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
2012 scm_i_thread_sleep_for_gc ()
2014 scm_i_thread
*t
= suspend ();
2016 /* Don't put t->heap_mutex in t->held_mutex here, because if the
2017 thread is cancelled during the cond wait, the thread's cleanup
2018 function (scm_leave_guile_cleanup) will handle unlocking the
2019 heap_mutex, so we don't need to do that again in on_thread_exit.
2021 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
2026 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
2028 scm_i_pthread_mutex_t scm_i_critical_section_mutex
;
2029 int scm_i_critical_section_level
= 0;
2031 static SCM dynwind_critical_section_mutex
;
2034 scm_dynwind_critical_section (SCM mutex
)
2036 if (scm_is_false (mutex
))
2037 mutex
= dynwind_critical_section_mutex
;
2038 scm_dynwind_lock_mutex (mutex
);
2039 scm_dynwind_block_asyncs ();
2042 /*** Initialization */
2044 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
2045 scm_i_pthread_mutex_t scm_i_misc_mutex
;
2047 #if SCM_USE_PTHREAD_THREADS
2048 pthread_mutexattr_t scm_i_pthread_mutexattr_recursive
[1];
2052 scm_threads_prehistory (SCM_STACKITEM
*base
)
2054 #if SCM_USE_PTHREAD_THREADS
2055 pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive
);
2056 pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive
,
2057 PTHREAD_MUTEX_RECURSIVE
);
2060 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
,
2061 scm_i_pthread_mutexattr_recursive
);
2062 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
2063 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
2064 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
2065 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
2067 guilify_self_1 (base
);
2070 scm_t_bits scm_tc16_thread
;
2071 scm_t_bits scm_tc16_mutex
;
2072 scm_t_bits scm_tc16_condvar
;
2077 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
2078 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
2079 scm_set_smob_print (scm_tc16_thread
, thread_print
);
2080 scm_set_smob_free (scm_tc16_thread
, thread_free
);
2082 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
2083 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
2084 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
2085 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
2087 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
2089 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
2090 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
2091 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
2093 scm_i_default_dynamic_state
= SCM_BOOL_F
;
2094 guilify_self_2 (SCM_BOOL_F
);
2095 threads_initialized_p
= 1;
2097 dynwind_critical_section_mutex
=
2098 scm_permanent_object (scm_make_recursive_mutex ());
2102 scm_init_threads_default_dynamic_state ()
2104 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
2105 scm_i_default_dynamic_state
= scm_permanent_object (state
);
2109 scm_init_thread_procs ()
2111 #include "libguile/threads.x"