1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 #include "libguile/_scm.h"
34 #include "libguile/validate.h"
35 #include "libguile/root.h"
36 #include "libguile/eval.h"
37 #include "libguile/async.h"
38 #include "libguile/ports.h"
39 #include "libguile/threads.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/iselect.h"
42 #include "libguile/fluids.h"
43 #include "libguile/continuations.h"
44 #include "libguile/init.h"
48 /* Make an empty queue data structure.
53 return scm_cons (SCM_EOL
, SCM_EOL
);
56 /* Put T at the back of Q and return a handle that can be used with
57 remqueue to remove T from Q again.
60 enqueue (SCM q
, SCM t
)
62 SCM c
= scm_cons (t
, SCM_EOL
);
63 if (scm_is_null (SCM_CDR (q
)))
66 SCM_SETCDR (SCM_CAR (q
), c
);
71 /* Remove the element that the handle C refers to from the queue Q. C
72 must have been returned from a call to enqueue. The return value
73 is zero when the element referred to by C has already been removed.
74 Otherwise, 1 is returned.
77 remqueue (SCM q
, SCM c
)
80 for (p
= SCM_CDR (q
); !scm_is_null (p
); p
= SCM_CDR (p
))
84 if (scm_is_eq (c
, SCM_CAR (q
)))
85 SCM_SETCAR (q
, SCM_CDR (c
));
86 SCM_SETCDR (prev
, SCM_CDR (c
));
94 /* Remove the front-most element from the queue Q and return it.
95 Return SCM_BOOL_F when Q is empty.
105 SCM_SETCDR (q
, SCM_CDR (c
));
106 if (scm_is_null (SCM_CDR (q
)))
107 SCM_SETCAR (q
, SCM_EOL
);
112 /*** Thread smob routines */
115 thread_mark (SCM obj
)
117 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
118 scm_gc_mark (t
->result
);
119 scm_gc_mark (t
->join_queue
);
120 scm_gc_mark (t
->dynwinds
);
121 scm_gc_mark (t
->active_asyncs
);
122 scm_gc_mark (t
->continuation_root
);
123 return t
->dynamic_state
;
127 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
129 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
130 scm_puts ("#<thread ", port
);
131 scm_uintprint ((size_t)t
->pthread
, 10, port
);
132 scm_puts (" (", port
);
133 scm_uintprint ((scm_t_bits
)t
, 16, port
);
134 scm_puts (")>", port
);
139 thread_free (SCM obj
)
141 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
143 scm_gc_free (t
, sizeof (*t
), "thread");
147 /*** Blocking on queues. */
149 /* See also scm_i_queue_async_cell for how such a block is
153 /* Put the current thread on QUEUE and go to sleep, waiting for it to
154 be woken up by a call to 'unblock_from_queue', or to be
155 interrupted. Upon return of this function, the current thread is
156 no longer on QUEUE, even when the sleep has been interrupted.
158 The QUEUE data structure is assumed to be protected by MUTEX and
159 the caller of block_self must hold MUTEX. It will be atomically
160 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
162 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
165 When WAITTIME is not NULL, the sleep will be aborted at that time.
167 The return value of block_self is an errno value. It will be zero
168 when the sleep has been successfully completed by a call to
169 unblock_from_queue, EINTR when it has been interrupted by the
170 delivery of a system async, and ETIMEDOUT when the timeout has
173 The system asyncs themselves are not executed by block_self.
176 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
177 const scm_t_timespec
*waittime
)
179 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
183 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
188 q_handle
= enqueue (queue
, t
->handle
);
189 if (waittime
== NULL
)
190 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
192 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
194 /* When we are still on QUEUE, we have been interrupted. We
195 report this only when no other error (such as a timeout) has
198 if (remqueue (queue
, q_handle
) && err
== 0)
201 scm_i_reset_sleep (t
);
207 /* Wake up the first thread on QUEUE, if any. The caller must hold
208 the mutex that protects QUEUE. The awoken thread is returned, or
209 #f when the queue was empty.
212 unblock_from_queue (SCM queue
)
214 SCM thread
= dequeue (queue
);
215 if (scm_is_true (thread
))
216 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
220 /* Getting into and out of guile mode.
223 scm_i_pthread_key_t scm_i_thread_key
;
226 resume (scm_i_thread
*t
)
229 if (t
->clear_freelists_p
)
231 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
232 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
233 t
->clear_freelists_p
= 0;
238 scm_enter_guile (scm_t_guile_ticket ticket
)
240 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
243 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
248 static scm_i_thread
*
251 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
253 /* record top of stack for the GC */
254 t
->top
= SCM_STACK_PTR (&t
);
255 /* save registers. */
256 SCM_FLUSH_REGISTER_WINDOWS
;
264 scm_i_thread
*t
= suspend ();
265 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
266 return (scm_t_guile_ticket
) t
;
269 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
270 static scm_i_thread
*all_threads
= NULL
;
271 static int thread_count
;
273 static SCM scm_i_default_dynamic_state
;
275 /* Perform first stage of thread initialisation, in non-guile mode.
278 guilify_self_1 (SCM_STACKITEM
*base
)
280 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
282 t
->pthread
= scm_i_pthread_self ();
283 t
->handle
= SCM_BOOL_F
;
284 t
->result
= SCM_BOOL_F
;
285 t
->join_queue
= SCM_EOL
;
286 t
->dynamic_state
= SCM_BOOL_F
;
287 t
->dynwinds
= SCM_EOL
;
288 t
->active_asyncs
= SCM_EOL
;
290 t
->pending_asyncs
= 1;
291 t
->last_debug_frame
= NULL
;
293 t
->continuation_root
= SCM_EOL
;
294 t
->continuation_base
= base
;
295 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
296 t
->sleep_mutex
= NULL
;
297 t
->sleep_object
= SCM_BOOL_F
;
299 /* XXX - check for errors. */
300 pipe (t
->sleep_pipe
);
301 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
302 t
->clear_freelists_p
= 0;
306 t
->freelist
= SCM_EOL
;
307 t
->freelist2
= SCM_EOL
;
308 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
309 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
311 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
313 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
315 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
316 t
->next_thread
= all_threads
;
319 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
322 /* Perform second stage of thread initialisation, in guile mode.
325 guilify_self_2 (SCM parent
)
327 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
329 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
330 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
331 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
332 t
->continuation_base
= t
->base
;
334 if (scm_is_true (parent
))
335 t
->dynamic_state
= scm_make_dynamic_state (parent
);
337 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
339 t
->join_queue
= make_queue ();
343 /* Perform thread tear-down, in guile mode.
346 do_thread_exit (void *v
)
348 scm_i_thread
*t
= (scm_i_thread
*)v
;
350 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
353 close (t
->sleep_pipe
[0]);
354 close (t
->sleep_pipe
[1]);
355 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
358 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
363 on_thread_exit (void *v
)
365 scm_i_thread
*t
= (scm_i_thread
*)v
, **tp
;
367 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
369 /* Unblocking the joining threads needs to happen in guile mode
370 since the queue is a SCM data structure.
372 scm_with_guile (do_thread_exit
, v
);
374 /* Removing ourself from the list of all threads needs to happen in
375 non-guile mode since all SCM values on our stack become
376 unprotected once we are no longer in the list.
379 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
380 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
383 *tp
= t
->next_thread
;
387 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
389 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
392 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
395 init_thread_key (void)
397 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
400 /* Perform any initializations necessary to bring the current thread
401 into guile mode, initializing Guile itself, if necessary.
403 BASE is the stack base to use with GC.
405 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
406 which case the default dynamic state is used.
408 Return zero when the thread was in guile mode already; otherwise
413 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
417 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
419 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
421 /* This thread has not been guilified yet.
424 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
425 if (scm_initialized_p
== 0)
427 /* First thread ever to enter Guile. Run the full
430 scm_i_init_guile (base
);
431 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
435 /* Guile is already initialized, but this thread enters it for
436 the first time. Only initialize this thread.
438 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
439 guilify_self_1 (base
);
440 guilify_self_2 (parent
);
446 /* This thread is already guilified but not in guile mode, just
449 XXX - base might be lower than when this thread was first
452 scm_enter_guile ((scm_t_guile_ticket
) t
);
457 /* Thread is already in guile mode. Nothing to do.
463 #ifdef HAVE_LIBC_STACK_END
465 extern void *__libc_stack_end
;
467 #if SCM_USE_PTHREAD_THREADS
468 #ifdef HAVE_PTHREAD_ATTR_GETSTACK
470 #define HAVE_GET_THREAD_STACK_BASE
472 static SCM_STACKITEM
*
473 get_thread_stack_base ()
479 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
480 for the main thread, but we can use __libc_stack_end in that
484 pthread_getattr_np (pthread_self (), &attr
);
485 pthread_attr_getstack (&attr
, &start
, &size
);
486 end
= (char *)start
+ size
;
488 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
489 return __libc_stack_end
;
492 #if SCM_STACK_GROWS_UP
500 #endif /* HAVE_PTHREAD_ATTR_GETSTACK */
502 #else /* !SCM_USE_PTHREAD_THREADS */
504 #define HAVE_GET_THREAD_STACK_BASE
506 static SCM_STACKITEM
*
507 get_thread_stack_base ()
509 return __libc_stack_end
;
512 #endif /* !SCM_USE_PTHREAD_THREADS */
513 #endif /* HAVE_LIBC_STACK_END */
515 #ifdef HAVE_GET_THREAD_STACK_BASE
520 scm_i_init_thread_for_guile (get_thread_stack_base (),
521 scm_i_default_dynamic_state
);
527 scm_with_guile (void *(*func
)(void *), void *data
)
529 return scm_i_with_guile_and_parent (func
, data
,
530 scm_i_default_dynamic_state
);
534 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
,
539 SCM_STACKITEM base_item
;
540 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
541 res
= scm_c_with_continuation_barrier (func
, data
);
548 scm_without_guile (void *(*func
)(void *), void *data
)
551 scm_t_guile_ticket t
;
552 t
= scm_leave_guile ();
558 /*** Thread creation */
565 scm_i_pthread_mutex_t mutex
;
566 scm_i_pthread_cond_t cond
;
570 really_launch (void *d
)
572 launch_data
*data
= (launch_data
*)d
;
573 SCM thunk
= data
->thunk
, handler
= data
->handler
;
576 t
= SCM_I_CURRENT_THREAD
;
578 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
579 data
->thread
= scm_current_thread ();
580 scm_i_pthread_cond_signal (&data
->cond
);
581 scm_i_pthread_mutex_unlock (&data
->mutex
);
583 if (SCM_UNBNDP (handler
))
584 t
->result
= scm_call_0 (thunk
);
586 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
592 launch_thread (void *d
)
594 launch_data
*data
= (launch_data
*)d
;
595 scm_i_pthread_detach (scm_i_pthread_self ());
596 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
600 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
601 (SCM thunk
, SCM handler
),
602 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
603 "returning a new thread object representing the thread. The procedure\n"
604 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
606 "When @var{handler} is specified, then @var{thunk} is called from\n"
607 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
608 "handler. This catch is established inside the continuation barrier.\n"
610 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
611 "the @emph{exit value} of the thread and the thread is terminated.")
612 #define FUNC_NAME s_scm_call_with_new_thread
618 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
619 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
620 handler
, SCM_ARG2
, FUNC_NAME
);
622 data
.parent
= scm_current_dynamic_state ();
624 data
.handler
= handler
;
625 data
.thread
= SCM_BOOL_F
;
626 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
627 scm_i_pthread_cond_init (&data
.cond
, NULL
);
629 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
630 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
633 scm_i_pthread_mutex_unlock (&data
.mutex
);
637 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
638 scm_i_pthread_mutex_unlock (&data
.mutex
);
646 scm_t_catch_body body
;
648 scm_t_catch_handler handler
;
651 scm_i_pthread_mutex_t mutex
;
652 scm_i_pthread_cond_t cond
;
656 really_spawn (void *d
)
658 spawn_data
*data
= (spawn_data
*)d
;
659 scm_t_catch_body body
= data
->body
;
660 void *body_data
= data
->body_data
;
661 scm_t_catch_handler handler
= data
->handler
;
662 void *handler_data
= data
->handler_data
;
663 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
665 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
666 data
->thread
= scm_current_thread ();
667 scm_i_pthread_cond_signal (&data
->cond
);
668 scm_i_pthread_mutex_unlock (&data
->mutex
);
671 t
->result
= body (body_data
);
673 t
->result
= scm_internal_catch (SCM_BOOL_T
,
675 handler
, handler_data
);
681 spawn_thread (void *d
)
683 spawn_data
*data
= (spawn_data
*)d
;
684 scm_i_pthread_detach (scm_i_pthread_self ());
685 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
690 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
691 scm_t_catch_handler handler
, void *handler_data
)
697 data
.parent
= scm_current_dynamic_state ();
699 data
.body_data
= body_data
;
700 data
.handler
= handler
;
701 data
.handler_data
= handler_data
;
702 data
.thread
= SCM_BOOL_F
;
703 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
704 scm_i_pthread_cond_init (&data
.cond
, NULL
);
706 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
707 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
710 scm_i_pthread_mutex_unlock (&data
.mutex
);
714 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
715 scm_i_pthread_mutex_unlock (&data
.mutex
);
720 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
722 "Move the calling thread to the end of the scheduling queue.")
723 #define FUNC_NAME s_scm_yield
725 return scm_from_bool (scm_i_sched_yield ());
729 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
731 "Suspend execution of the calling thread until the target @var{thread} "
732 "terminates, unless the target @var{thread} has already terminated. ")
733 #define FUNC_NAME s_scm_join_thread
738 SCM_VALIDATE_THREAD (1, thread
);
739 if (scm_is_eq (scm_current_thread (), thread
))
740 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
742 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
744 t
= SCM_I_THREAD_DATA (thread
);
749 block_self (t
->join_queue
, thread
, &thread_admin_mutex
, NULL
);
752 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
754 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
759 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
766 /* We implement our own mutex type since we want them to be 'fair', we
767 want to do fancy things while waiting for them (like running
768 asyncs) and we might want to add things that are nice for
773 scm_i_pthread_mutex_t lock
;
775 int level
; /* how much the owner owns us.
776 < 0 for non-recursive mutexes */
777 SCM waiting
; /* the threads waiting for this mutex. */
780 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
781 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
784 fat_mutex_mark (SCM mx
)
786 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
787 scm_gc_mark (m
->owner
);
792 fat_mutex_free (SCM mx
)
794 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
795 scm_i_pthread_mutex_destroy (&m
->lock
);
796 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
801 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
803 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
804 scm_puts ("#<mutex ", port
);
805 scm_uintprint ((scm_t_bits
)m
, 16, port
);
806 scm_puts (">", port
);
811 make_fat_mutex (int recursive
)
816 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
817 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
818 m
->owner
= SCM_BOOL_F
;
819 m
->level
= recursive
? 0 : -1;
820 m
->waiting
= SCM_EOL
;
821 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
822 m
->waiting
= make_queue ();
826 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
828 "Create a new mutex. ")
829 #define FUNC_NAME s_scm_make_mutex
831 return make_fat_mutex (0);
835 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
837 "Create a new recursive mutex. ")
838 #define FUNC_NAME s_scm_make_recursive_mutex
840 return make_fat_mutex (1);
845 fat_mutex_lock (SCM mutex
)
847 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
848 SCM thread
= scm_current_thread ();
851 scm_i_scm_pthread_mutex_lock (&m
->lock
);
852 if (scm_is_false (m
->owner
))
854 else if (scm_is_eq (m
->owner
, thread
))
859 msg
= "mutex already locked by current thread";
865 block_self (m
->waiting
, mutex
, &m
->lock
, NULL
);
866 if (scm_is_eq (m
->owner
, thread
))
868 scm_i_pthread_mutex_unlock (&m
->lock
);
870 scm_i_scm_pthread_mutex_lock (&m
->lock
);
873 scm_i_pthread_mutex_unlock (&m
->lock
);
877 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
879 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
880 "blocks until the mutex becomes available. The function returns when "
881 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
882 "a thread already owns will succeed right away and will not block the "
883 "thread. That is, Guile's mutexes are @emph{recursive}. ")
884 #define FUNC_NAME s_scm_lock_mutex
886 SCM_VALIDATE_MUTEX (1, mx
);
889 msg
= fat_mutex_lock (mx
);
891 scm_misc_error (NULL
, msg
, SCM_EOL
);
897 scm_frame_lock_mutex (SCM mutex
)
899 scm_frame_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
900 SCM_F_WIND_EXPLICITLY
);
901 scm_frame_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
902 SCM_F_WIND_EXPLICITLY
);
906 fat_mutex_trylock (fat_mutex
*m
, int *resp
)
909 SCM thread
= scm_current_thread ();
912 scm_i_pthread_mutex_lock (&m
->lock
);
913 if (scm_is_false (m
->owner
))
915 else if (scm_is_eq (m
->owner
, thread
))
920 msg
= "mutex already locked by current thread";
924 scm_i_pthread_mutex_unlock (&m
->lock
);
928 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
930 "Try to lock @var{mutex}. If the mutex is already locked by someone "
931 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
932 #define FUNC_NAME s_scm_try_mutex
937 SCM_VALIDATE_MUTEX (1, mutex
);
939 msg
= fat_mutex_trylock (SCM_MUTEX_DATA (mutex
), &res
);
941 scm_misc_error (NULL
, msg
, SCM_EOL
);
942 return scm_from_bool (res
);
947 fat_mutex_unlock (fat_mutex
*m
)
951 scm_i_scm_pthread_mutex_lock (&m
->lock
);
952 if (!scm_is_eq (m
->owner
, scm_current_thread ()))
954 if (scm_is_false (m
->owner
))
955 msg
= "mutex not locked";
957 msg
= "mutex not locked by current thread";
959 else if (m
->level
> 0)
962 m
->owner
= unblock_from_queue (m
->waiting
);
963 scm_i_pthread_mutex_unlock (&m
->lock
);
968 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
970 "Unlocks @var{mutex} if the calling thread owns the lock on "
971 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
972 "thread results in undefined behaviour. Once a mutex has been unlocked, "
973 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
974 "lock. Every call to @code{lock-mutex} by this thread must be matched "
975 "with a call to @code{unlock-mutex}. Only the last call to "
976 "@code{unlock-mutex} will actually unlock the mutex. ")
977 #define FUNC_NAME s_scm_unlock_mutex
980 SCM_VALIDATE_MUTEX (1, mx
);
982 msg
= fat_mutex_unlock (SCM_MUTEX_DATA (mx
));
984 scm_misc_error (NULL
, msg
, SCM_EOL
);
991 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
993 "Return the thread owning @var{mx}, or @code{#f}.")
994 #define FUNC_NAME s_scm_mutex_owner
996 SCM_VALIDATE_MUTEX (1, mx
);
997 return (SCM_MUTEX_DATA(mx
))->owner
;
1001 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
1003 "Return the lock level of a recursive mutex, or -1\n"
1004 "for a standard mutex.")
1005 #define FUNC_NAME s_scm_mutex_level
1007 SCM_VALIDATE_MUTEX (1, mx
);
1008 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
1014 /*** Fat condition variables */
1017 scm_i_pthread_mutex_t lock
;
1018 SCM waiting
; /* the threads waiting for this condition. */
1021 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1022 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1025 fat_cond_mark (SCM cv
)
1027 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1032 fat_cond_free (SCM mx
)
1034 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1035 scm_i_pthread_mutex_destroy (&c
->lock
);
1036 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1041 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1043 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1044 scm_puts ("#<condition-variable ", port
);
1045 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1046 scm_puts (">", port
);
1050 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1052 "Make a new condition variable.")
1053 #define FUNC_NAME s_scm_make_condition_variable
1058 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1059 scm_i_pthread_mutex_init (&c
->lock
, 0);
1060 c
->waiting
= SCM_EOL
;
1061 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1062 c
->waiting
= make_queue ();
1068 fat_cond_timedwait (SCM cond
, SCM mutex
,
1069 const scm_t_timespec
*waittime
)
1071 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1072 fat_cond
*c
= SCM_CONDVAR_DATA (cond
);
1073 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1079 fprintf (stderr
, "cond wait on %p\n", &c
->lock
);
1081 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1082 msg
= fat_mutex_unlock (m
);
1086 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1087 scm_i_pthread_mutex_unlock (&c
->lock
);
1088 fprintf (stderr
, "locking mutex\n");
1089 fat_mutex_lock (mutex
);
1092 scm_i_pthread_mutex_unlock (&c
->lock
);
1096 fprintf (stderr
, "back: %s, %d\n", msg
, err
);
1099 scm_misc_error (NULL
, msg
, SCM_EOL
);
1101 scm_remember_upto_here_2 (cond
, mutex
);
1105 if (err
== ETIMEDOUT
)
1110 scm_syserror (NULL
);
1115 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1116 (SCM cv
, SCM mx
, SCM t
),
1117 "Wait until @var{cond-var} has been signalled. While waiting, "
1118 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1119 "is locked again when this function returns. When @var{time} is given, "
1120 "it specifies a point in time where the waiting should be aborted. It "
1121 "can be either a integer as returned by @code{current-time} or a pair "
1122 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1123 "mutex is locked and @code{#f} is returned. When the condition "
1124 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1126 #define FUNC_NAME s_scm_timed_wait_condition_variable
1128 scm_t_timespec waittime
, *waitptr
= NULL
;
1130 SCM_VALIDATE_CONDVAR (1, cv
);
1131 SCM_VALIDATE_MUTEX (2, mx
);
1133 if (!SCM_UNBNDP (t
))
1135 if (scm_is_pair (t
))
1137 waittime
.tv_sec
= scm_to_ulong (SCM_CAR (t
));
1138 waittime
.tv_nsec
= scm_to_ulong (SCM_CAR (t
)) * 1000;
1142 waittime
.tv_sec
= scm_to_ulong (t
);
1143 waittime
.tv_nsec
= 0;
1145 waitptr
= &waittime
;
1148 return scm_from_bool (fat_cond_timedwait (cv
, mx
, waitptr
));
1153 fat_cond_signal (fat_cond
*c
)
1155 fprintf (stderr
, "cond signal on %p\n", &c
->lock
);
1157 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1158 unblock_from_queue (c
->waiting
);
1159 scm_i_pthread_mutex_unlock (&c
->lock
);
1162 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1164 "Wake up one thread that is waiting for @var{cv}")
1165 #define FUNC_NAME s_scm_signal_condition_variable
1167 SCM_VALIDATE_CONDVAR (1, cv
);
1168 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1174 fat_cond_broadcast (fat_cond
*c
)
1176 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1177 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1179 scm_i_pthread_mutex_unlock (&c
->lock
);
1182 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1184 "Wake up all threads that are waiting for @var{cv}. ")
1185 #define FUNC_NAME s_scm_broadcast_condition_variable
1187 SCM_VALIDATE_CONDVAR (1, cv
);
1188 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1193 /*** Marking stacks */
1195 /* XXX - what to do with this? Do we need to handle this for blocked
1199 # define SCM_MARK_BACKING_STORE() do { \
1201 SCM_STACKITEM * top, * bot; \
1202 getcontext (&ctx); \
1203 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1204 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1205 / sizeof (SCM_STACKITEM))); \
1206 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1207 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1208 scm_mark_locations (bot, top - bot); } while (0)
1210 # define SCM_MARK_BACKING_STORE()
1214 scm_threads_mark_stacks (void)
1217 for (t
= all_threads
; t
; t
= t
->next_thread
)
1219 /* Check that thread has indeed been suspended.
1223 scm_gc_mark (t
->handle
);
1225 #if SCM_STACK_GROWS_UP
1226 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1228 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1230 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1231 ((size_t) sizeof(t
->regs
)
1232 / sizeof (SCM_STACKITEM
)));
1235 SCM_MARK_BACKING_STORE ();
1241 scm_std_select (int nfds
,
1242 SELECT_TYPE
*readfds
,
1243 SELECT_TYPE
*writefds
,
1244 SELECT_TYPE
*exceptfds
,
1245 struct timeval
*timeout
)
1248 int res
, eno
, wakeup_fd
;
1249 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1250 scm_t_guile_ticket ticket
;
1252 if (readfds
== NULL
)
1254 FD_ZERO (&my_readfds
);
1255 readfds
= &my_readfds
;
1258 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1261 wakeup_fd
= t
->sleep_pipe
[0];
1262 ticket
= scm_leave_guile ();
1263 FD_SET (wakeup_fd
, readfds
);
1264 if (wakeup_fd
>= nfds
)
1266 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1269 scm_enter_guile (ticket
);
1271 scm_i_reset_sleep (t
);
1273 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1276 read (wakeup_fd
, &dummy
, 1);
1277 FD_CLR (wakeup_fd
, readfds
);
1289 /* Convenience API for blocking while in guile mode. */
1291 #if SCM_USE_PTHREAD_THREADS
1294 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1296 scm_t_guile_ticket t
= scm_leave_guile ();
1297 int res
= scm_i_pthread_mutex_lock (mutex
);
1298 scm_enter_guile (t
);
1305 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1309 scm_frame_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1311 scm_i_scm_pthread_mutex_lock (mutex
);
1312 scm_frame_unwind_handler (unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1316 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1318 scm_t_guile_ticket t
= scm_leave_guile ();
1319 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1320 scm_enter_guile (t
);
1325 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1326 scm_i_pthread_mutex_t
*mutex
,
1327 const scm_t_timespec
*wt
)
1329 scm_t_guile_ticket t
= scm_leave_guile ();
1330 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1331 scm_enter_guile (t
);
1338 scm_std_usleep (unsigned long usecs
)
1341 tv
.tv_usec
= usecs
% 1000000;
1342 tv
.tv_sec
= usecs
/ 1000000;
1343 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1344 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1348 scm_std_sleep (unsigned int secs
)
1353 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1359 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1361 "Return the thread that called this function.")
1362 #define FUNC_NAME s_scm_current_thread
1364 return SCM_I_CURRENT_THREAD
->handle
;
1369 scm_c_make_list (size_t n
, SCM fill
)
1373 res
= scm_cons (fill
, res
);
1377 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1379 "Return a list of all threads.")
1380 #define FUNC_NAME s_scm_all_threads
1382 /* We can not allocate while holding the thread_admin_mutex because
1383 of the way GC is done.
1385 int n
= thread_count
;
1387 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1389 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1391 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1393 SCM_SETCAR (*l
, t
->handle
);
1394 l
= SCM_CDRLOC (*l
);
1398 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1403 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1405 "Return @code{#t} iff @var{thread} has exited.\n")
1406 #define FUNC_NAME s_scm_thread_exited_p
1408 return scm_from_bool (scm_c_thread_exited_p (thread
));
1413 scm_c_thread_exited_p (SCM thread
)
1414 #define FUNC_NAME s_scm_thread_exited_p
1417 SCM_VALIDATE_THREAD (1, thread
);
1418 t
= SCM_I_THREAD_DATA (thread
);
1423 static scm_i_pthread_cond_t wake_up_cond
;
1424 int scm_i_thread_go_to_sleep
;
1425 static int threads_initialized_p
= 0;
1428 scm_i_thread_put_to_sleep ()
1430 if (threads_initialized_p
)
1435 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1437 /* Signal all threads to go to sleep
1439 scm_i_thread_go_to_sleep
= 1;
1440 for (t
= all_threads
; t
; t
= t
->next_thread
)
1441 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1442 scm_i_thread_go_to_sleep
= 0;
1447 scm_i_thread_invalidate_freelists ()
1449 /* thread_admin_mutex is already locked. */
1452 for (t
= all_threads
; t
; t
= t
->next_thread
)
1453 if (t
!= SCM_I_CURRENT_THREAD
)
1454 t
->clear_freelists_p
= 1;
1458 scm_i_thread_wake_up ()
1460 if (threads_initialized_p
)
1464 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1465 for (t
= all_threads
; t
; t
= t
->next_thread
)
1466 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1467 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1468 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1473 scm_i_thread_sleep_for_gc ()
1475 scm_i_thread
*t
= suspend ();
1476 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1480 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1482 scm_i_pthread_mutex_t scm_i_critical_section_mutex
=
1483 SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER
;
1484 int scm_i_critical_section_level
= 0;
1486 static SCM framed_critical_section_mutex
;
1489 scm_frame_critical_section (SCM mutex
)
1491 if (scm_is_false (mutex
))
1492 mutex
= framed_critical_section_mutex
;
1493 scm_frame_lock_mutex (mutex
);
1494 scm_frame_block_asyncs ();
1497 /*** Initialization */
1499 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1500 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1503 scm_threads_prehistory (SCM_STACKITEM
*base
)
1505 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1506 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1507 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1508 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1510 guilify_self_1 (base
);
1513 scm_t_bits scm_tc16_thread
;
1514 scm_t_bits scm_tc16_mutex
;
1515 scm_t_bits scm_tc16_condvar
;
1520 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1521 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1522 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1523 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1525 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1526 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
1527 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1528 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1530 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1532 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
1533 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1534 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1536 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1537 guilify_self_2 (SCM_BOOL_F
);
1538 threads_initialized_p
= 1;
1540 framed_critical_section_mutex
=
1541 scm_permanent_object (scm_make_recursive_mutex ());
1545 scm_init_threads_default_dynamic_state ()
1547 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
1548 scm_i_default_dynamic_state
= scm_permanent_object (state
);
1552 scm_init_thread_procs ()
1554 #include "libguile/threads.x"