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 scm_frame_lock_mutex (SCM mutex
)
882 scm_frame_unwind_handler_with_scm ((void(*)(SCM
))scm_unlock_mutex
, mutex
,
883 SCM_F_WIND_EXPLICITLY
);
884 scm_frame_rewind_handler_with_scm ((void(*)(SCM
))scm_lock_mutex
, mutex
,
885 SCM_F_WIND_EXPLICITLY
);
889 fat_mutex_trylock (fat_mutex
*m
, int *resp
)
892 SCM thread
= scm_current_thread ();
895 scm_i_pthread_mutex_lock (&m
->lock
);
896 if (scm_is_false (m
->owner
))
898 else if (scm_is_eq (m
->owner
, thread
))
903 msg
= "mutex already locked by current thread";
907 scm_i_pthread_mutex_unlock (&m
->lock
);
911 SCM_DEFINE (scm_try_mutex
, "try-mutex", 1, 0, 0,
913 "Try to lock @var{mutex}. If the mutex is already locked by someone "
914 "else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
915 #define FUNC_NAME s_scm_try_mutex
920 SCM_VALIDATE_MUTEX (1, mutex
);
922 msg
= fat_mutex_trylock (SCM_MUTEX_DATA (mutex
), &res
);
924 scm_misc_error (NULL
, msg
, SCM_EOL
);
925 return scm_from_bool (res
);
930 fat_mutex_unlock (fat_mutex
*m
)
934 scm_i_scm_pthread_mutex_lock (&m
->lock
);
935 if (!scm_is_eq (m
->owner
, scm_current_thread ()))
937 if (scm_is_false (m
->owner
))
938 msg
= "mutex not locked";
940 msg
= "mutex not locked by current thread";
942 else if (m
->level
> 0)
945 m
->owner
= unblock_from_queue (m
->waiting
);
946 scm_i_pthread_mutex_unlock (&m
->lock
);
951 SCM_DEFINE (scm_unlock_mutex
, "unlock-mutex", 1, 0, 0,
953 "Unlocks @var{mutex} if the calling thread owns the lock on "
954 "@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
955 "thread results in undefined behaviour. Once a mutex has been unlocked, "
956 "one thread blocked on @var{mutex} is awakened and grabs the mutex "
957 "lock. Every call to @code{lock-mutex} by this thread must be matched "
958 "with a call to @code{unlock-mutex}. Only the last call to "
959 "@code{unlock-mutex} will actually unlock the mutex. ")
960 #define FUNC_NAME s_scm_unlock_mutex
963 SCM_VALIDATE_MUTEX (1, mx
);
965 msg
= fat_mutex_unlock (SCM_MUTEX_DATA (mx
));
967 scm_misc_error (NULL
, msg
, SCM_EOL
);
974 SCM_DEFINE (scm_mutex_owner
, "mutex-owner", 1, 0, 0,
976 "Return the thread owning @var{mx}, or @code{#f}.")
977 #define FUNC_NAME s_scm_mutex_owner
979 SCM_VALIDATE_MUTEX (1, mx
);
980 return (SCM_MUTEX_DATA(mx
))->owner
;
984 SCM_DEFINE (scm_mutex_level
, "mutex-level", 1, 0, 0,
986 "Return the lock level of a recursive mutex, or -1\n"
987 "for a standard mutex.")
988 #define FUNC_NAME s_scm_mutex_level
990 SCM_VALIDATE_MUTEX (1, mx
);
991 return scm_from_int (SCM_MUTEX_DATA(mx
)->level
);
997 /*** Fat condition variables */
1000 scm_i_pthread_mutex_t lock
;
1001 SCM waiting
; /* the threads waiting for this condition. */
1004 #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
1005 #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
1008 fat_cond_mark (SCM cv
)
1010 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1015 fat_cond_free (SCM mx
)
1017 fat_cond
*c
= SCM_CONDVAR_DATA (mx
);
1018 scm_i_pthread_mutex_destroy (&c
->lock
);
1019 scm_gc_free (c
, sizeof (fat_cond
), "condition-variable");
1024 fat_cond_print (SCM cv
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
1026 fat_cond
*c
= SCM_CONDVAR_DATA (cv
);
1027 scm_puts ("#<condition-variable ", port
);
1028 scm_uintprint ((scm_t_bits
)c
, 16, port
);
1029 scm_puts (">", port
);
1033 SCM_DEFINE (scm_make_condition_variable
, "make-condition-variable", 0, 0, 0,
1035 "Make a new condition variable.")
1036 #define FUNC_NAME s_scm_make_condition_variable
1041 c
= scm_gc_malloc (sizeof (fat_cond
), "condition variable");
1042 scm_i_pthread_mutex_init (&c
->lock
, 0);
1043 c
->waiting
= SCM_EOL
;
1044 SCM_NEWSMOB (cv
, scm_tc16_condvar
, (scm_t_bits
) c
);
1045 c
->waiting
= make_queue ();
1051 fat_cond_timedwait (SCM cond
, SCM mutex
,
1052 const scm_t_timespec
*waittime
)
1054 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1055 fat_cond
*c
= SCM_CONDVAR_DATA (cond
);
1056 fat_mutex
*m
= SCM_MUTEX_DATA (mutex
);
1062 fprintf (stderr
, "cond wait on %p\n", &c
->lock
);
1064 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1065 msg
= fat_mutex_unlock (m
);
1069 err
= block_self (c
->waiting
, cond
, &c
->lock
, waittime
);
1070 scm_i_pthread_mutex_unlock (&c
->lock
);
1071 fprintf (stderr
, "locking mutex\n");
1072 fat_mutex_lock (mutex
);
1075 scm_i_pthread_mutex_unlock (&c
->lock
);
1079 fprintf (stderr
, "back: %s, %d\n", msg
, err
);
1082 scm_misc_error (NULL
, msg
, SCM_EOL
);
1084 scm_remember_upto_here_2 (cond
, mutex
);
1088 if (err
== ETIMEDOUT
)
1093 scm_syserror (NULL
);
1098 SCM_DEFINE (scm_timed_wait_condition_variable
, "wait-condition-variable", 2, 1, 0,
1099 (SCM cv
, SCM mx
, SCM t
),
1100 "Wait until @var{cond-var} has been signalled. While waiting, "
1101 "@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
1102 "is locked again when this function returns. When @var{time} is given, "
1103 "it specifies a point in time where the waiting should be aborted. It "
1104 "can be either a integer as returned by @code{current-time} or a pair "
1105 "as returned by @code{gettimeofday}. When the waiting is aborted the "
1106 "mutex is locked and @code{#f} is returned. When the condition "
1107 "variable is in fact signalled, the mutex is also locked and @code{#t} "
1109 #define FUNC_NAME s_scm_timed_wait_condition_variable
1111 scm_t_timespec waittime
, *waitptr
= NULL
;
1113 SCM_VALIDATE_CONDVAR (1, cv
);
1114 SCM_VALIDATE_MUTEX (2, mx
);
1116 if (!SCM_UNBNDP (t
))
1118 if (scm_is_pair (t
))
1120 waittime
.tv_sec
= scm_to_ulong (SCM_CAR (t
));
1121 waittime
.tv_nsec
= scm_to_ulong (SCM_CAR (t
)) * 1000;
1125 waittime
.tv_sec
= scm_to_ulong (t
);
1126 waittime
.tv_nsec
= 0;
1128 waitptr
= &waittime
;
1131 return scm_from_bool (fat_cond_timedwait (cv
, mx
, waitptr
));
1136 fat_cond_signal (fat_cond
*c
)
1138 fprintf (stderr
, "cond signal on %p\n", &c
->lock
);
1140 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1141 unblock_from_queue (c
->waiting
);
1142 scm_i_pthread_mutex_unlock (&c
->lock
);
1145 SCM_DEFINE (scm_signal_condition_variable
, "signal-condition-variable", 1, 0, 0,
1147 "Wake up one thread that is waiting for @var{cv}")
1148 #define FUNC_NAME s_scm_signal_condition_variable
1150 SCM_VALIDATE_CONDVAR (1, cv
);
1151 fat_cond_signal (SCM_CONDVAR_DATA (cv
));
1157 fat_cond_broadcast (fat_cond
*c
)
1159 scm_i_scm_pthread_mutex_lock (&c
->lock
);
1160 while (scm_is_true (unblock_from_queue (c
->waiting
)))
1162 scm_i_pthread_mutex_unlock (&c
->lock
);
1165 SCM_DEFINE (scm_broadcast_condition_variable
, "broadcast-condition-variable", 1, 0, 0,
1167 "Wake up all threads that are waiting for @var{cv}. ")
1168 #define FUNC_NAME s_scm_broadcast_condition_variable
1170 SCM_VALIDATE_CONDVAR (1, cv
);
1171 fat_cond_broadcast (SCM_CONDVAR_DATA (cv
));
1176 /*** Marking stacks */
1178 /* XXX - what to do with this? Do we need to handle this for blocked
1182 # define SCM_MARK_BACKING_STORE() do { \
1184 SCM_STACKITEM * top, * bot; \
1185 getcontext (&ctx); \
1186 scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
1187 ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
1188 / sizeof (SCM_STACKITEM))); \
1189 bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
1190 top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
1191 scm_mark_locations (bot, top - bot); } while (0)
1193 # define SCM_MARK_BACKING_STORE()
1197 scm_threads_mark_stacks (void)
1200 for (t
= all_threads
; t
; t
= t
->next_thread
)
1202 /* Check that thread has indeed been suspended.
1206 scm_gc_mark (t
->handle
);
1208 #if SCM_STACK_GROWS_UP
1209 scm_mark_locations (t
->base
, t
->top
- t
->base
);
1211 scm_mark_locations (t
->top
, t
->base
- t
->top
);
1213 scm_mark_locations ((SCM_STACKITEM
*) t
->regs
,
1214 ((size_t) sizeof(t
->regs
)
1215 / sizeof (SCM_STACKITEM
)));
1218 SCM_MARK_BACKING_STORE ();
1224 scm_std_select (int nfds
,
1225 SELECT_TYPE
*readfds
,
1226 SELECT_TYPE
*writefds
,
1227 SELECT_TYPE
*exceptfds
,
1228 struct timeval
*timeout
)
1231 int res
, eno
, wakeup_fd
;
1232 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
1233 scm_t_guile_ticket ticket
;
1235 if (readfds
== NULL
)
1237 FD_ZERO (&my_readfds
);
1238 readfds
= &my_readfds
;
1241 while (scm_i_setup_sleep (t
, SCM_BOOL_F
, NULL
, t
->sleep_pipe
[1]))
1244 wakeup_fd
= t
->sleep_pipe
[0];
1245 ticket
= scm_leave_guile ();
1246 FD_SET (wakeup_fd
, readfds
);
1247 if (wakeup_fd
>= nfds
)
1249 res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
1252 scm_enter_guile (ticket
);
1254 scm_i_reset_sleep (t
);
1256 if (res
> 0 && FD_ISSET (wakeup_fd
, readfds
))
1259 read (wakeup_fd
, &dummy
, 1);
1260 FD_CLR (wakeup_fd
, readfds
);
1272 /* Convenience API for blocking while in guile mode. */
1274 #if SCM_USE_PTHREAD_THREADS
1277 scm_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1279 scm_t_guile_ticket t
= scm_leave_guile ();
1280 int res
= scm_i_pthread_mutex_lock (mutex
);
1281 scm_enter_guile (t
);
1288 scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t
*)data
);
1292 scm_frame_pthread_mutex_lock (scm_i_pthread_mutex_t
*mutex
)
1294 scm_i_scm_pthread_mutex_lock (mutex
);
1295 scm_frame_unwind_handler (unlock
, mutex
, SCM_F_WIND_EXPLICITLY
);
1299 scm_pthread_cond_wait (scm_i_pthread_cond_t
*cond
, scm_i_pthread_mutex_t
*mutex
)
1301 scm_t_guile_ticket t
= scm_leave_guile ();
1302 int res
= scm_i_pthread_cond_wait (cond
, mutex
);
1303 scm_enter_guile (t
);
1308 scm_pthread_cond_timedwait (scm_i_pthread_cond_t
*cond
,
1309 scm_i_pthread_mutex_t
*mutex
,
1310 const scm_t_timespec
*wt
)
1312 scm_t_guile_ticket t
= scm_leave_guile ();
1313 int res
= scm_i_pthread_cond_timedwait (cond
, mutex
, wt
);
1314 scm_enter_guile (t
);
1321 scm_std_usleep (unsigned long usecs
)
1324 tv
.tv_usec
= usecs
% 1000000;
1325 tv
.tv_sec
= usecs
/ 1000000;
1326 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1327 return tv
.tv_sec
* 1000000 + tv
.tv_usec
;
1331 scm_std_sleep (unsigned int secs
)
1336 scm_std_select (0, NULL
, NULL
, NULL
, &tv
);
1342 SCM_DEFINE (scm_current_thread
, "current-thread", 0, 0, 0,
1344 "Return the thread that called this function.")
1345 #define FUNC_NAME s_scm_current_thread
1347 return SCM_I_CURRENT_THREAD
->handle
;
1352 scm_c_make_list (size_t n
, SCM fill
)
1356 res
= scm_cons (fill
, res
);
1360 SCM_DEFINE (scm_all_threads
, "all-threads", 0, 0, 0,
1362 "Return a list of all threads.")
1363 #define FUNC_NAME s_scm_all_threads
1365 /* We can not allocate while holding the thread_admin_mutex because
1366 of the way GC is done.
1368 int n
= thread_count
;
1370 SCM list
= scm_c_make_list (n
, SCM_UNSPECIFIED
), *l
;
1372 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1374 for (t
= all_threads
; t
&& n
> 0; t
= t
->next_thread
)
1376 SCM_SETCAR (*l
, t
->handle
);
1377 l
= SCM_CDRLOC (*l
);
1381 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1386 SCM_DEFINE (scm_thread_exited_p
, "thread-exited?", 1, 0, 0,
1388 "Return @code{#t} iff @var{thread} has exited.\n")
1389 #define FUNC_NAME s_scm_thread_exited_p
1391 return scm_from_bool (scm_c_thread_exited_p (thread
));
1396 scm_c_thread_exited_p (SCM thread
)
1397 #define FUNC_NAME s_scm_thread_exited_p
1400 SCM_VALIDATE_THREAD (1, thread
);
1401 t
= SCM_I_THREAD_DATA (thread
);
1406 static scm_i_pthread_cond_t wake_up_cond
;
1407 int scm_i_thread_go_to_sleep
;
1408 static int threads_initialized_p
= 0;
1409 static int sleep_level
= 0;
1412 scm_i_thread_put_to_sleep ()
1414 if (threads_initialized_p
)
1419 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1421 if (sleep_level
== 0)
1423 /* Signal all threads to go to sleep
1425 scm_i_thread_go_to_sleep
= 1;
1426 for (t
= all_threads
; t
; t
= t
->next_thread
)
1427 scm_i_pthread_mutex_lock (&t
->heap_mutex
);
1428 scm_i_thread_go_to_sleep
= 0;
1432 /* We are already single threaded. Suspend again to update
1433 the recorded stack information.
1439 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1444 scm_i_thread_invalidate_freelists ()
1446 /* thread_admin_mutex is already locked. */
1449 for (t
= all_threads
; t
; t
= t
->next_thread
)
1450 if (t
!= SCM_I_CURRENT_THREAD
)
1451 t
->clear_freelists_p
= 1;
1455 scm_i_thread_wake_up ()
1457 if (threads_initialized_p
)
1460 scm_i_pthread_mutex_lock (&thread_admin_mutex
);
1463 if (sleep_level
== 0)
1465 scm_i_pthread_cond_broadcast (&wake_up_cond
);
1466 for (t
= all_threads
; t
; t
= t
->next_thread
)
1467 scm_i_pthread_mutex_unlock (&t
->heap_mutex
);
1470 scm_i_pthread_mutex_unlock (&thread_admin_mutex
);
1471 scm_enter_guile ((scm_t_guile_ticket
) SCM_I_CURRENT_THREAD
);
1476 scm_i_thread_sleep_for_gc ()
1478 scm_i_thread
*t
= suspend ();
1479 scm_i_pthread_cond_wait (&wake_up_cond
, &t
->heap_mutex
);
1484 put_to_sleep (void *unused
)
1486 scm_i_thread_put_to_sleep ();
1490 wake_up (void *unused
)
1492 scm_i_thread_wake_up ();
1496 scm_i_frame_single_threaded ()
1498 scm_frame_rewind_handler (put_to_sleep
, NULL
, SCM_F_WIND_EXPLICITLY
);
1499 scm_frame_unwind_handler (wake_up
, NULL
, SCM_F_WIND_EXPLICITLY
);
1502 /* This mutex is used by SCM_CRITICAL_SECTION_START/END.
1504 scm_i_pthread_mutex_t scm_i_critical_section_mutex
=
1505 SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER
;
1506 int scm_i_critical_section_level
= 0;
1508 static SCM framed_critical_section_mutex
;
1511 scm_frame_critical_section (SCM mutex
)
1513 if (scm_is_false (mutex
))
1514 mutex
= framed_critical_section_mutex
;
1515 scm_frame_lock_mutex (mutex
);
1516 scm_frame_block_asyncs ();
1519 /*** Initialization */
1521 scm_i_pthread_key_t scm_i_freelist
, scm_i_freelist2
;
1522 scm_i_pthread_mutex_t scm_i_misc_mutex
;
1525 scm_threads_prehistory (SCM_STACKITEM
*base
)
1527 scm_i_pthread_mutex_init (&scm_i_misc_mutex
, NULL
);
1528 scm_i_pthread_cond_init (&wake_up_cond
, NULL
);
1529 scm_i_pthread_key_create (&scm_i_freelist
, NULL
);
1530 scm_i_pthread_key_create (&scm_i_freelist2
, NULL
);
1532 guilify_self_1 (base
);
1535 scm_t_bits scm_tc16_thread
;
1536 scm_t_bits scm_tc16_mutex
;
1537 scm_t_bits scm_tc16_condvar
;
1542 scm_tc16_thread
= scm_make_smob_type ("thread", sizeof (scm_i_thread
));
1543 scm_set_smob_mark (scm_tc16_thread
, thread_mark
);
1544 scm_set_smob_print (scm_tc16_thread
, thread_print
);
1545 scm_set_smob_free (scm_tc16_thread
, thread_free
);
1547 scm_tc16_mutex
= scm_make_smob_type ("mutex", sizeof (fat_mutex
));
1548 scm_set_smob_mark (scm_tc16_mutex
, fat_mutex_mark
);
1549 scm_set_smob_print (scm_tc16_mutex
, fat_mutex_print
);
1550 scm_set_smob_free (scm_tc16_mutex
, fat_mutex_free
);
1552 scm_tc16_condvar
= scm_make_smob_type ("condition-variable",
1554 scm_set_smob_mark (scm_tc16_condvar
, fat_cond_mark
);
1555 scm_set_smob_print (scm_tc16_condvar
, fat_cond_print
);
1556 scm_set_smob_free (scm_tc16_condvar
, fat_cond_free
);
1558 scm_i_default_dynamic_state
= SCM_BOOL_F
;
1559 guilify_self_2 (SCM_BOOL_F
);
1560 threads_initialized_p
= 1;
1562 framed_critical_section_mutex
=
1563 scm_permanent_object (scm_make_recursive_mutex ());
1567 scm_init_threads_default_dynamic_state ()
1569 SCM state
= scm_make_dynamic_state (scm_current_dynamic_state ());
1570 scm_i_default_dynamic_state
= scm_permanent_object (state
);
1574 scm_init_thread_procs ()
1576 #include "libguile/threads.x"