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
->signal_asyncs
);
123 scm_gc_mark (t
->continuation_root
);
124 return t
->dynamic_state
;
128 thread_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
130 scm_i_thread
*t
= SCM_I_THREAD_DATA (exp
);
131 scm_puts ("#<thread ", port
);
132 scm_uintprint ((size_t)t
->pthread
, 10, port
);
133 scm_puts (" (", port
);
134 scm_uintprint ((scm_t_bits
)t
, 16, port
);
135 scm_puts (")>", port
);
140 thread_free (SCM obj
)
142 scm_i_thread
*t
= SCM_I_THREAD_DATA (obj
);
144 scm_gc_free (t
, sizeof (*t
), "thread");
148 /*** Blocking on queues. */
150 /* See also scm_i_queue_async_cell for how such a block is
154 /* Put the current thread on QUEUE and go to sleep, waiting for it to
155 be woken up by a call to 'unblock_from_queue', or to be
156 interrupted. Upon return of this function, the current thread is
157 no longer on QUEUE, even when the sleep has been interrupted.
159 The QUEUE data structure is assumed to be protected by MUTEX and
160 the caller of block_self must hold MUTEX. It will be atomically
161 unlocked while sleeping, just as with scm_i_pthread_cond_wait.
163 SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
166 When WAITTIME is not NULL, the sleep will be aborted at that time.
168 The return value of block_self is an errno value. It will be zero
169 when the sleep has been successfully completed by a call to
170 unblock_from_queue, EINTR when it has been interrupted by the
171 delivery of a system async, and ETIMEDOUT when the timeout has
174 The system asyncs themselves are not executed by block_self.
177 block_self (SCM queue
, SCM sleep_object
, scm_i_pthread_mutex_t
*mutex
,
178 const scm_t_timespec
*waittime
)
180 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
184 if (scm_i_setup_sleep (t
, sleep_object
, mutex
, -1))
189 q_handle
= enqueue (queue
, t
->handle
);
190 if (waittime
== NULL
)
191 err
= scm_i_scm_pthread_cond_wait (&t
->sleep_cond
, mutex
);
193 err
= scm_i_scm_pthread_cond_timedwait (&t
->sleep_cond
, mutex
, waittime
);
195 /* When we are still on QUEUE, we have been interrupted. We
196 report this only when no other error (such as a timeout) has
199 if (remqueue (queue
, q_handle
) && err
== 0)
202 scm_i_reset_sleep (t
);
208 /* Wake up the first thread on QUEUE, if any. The caller must hold
209 the mutex that protects QUEUE. The awoken thread is returned, or
210 #f when the queue was empty.
213 unblock_from_queue (SCM queue
)
215 SCM thread
= dequeue (queue
);
216 if (scm_is_true (thread
))
217 scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread
)->sleep_cond
);
221 /* Getting into and out of guile mode.
224 scm_i_pthread_key_t scm_i_thread_key
;
227 resume (scm_i_thread
*t
)
230 if (t
->clear_freelists_p
)
232 *SCM_FREELIST_LOC (scm_i_freelist
) = SCM_EOL
;
233 *SCM_FREELIST_LOC (scm_i_freelist2
) = SCM_EOL
;
234 t
->clear_freelists_p
= 0;
239 scm_enter_guile (scm_t_guile_ticket ticket
)
241 scm_i_thread
*t
= (scm_i_thread
*)ticket
;
244 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
249 static scm_i_thread
*
252 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
254 /* record top of stack for the GC */
255 t
->top
= SCM_STACK_PTR (&t
);
256 /* save registers. */
257 SCM_FLUSH_REGISTER_WINDOWS
;
265 scm_i_thread
*t
= suspend ();
266 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
267 return (scm_t_guile_ticket
) t
;
270 static scm_i_pthread_mutex_t thread_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
271 static scm_i_thread
*all_threads
= NULL
;
272 static int thread_count
;
274 static SCM scm_i_default_dynamic_state
;
276 /* Perform first stage of thread initialisation, in non-guile mode.
279 guilify_self_1 (SCM_STACKITEM
*base
)
281 scm_i_thread
*t
= malloc (sizeof (scm_i_thread
));
283 t
->pthread
= scm_i_pthread_self ();
284 t
->handle
= SCM_BOOL_F
;
285 t
->result
= SCM_BOOL_F
;
286 t
->join_queue
= SCM_EOL
;
287 t
->dynamic_state
= SCM_BOOL_F
;
288 t
->dynwinds
= SCM_EOL
;
289 t
->active_asyncs
= SCM_EOL
;
290 t
->signal_asyncs
= SCM_EOL
;
292 t
->pending_asyncs
= 1;
293 t
->last_debug_frame
= NULL
;
295 t
->continuation_base
= base
;
296 scm_i_pthread_cond_init (&t
->sleep_cond
, NULL
);
297 t
->sleep_mutex
= NULL
;
298 t
->sleep_object
= SCM_BOOL_F
;
300 pipe (t
->sleep_pipe
);
301 scm_i_pthread_mutex_init (&t
->heap_mutex
, NULL
);
302 t
->clear_freelists_p
= 0;
305 t
->freelist
= SCM_EOL
;
306 t
->freelist2
= SCM_EOL
;
307 SCM_SET_FREELIST_LOC (scm_i_freelist
, &t
->freelist
);
308 SCM_SET_FREELIST_LOC (scm_i_freelist2
, &t
->freelist2
);
310 scm_i_pthread_setspecific (scm_i_thread_key
, t
);
312 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
314 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
315 t
->next_thread
= all_threads
;
318 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
321 /* Perform second stage of thread initialisation, in guile mode.
324 guilify_self_2 (SCM parent
)
326 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
328 SCM_NEWSMOB (t
->handle
, scm_tc16_thread
, t
);
329 scm_gc_register_collectable_memory (t
, sizeof (scm_i_thread
), "thread");
330 t
->continuation_root
= scm_cons (t
->handle
, SCM_EOL
);
331 t
->continuation_base
= t
->base
;
333 if (scm_is_true (parent
))
334 t
->dynamic_state
= scm_make_dynamic_state (parent
);
336 t
->dynamic_state
= scm_i_make_initial_dynamic_state ();
338 t
->join_queue
= make_queue ();
342 /* Perform thread tear-down, in guile mode.
345 do_thread_exit (void *v
)
347 scm_i_thread
*t
= (scm_i_thread
*)v
, **tp
;
349 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
352 while (scm_is_true (unblock_from_queue (t
->join_queue
)))
355 for (tp
= &all_threads
; *tp
; tp
= &(*tp
)->next_thread
)
358 *tp
= t
->next_thread
;
363 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
368 on_thread_exit (void *v
)
370 scm_i_pthread_setspecific (scm_i_thread_key
, v
);
371 scm_with_guile (do_thread_exit
, v
);
372 scm_i_pthread_setspecific (scm_i_thread_key
, NULL
);
375 static scm_i_pthread_once_t init_thread_key_once
= SCM_I_PTHREAD_ONCE_INIT
;
378 init_thread_key (void)
380 scm_i_pthread_key_create (&scm_i_thread_key
, on_thread_exit
);
383 /* Perform any initializations necessary to bring the current thread
384 into guile mode, initializing Guile itself, if necessary.
386 BASE is the stack base to use with GC.
388 PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
389 which case the default dynamic state is used.
391 Return zero when the thread was in guile mode already; otherwise
396 scm_i_init_thread_for_guile (SCM_STACKITEM
*base
, SCM parent
)
400 scm_i_pthread_once (&init_thread_key_once
, init_thread_key
);
402 if ((t
= SCM_I_CURRENT_THREAD
) == NULL
)
404 /* This thread has not been guilified yet.
407 scm_i_pthread_mutex_lock (&scm_i_init_mutex
);
408 if (scm_initialized_p
== 0)
410 /* First thread ever to enter Guile. Run the full
413 scm_i_init_guile (base
);
414 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
418 /* Guile is already initialized, but this thread enters it for
419 the first time. Only initialize this thread.
421 scm_i_pthread_mutex_unlock (&scm_i_init_mutex
);
422 guilify_self_1 (base
);
423 guilify_self_2 (parent
);
429 /* This thread is already guilified but not in guile mode, just
432 XXX - base might be lower than when this thread was first
435 scm_enter_guile ((scm_t_guile_ticket
) t
);
440 /* Thread is already in guile mode. Nothing to do.
446 #ifdef HAVE_LIBC_STACK_END
448 extern void *__libc_stack_end
;
450 #if SCM_USE_PTHREAD_THREADS
451 #ifdef HAVE_PTHREAD_ATTR_GETSTACK
453 #define HAVE_GET_THREAD_STACK_BASE
455 static SCM_STACKITEM
*
456 get_thread_stack_base ()
462 /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
463 for the main thread, but we can use __libc_stack_end in that
467 pthread_getattr_np (pthread_self (), &attr
);
468 pthread_attr_getstack (&attr
, &start
, &size
);
469 end
= (char *)start
+ size
;
471 if ((void *)&attr
< start
|| (void *)&attr
>= end
)
472 return __libc_stack_end
;
475 #if SCM_STACK_GROWS_UP
483 #endif /* HAVE_PTHREAD_ATTR_GETSTACK */
485 #else /* !SCM_USE_PTHREAD_THREADS */
487 #define HAVE_GET_THREAD_STACK_BASE
489 static SCM_STACKITEM
*
490 get_thread_stack_base ()
492 return __libc_stack_end
;
495 #endif /* !SCM_USE_PTHREAD_THREADS */
496 #endif /* HAVE_LIBC_STACK_END */
498 #ifdef HAVE_GET_THREAD_STACK_BASE
503 scm_i_init_thread_for_guile (get_thread_stack_base (),
504 scm_i_default_dynamic_state
);
510 scm_with_guile (void *(*func
)(void *), void *data
)
512 return scm_i_with_guile_and_parent (func
, data
,
513 scm_i_default_dynamic_state
);
517 scm_i_with_guile_and_parent (void *(*func
)(void *), void *data
,
522 SCM_STACKITEM base_item
;
523 really_entered
= scm_i_init_thread_for_guile (&base_item
, parent
);
524 res
= scm_c_with_continuation_barrier (func
, data
);
531 scm_without_guile (void *(*func
)(void *), void *data
)
534 scm_t_guile_ticket t
;
535 t
= scm_leave_guile ();
541 /*** Thread creation */
548 scm_i_pthread_mutex_t mutex
;
549 scm_i_pthread_cond_t cond
;
553 really_launch (void *d
)
555 launch_data
*data
= (launch_data
*)d
;
556 SCM thunk
= data
->thunk
, handler
= data
->handler
;
559 t
= SCM_I_CURRENT_THREAD
;
561 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
562 data
->thread
= scm_current_thread ();
563 scm_i_pthread_cond_signal (&data
->cond
);
564 scm_i_pthread_mutex_unlock (&data
->mutex
);
566 if (SCM_UNBNDP (handler
))
567 t
->result
= scm_call_0 (thunk
);
569 t
->result
= scm_catch (SCM_BOOL_T
, thunk
, handler
);
575 launch_thread (void *d
)
577 launch_data
*data
= (launch_data
*)d
;
578 scm_i_pthread_detach (scm_i_pthread_self ());
579 scm_i_with_guile_and_parent (really_launch
, d
, data
->parent
);
583 SCM_DEFINE (scm_call_with_new_thread
, "call-with-new-thread", 1, 1, 0,
584 (SCM thunk
, SCM handler
),
585 "Call @code{thunk} in a new thread and with a new dynamic state,\n"
586 "returning a new thread object representing the thread. The procedure\n"
587 "@var{thunk} is called via @code{with-continuation-barrier}.\n"
589 "When @var{handler} is specified, then @var{thunk} is called from\n"
590 "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
591 "handler. This catch is established inside the continuation barrier.\n"
593 "Once @var{thunk} or @var{handler} returns, the return value is made\n"
594 "the @emph{exit value} of the thread and the thread is terminated.")
595 #define FUNC_NAME s_scm_call_with_new_thread
601 SCM_ASSERT (scm_is_true (scm_thunk_p (thunk
)), thunk
, SCM_ARG1
, FUNC_NAME
);
602 SCM_ASSERT (SCM_UNBNDP (handler
) || scm_is_true (scm_procedure_p (handler
)),
603 handler
, SCM_ARG2
, FUNC_NAME
);
605 data
.parent
= scm_current_dynamic_state ();
607 data
.handler
= handler
;
608 data
.thread
= SCM_BOOL_F
;
609 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
610 scm_i_pthread_cond_init (&data
.cond
, NULL
);
612 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
613 err
= scm_i_pthread_create (&id
, NULL
, launch_thread
, &data
);
616 scm_i_pthread_mutex_unlock (&data
.mutex
);
620 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
621 scm_i_pthread_mutex_unlock (&data
.mutex
);
629 scm_t_catch_body body
;
631 scm_t_catch_handler handler
;
634 scm_i_pthread_mutex_t mutex
;
635 scm_i_pthread_cond_t cond
;
639 really_spawn (void *d
)
641 spawn_data
*data
= (spawn_data
*)d
;
642 scm_t_catch_body body
= data
->body
;
643 void *body_data
= data
->body_data
;
644 scm_t_catch_handler handler
= data
->handler
;
645 void *handler_data
= data
->handler_data
;
646 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
648 scm_i_scm_pthread_mutex_lock (&data
->mutex
);
649 data
->thread
= scm_current_thread ();
650 scm_i_pthread_cond_signal (&data
->cond
);
651 scm_i_pthread_mutex_unlock (&data
->mutex
);
654 t
->result
= body (body_data
);
656 t
->result
= scm_internal_catch (SCM_BOOL_T
,
658 handler
, handler_data
);
664 spawn_thread (void *d
)
666 spawn_data
*data
= (spawn_data
*)d
;
667 scm_i_pthread_detach (scm_i_pthread_self ());
668 scm_i_with_guile_and_parent (really_spawn
, d
, data
->parent
);
673 scm_spawn_thread (scm_t_catch_body body
, void *body_data
,
674 scm_t_catch_handler handler
, void *handler_data
)
680 data
.parent
= scm_current_dynamic_state ();
682 data
.body_data
= body_data
;
683 data
.handler
= handler
;
684 data
.handler_data
= handler_data
;
685 data
.thread
= SCM_BOOL_F
;
686 scm_i_pthread_mutex_init (&data
.mutex
, NULL
);
687 scm_i_pthread_cond_init (&data
.cond
, NULL
);
689 scm_i_scm_pthread_mutex_lock (&data
.mutex
);
690 err
= scm_i_pthread_create (&id
, NULL
, spawn_thread
, &data
);
693 scm_i_pthread_mutex_unlock (&data
.mutex
);
697 scm_i_scm_pthread_cond_wait (&data
.cond
, &data
.mutex
);
698 scm_i_pthread_mutex_unlock (&data
.mutex
);
703 SCM_DEFINE (scm_yield
, "yield", 0, 0, 0,
705 "Move the calling thread to the end of the scheduling queue.")
706 #define FUNC_NAME s_scm_yield
708 return scm_from_bool (scm_i_sched_yield ());
712 SCM_DEFINE (scm_join_thread
, "join-thread", 1, 0, 0,
714 "Suspend execution of the calling thread until the target @var{thread} "
715 "terminates, unless the target @var{thread} has already terminated. ")
716 #define FUNC_NAME s_scm_join_thread
721 SCM_VALIDATE_THREAD (1, thread
);
722 if (scm_is_eq (scm_current_thread (), thread
))
723 SCM_MISC_ERROR ("can not join the current thread", SCM_EOL
);
725 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
727 t
= SCM_I_THREAD_DATA (thread
);
732 block_self (t
->join_queue
, thread
, &thread_admin_mutex
, NULL
);
735 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
737 scm_i_scm_pthread_mutex_lock (&thread_admin_mutex
);
742 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
749 /* We implement our own mutex type since we want them to be 'fair', we
750 want to do fancy things while waiting for them (like running
751 asyncs) and we might want to add things that are nice for
756 scm_i_pthread_mutex_t lock
;
758 int level
; /* how much the owner owns us.
759 < 0 for non-recursive mutexes */
760 SCM waiting
; /* the threads waiting for this mutex. */
763 #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
764 #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
767 fat_mutex_mark (SCM mx
)
769 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
770 scm_gc_mark (m
->owner
);
775 fat_mutex_free (SCM mx
)
777 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
778 scm_i_pthread_mutex_destroy (&m
->lock
);
779 scm_gc_free (m
, sizeof (fat_mutex
), "mutex");
784 fat_mutex_print (SCM mx
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
786 fat_mutex
*m
= SCM_MUTEX_DATA (mx
);
787 scm_puts ("#<mutex ", port
);
788 scm_uintprint ((scm_t_bits
)m
, 16, port
);
789 scm_puts (">", port
);
794 make_fat_mutex (int recursive
)
799 m
= scm_gc_malloc (sizeof (fat_mutex
), "mutex");
800 scm_i_pthread_mutex_init (&m
->lock
, NULL
);
801 m
->owner
= SCM_BOOL_F
;
802 m
->level
= recursive
? 0 : -1;
803 m
->waiting
= SCM_EOL
;
804 SCM_NEWSMOB (mx
, scm_tc16_mutex
, (scm_t_bits
) m
);
805 m
->waiting
= make_queue ();
809 SCM_DEFINE (scm_make_mutex
, "make-mutex", 0, 0, 0,
811 "Create a new mutex. ")
812 #define FUNC_NAME s_scm_make_mutex
814 return make_fat_mutex (0);
818 SCM_DEFINE (scm_make_recursive_mutex
, "make-recursive-mutex", 0, 0, 0,
820 "Create a new recursive mutex. ")
821 #define FUNC_NAME s_scm_make_recursive_mutex
823 return make_fat_mutex (1);
828 fat_mutex_lock (SCM mutex
)
830 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
831 SCM thread
= scm_current_thread ();
834 scm_i_scm_pthread_mutex_lock (&m
->lock
);
835 if (scm_is_false (m
->owner
))
837 else if (scm_is_eq (m
->owner
, thread
))
842 msg
= "mutex already locked by current thread";
848 block_self (m
->waiting
, mutex
, &m
->lock
, NULL
);
849 if (scm_is_eq (m
->owner
, thread
))
851 scm_i_pthread_mutex_unlock (&m
->lock
);
853 scm_i_scm_pthread_mutex_lock (&m
->lock
);
856 scm_i_pthread_mutex_unlock (&m
->lock
);
860 SCM_DEFINE (scm_lock_mutex
, "lock-mutex", 1, 0, 0,
862 "Lock @var{mutex}. If the mutex is already locked, the calling thread "
863 "blocks until the mutex becomes available. The function returns when "
864 "the calling thread owns the lock on @var{mutex}. Locking a mutex that "
865 "a thread already owns will succeed right away and will not block the "
866 "thread. That is, Guile's mutexes are @emph{recursive}. ")
867 #define FUNC_NAME s_scm_lock_mutex
869 SCM_VALIDATE_MUTEX (1, mx
);
872 msg
= fat_mutex_lock (mx
);
874 scm_misc_error (NULL
, msg
, SCM_EOL
);
880 fat_mutex_trylock (fat_mutex
*m
, int *resp
)
883 SCM thread
= scm_current_thread ();
886 scm_i_pthread_mutex_lock (&m
->lock
);
887 if (scm_is_false (m
->owner
))
889 else if (scm_is_eq (m
->owner
, thread
))
894 msg
= "mutex already locked by current thread";
898 scm_i_pthread_mutex_unlock (&m
->lock
);
902 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
904 "Try to lock @var{mutex}. If the mutex is already locked by someone "
905 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
906 #define FUNC_NAME s_scm_try_mutex
911 SCM_VALIDATE_MUTEX (1, mutex
);
913 msg
= fat_mutex_trylock (SCM_MUTEX_DATA (mutex
), &res
);
915 scm_misc_error (NULL
, msg
, SCM_EOL
);
916 return scm_from_bool (res
);
921 fat_mutex_unlock (fat_mutex
*m
)
925 scm_i_scm_pthread_mutex_lock (&m
->lock
);
926 if (!scm_is_eq (m
->owner
, scm_current_thread ()))
928 if (scm_is_false (m
->owner
))
929 msg
= "mutex not locked";
931 msg
= "mutex not locked by current thread";
933 else if (m
->level
> 0)
936 m
->owner
= unblock_from_queue (m
->waiting
);
937 scm_i_pthread_mutex_unlock (&m
->lock
);
942 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
944 "Unlocks @var{mutex} if the calling thread owns the lock on "
945 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
946 "thread results in undefined behaviour. Once a mutex has been unlocked, "
947 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
948 "lock. Every call to @code{lock-mutex} by this thread must be matched "
949 "with a call to @code{unlock-mutex}. Only the last call to "
950 "@code{unlock-mutex} will actually unlock the mutex. ")
951 #define FUNC_NAME s_scm_unlock_mutex
954 SCM_VALIDATE_MUTEX (1, mx
);
956 msg
= fat_mutex_unlock (SCM_MUTEX_DATA (mx
));
958 scm_misc_error (NULL
, msg
, SCM_EOL
);
965 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
967 "Return the thread owning @var{mx}, or @code{#f}.")
968 #define FUNC_NAME s_scm_mutex_owner
970 SCM_VALIDATE_MUTEX (1, mx
);
971 return (SCM_MUTEX_DATA(mx
))->owner
;
975 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
977 "Return the lock level of a recursive mutex, or -1\n"
978 "for a standard mutex.")
979 #define FUNC_NAME s_scm_mutex_level
981 SCM_VALIDATE_MUTEX (1, mx
);
982 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
988 /*** Fat condition variables */
991 scm_i_pthread_mutex_t lock
;
992 SCM waiting
; /* the threads waiting for this condition. */
995 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
996 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
999 fat_cond_mark (SCM cv
)
1001 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1006 fat_cond_free (SCM mx
)
1008 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1009 scm_i_pthread_mutex_destroy (&c
->lock
);
1010 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1015 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1017 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1018 scm_puts ("#<condition-variable ", port
);
1019 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1020 scm_puts (">", port
);
1024 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1026 "Make a new condition variable.")
1027 #define FUNC_NAME s_scm_make_condition_variable
1032 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1033 scm_i_pthread_mutex_init (&c
->lock
, 0);
1034 c
->waiting
= SCM_EOL
;
1035 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1036 c
->waiting
= make_queue ();
1042 fat_cond_timedwait (SCM cond
, SCM mutex
,
1043 const scm_t_timespec
*waittime
)
1045 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1046 fat_cond
*c
= SCM_CONDVAR_DATA (cond
);
1047 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1053 fprintf (stderr
, "cond wait on %p\n", &c
->lock
);
1055 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1056 msg
= fat_mutex_unlock (m
);
1060 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1061 scm_i_pthread_mutex_unlock (&c
->lock
);
1062 fprintf (stderr
, "locking mutex\n");
1063 fat_mutex_lock (mutex
);
1066 scm_i_pthread_mutex_unlock (&c
->lock
);
1070 fprintf (stderr
, "back: %s, %d\n", msg
, err
);
1073 scm_misc_error (NULL
, msg
, SCM_EOL
);
1075 scm_remember_upto_here_2 (cond
, mutex
);
1079 if (err
== ETIMEDOUT
)
1084 scm_syserror (NULL
);
1089 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1090 (SCM cv
, SCM mx
, SCM t
),
1091 "Wait until @var{cond-var} has been signalled. While waiting, "
1092 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1093 "is locked again when this function returns. When @var{time} is given, "
1094 "it specifies a point in time where the waiting should be aborted. It "
1095 "can be either a integer as returned by @code{current-time} or a pair "
1096 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1097 "mutex is locked and @code{#f} is returned. When the condition "
1098 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1100 #define FUNC_NAME s_scm_timed_wait_condition_variable
1102 scm_t_timespec waittime
, *waitptr
= NULL
;
1104 SCM_VALIDATE_CONDVAR (1, cv
);
1105 SCM_VALIDATE_MUTEX (2, mx
);
1107 if (!SCM_UNBNDP (t
))
1109 if (scm_is_pair (t
))
1111 waittime
.tv_sec
= scm_to_ulong (SCM_CAR (t
));
1112 waittime
.tv_nsec
= scm_to_ulong (SCM_CAR (t
)) * 1000;
1116 waittime
.tv_sec
= scm_to_ulong (t
);
1117 waittime
.tv_nsec
= 0;
1119 waitptr
= &waittime
;
1122 return scm_from_bool (fat_cond_timedwait (cv
, mx
, waitptr
));
1127 fat_cond_signal (fat_cond
*c
)
1129 fprintf (stderr
, "cond signal on %p\n", &c
->lock
);
1131 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1132 unblock_from_queue (c
->waiting
);
1133 scm_i_pthread_mutex_unlock (&c
->lock
);
1136 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1138 "Wake up one thread that is waiting for @var{cv}")
1139 #define FUNC_NAME s_scm_signal_condition_variable
1141 SCM_VALIDATE_CONDVAR (1, cv
);
1142 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1148 fat_cond_broadcast (fat_cond
*c
)
1150 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1151 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1153 scm_i_pthread_mutex_unlock (&c
->lock
);
1156 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1158 "Wake up all threads that are waiting for @var{cv}. ")
1159 #define FUNC_NAME s_scm_broadcast_condition_variable
1161 SCM_VALIDATE_CONDVAR (1, cv
);
1162 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1167 /*** Marking stacks */
1169 /* XXX - what to do with this? Do we need to handle this for blocked
1173 # define SCM_MARK_BACKING_STORE() do { \
1175 SCM_STACKITEM * top, * bot; \
1176 getcontext (&ctx); \
1177 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1178 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1179 / sizeof (SCM_STACKITEM))); \
1180 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1181 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1182 scm_mark_locations (bot, top - bot); } while (0)
1184 # define SCM_MARK_BACKING_STORE()
1188 scm_threads_mark_stacks (void)
1191 for (t
= all_threads
; t
; t
= t
->next_thread
)
1193 /* Check that thread has indeed been suspended.
1197 scm_gc_mark (t
->handle
);
1199 #if SCM_STACK_GROWS_UP
1200 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1202 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1204 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1205 ((size_t) sizeof(t
->regs
)
1206 / sizeof (SCM_STACKITEM
)));
1209 SCM_MARK_BACKING_STORE ();
1215 scm_std_select (int nfds
,
1216 SELECT_TYPE
*readfds
,
1217 SELECT_TYPE
*writefds
,
1218 SELECT_TYPE
*exceptfds
,
1219 struct timeval
*timeout
)
1222 int res
, eno
, wakeup_fd
;
1223 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1224 scm_t_guile_ticket ticket
;
1226 if (readfds
== NULL
)
1228 FD_ZERO (&my_readfds
);
1229 readfds
= &my_readfds
;
1232 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1235 wakeup_fd
= t
->sleep_pipe
[0];
1236 ticket
= scm_leave_guile ();
1237 FD_SET (wakeup_fd
, readfds
);
1238 if (wakeup_fd
>= nfds
)
1240 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1243 scm_enter_guile (ticket
);
1245 scm_i_reset_sleep (t
);
1247 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1250 read (wakeup_fd
, &dummy
, 1);
1251 FD_CLR (wakeup_fd
, readfds
);
1263 /* Convenience API for blocking while in guile mode. */
1265 #if SCM_USE_PTHREAD_THREADS
1268 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1270 scm_t_guile_ticket t
= scm_leave_guile ();
1271 int res
= scm_i_pthread_mutex_lock (mutex
);
1272 scm_enter_guile (t
);
1279 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1283 scm_frame_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1285 scm_i_scm_pthread_mutex_lock (mutex
);
1286 scm_frame_unwind_handler (unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1290 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1292 scm_t_guile_ticket t
= scm_leave_guile ();
1293 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1294 scm_enter_guile (t
);
1299 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1300 scm_i_pthread_mutex_t
*mutex
,
1301 const scm_t_timespec
*wt
)
1303 scm_t_guile_ticket t
= scm_leave_guile ();
1304 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1305 scm_enter_guile (t
);
1312 scm_std_usleep (unsigned long usecs
)
1315 tv
.tv_usec
= usecs
% 1000000;
1316 tv
.tv_sec
= usecs
/ 1000000;
1317 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1318 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1322 scm_std_sleep (unsigned int secs
)
1327 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1333 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1335 "Return the thread that called this function.")
1336 #define FUNC_NAME s_scm_current_thread
1338 return SCM_I_CURRENT_THREAD
->handle
;
1343 scm_c_make_list (size_t n
, SCM fill
)
1347 res
= scm_cons (fill
, res
);
1351 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1353 "Return a list of all threads.")
1354 #define FUNC_NAME s_scm_all_threads
1356 /* We can not allocate while holding the thread_admin_mutex because
1357 of the way GC is done.
1359 int n
= thread_count
;
1361 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1363 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1365 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1367 SCM_SETCAR (*l
, t
->handle
);
1368 l
= SCM_CDRLOC (*l
);
1372 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1377 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1379 "Return @code{#t} iff @var{thread} has exited.\n")
1380 #define FUNC_NAME s_scm_thread_exited_p
1382 return scm_from_bool (scm_c_thread_exited_p (thread
));
1387 scm_c_thread_exited_p (SCM thread
)
1388 #define FUNC_NAME s_scm_thread_exited_p
1391 SCM_VALIDATE_THREAD (1, thread
);
1392 t
= SCM_I_THREAD_DATA (thread
);
1397 static scm_i_pthread_cond_t wake_up_cond
;
1398 int scm_i_thread_go_to_sleep
;
1399 static int threads_initialized_p
= 0;
1400 static int sleep_level
= 0;
1403 scm_i_thread_put_to_sleep ()
1405 if (threads_initialized_p
)
1410 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1412 if (sleep_level
== 0)
1414 /* Signal all threads to go to sleep
1416 scm_i_thread_go_to_sleep
= 1;
1417 for (t
= all_threads
; t
; t
= t
->next_thread
)
1418 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1419 scm_i_thread_go_to_sleep
= 0;
1423 /* We are already single threaded. Suspend again to update
1424 the recorded stack information.
1430 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1435 scm_i_thread_invalidate_freelists ()
1437 /* thread_admin_mutex is already locked. */
1440 for (t
= all_threads
; t
; t
= t
->next_thread
)
1441 if (t
!= SCM_I_CURRENT_THREAD
)
1442 t
->clear_freelists_p
= 1;
1446 scm_i_thread_wake_up ()
1448 if (threads_initialized_p
)
1451 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1454 if (sleep_level
== 0)
1456 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1457 for (t
= all_threads
; t
; t
= t
->next_thread
)
1458 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1461 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1462 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1467 scm_i_thread_sleep_for_gc ()
1469 scm_i_thread
*t
= suspend ();
1470 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1475 put_to_sleep (void *unused
)
1477 scm_i_thread_put_to_sleep ();
1481 wake_up (void *unused
)
1483 scm_i_thread_wake_up ();
1487 scm_i_frame_single_threaded ()
1489 scm_frame_rewind_handler (put_to_sleep
, NULL
, SCM_F_WIND_EXPLICITLY
);
1490 scm_frame_unwind_handler (wake_up
, NULL
, SCM_F_WIND_EXPLICITLY
);
1493 scm_i_pthread_mutex_t scm_i_critical_section_mutex
=
1494 SCM_I_PTHREAD_MUTEX_INITIALIZER
;
1497 scm_frame_critical_section ()
1499 scm_i_frame_pthread_mutex_lock (&scm_i_critical_section_mutex
);
1500 scm_frame_block_asyncs ();
1503 /*** Initialization */
1505 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1506 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1509 scm_threads_prehistory (SCM_STACKITEM
*base
)
1511 scm_i_pthread_mutex_init (&thread_admin_mutex
, NULL
);
1512 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1513 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1514 scm_i_pthread_mutex_init (&scm_i_critical_section_mutex
, NULL
);
1515 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1516 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1518 guilify_self_1 (base
);
1521 scm_t_bits scm_tc16_thread
;
1522 scm_t_bits scm_tc16_mutex
;
1523 scm_t_bits scm_tc16_condvar
;
1528 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1529 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1530 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1531 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1533 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1534 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
1535 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1536 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1538 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1540 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
1541 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1542 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1544 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1545 guilify_self_2 (SCM_BOOL_F
);
1546 threads_initialized_p
= 1;
1550 scm_init_threads_default_dynamic_state ()
1552 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
1553 scm_i_default_dynamic_state
= scm_permanent_object (state
);
1557 scm_init_thread_procs ()
1559 #include "libguile/threads.x"