Index: scmsigs.c =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/scmsigs.c,v retrieving revision 1.98 diff -a -u -r1.98 scmsigs.c --- scmsigs.c 20 Oct 2007 11:09:58 -0000 1.98 +++ scmsigs.c 29 Oct 2007 13:15:31 -0000 @@ -212,9 +212,7 @@ if (pipe (signal_pipe) != 0) scm_syserror (NULL); - signal_thread = scm_spawn_thread (signal_delivery_thread, NULL, - scm_handle_by_message, - "signal delivery thread"); + signal_thread = scm_spawn_thread (signal_delivery_thread, NULL, NULL, NULL); scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread); scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex); Index: threads.c =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v retrieving revision 1.90 diff -a -u -r1.90 threads.c --- threads.c 20 Oct 2007 11:09:58 -0000 1.90 +++ threads.c 29 Oct 2007 13:15:34 -0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -15,7 +15,6 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ - #define _GNU_SOURCE @@ -49,6 +48,8 @@ #include "libguile/gc.h" #include "libguile/init.h" #include "libguile/scmsigs.h" +#include "libguile/strings.h" +#include "libguile/list.h" #ifdef __MINGW32__ #ifndef ETIMEDOUT @@ -59,6 +60,26 @@ # define pipe(fd) _pipe (fd, 256, O_BINARY) #endif /* __MINGW32__ */ +static scm_t_timespec +scm_to_timespec (SCM t) +{ + scm_t_timespec waittime; + if (scm_is_pair (t)) + { + waittime.tv_sec = scm_to_ulong (SCM_CAR (t)); + waittime.tv_nsec = scm_to_ulong (SCM_CDR (t)) * 1000; + } + else + { + double time = scm_to_double (t); + double sec = scm_c_truncate (time); + + waittime.tv_sec = (long) sec; + waittime.tv_nsec = (long) ((time - sec) * 1000000); + } + return waittime; +} + /*** Queues */ /* Make an empty queue data structure. @@ -131,7 +152,9 @@ thread_mark (SCM obj) { scm_i_thread *t = SCM_I_THREAD_DATA (obj); + scm_gc_mark (t->mutexes); scm_gc_mark (t->result); + scm_gc_mark (t->exception); scm_gc_mark (t->cleanup_handler); scm_gc_mark (t->join_queue); scm_gc_mark (t->dynwinds); @@ -212,6 +235,7 @@ The system asyncs themselves are not executed by block_self. */ + static int block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex, const scm_t_timespec *waittime) @@ -224,8 +248,10 @@ err = EINTR; else { + scm_i_pthread_cleanup_push ((void (*)(void *)) scm_i_reset_sleep, t); t->block_asyncs++; q_handle = enqueue (queue, t->handle); + if (waittime == NULL) err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex); else @@ -239,6 +265,7 @@ err = EINTR; t->block_asyncs--; scm_i_reset_sleep (t); + scm_i_pthread_cleanup_pop (0); } return err; @@ -246,15 +273,20 @@ /* Wake up the first thread on QUEUE, if any. The caller must hold the mutex that protects QUEUE. The awoken thread is returned, or - #f when the queue was empty. + SCM_UNDEFINED when the queue was empty. */ static SCM unblock_from_queue (SCM queue) { SCM thread = dequeue (queue); + if (scm_is_true (thread)) - scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond); - return thread; + { + scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond); + return thread; + } + + return SCM_UNDEFINED; } /* Getting into and out of guile mode. @@ -407,6 +439,8 @@ static SCM scm_i_default_dynamic_state; +extern scm_i_thread *scm_i_signal_delivery_thread; + /* Perform first stage of thread initialisation, in non-guile mode. */ static void @@ -417,7 +451,9 @@ t->pthread = scm_i_pthread_self (); t->handle = SCM_BOOL_F; t->result = SCM_BOOL_F; + t->exception = SCM_BOOL_F; t->cleanup_handler = SCM_BOOL_F; + t->mutexes = SCM_EOL; t->join_queue = SCM_EOL; t->dynamic_state = SCM_BOOL_F; t->dynwinds = SCM_EOL; @@ -435,6 +471,7 @@ /* XXX - check for errors. */ pipe (t->sleep_pipe); scm_i_pthread_mutex_init (&t->heap_mutex, NULL); + scm_i_pthread_mutex_init (&t->admin_mutex, NULL); t->clear_freelists_p = 0; t->gc_running_p = 0; t->canceled = 0; @@ -477,6 +514,25 @@ t->block_asyncs = 0; } +static SCM +exception_preserve_catch_handler (void *data, SCM tag, SCM throw_args) +{ + scm_i_thread *t = (scm_i_thread *) data; + t->exception = scm_cons (tag, throw_args); + return SCM_BOOL_F; +} + +typedef struct { + scm_i_pthread_mutex_t lock; + SCM owner; + int level; /* how much the owner owns us. + < 0 for non-recursive mutexes */ + SCM waiting; /* the threads waiting for this mutex. */ +} fat_mutex; + +#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) +#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) + /* Perform thread tear-down, in guile mode. */ static void * @@ -487,22 +543,31 @@ if (!scm_is_false (t->cleanup_handler)) { SCM ptr = t->cleanup_handler; - t->cleanup_handler = SCM_BOOL_F; - t->result = scm_internal_catch (SCM_BOOL_T, + t->result = scm_internal_catch (SCM_BOOL_T, (scm_t_catch_body) scm_call_0, ptr, - scm_handle_by_message_noexit, NULL); + exception_preserve_catch_handler, t); } - scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); + scm_i_pthread_mutex_lock (&t->admin_mutex); t->exited = 1; close (t->sleep_pipe[0]); close (t->sleep_pipe[1]); - while (scm_is_true (unblock_from_queue (t->join_queue))) + while (unblock_from_queue (t->join_queue) != SCM_UNDEFINED) ; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + while (!scm_is_null (t->mutexes)) + { + SCM mutex = SCM_CAR (t->mutexes); + fat_mutex *m = SCM_MUTEX_DATA (mutex); + scm_i_pthread_mutex_lock (&m->lock); + unblock_from_queue (m->waiting); + scm_i_pthread_mutex_unlock (&m->lock); + t->mutexes = SCM_CDR (t->mutexes); + } + + scm_i_pthread_mutex_unlock (&t->admin_mutex); return NULL; } @@ -515,14 +580,14 @@ scm_i_pthread_setspecific (scm_i_thread_key, v); - /* Ensure the signal handling thread has been launched, because we might be - shutting it down. */ - scm_i_ensure_signal_delivery_thread (); - /* Unblocking the joining threads needs to happen in guile mode since the queue is a SCM data structure. */ scm_with_guile (do_thread_exit, v); + /* Ensure the signal handling thread has been launched, because we might be + shutting it down. */ + scm_i_ensure_signal_delivery_thread (); + /* Removing ourself from the list of all threads needs to happen in non-guile mode since all SCM values on our stack become unprotected once we are no longer in the list. */ @@ -749,6 +814,13 @@ return res; } +SCM_GLOBAL_SYMBOL (scm_uncaught_exception_key, "uncaught-exception"); +SCM_GLOBAL_SYMBOL (scm_join_timeout_exception_key, "join-timeout-exception"); +SCM_GLOBAL_SYMBOL (scm_abandoned_mutex_exception_key, + "abandoned-mutex-exception"); +SCM_GLOBAL_SYMBOL (scm_terminated_thread_exception_key, + "terminated-thread-exception"); + /*** Thread creation */ typedef struct { @@ -775,7 +847,9 @@ scm_i_pthread_mutex_unlock (&data->mutex); if (SCM_UNBNDP (handler)) - t->result = scm_call_0 (thunk); + t->result = scm_internal_catch (scm_uncaught_exception_key, + (scm_t_catch_body) scm_call_0, thunk, + exception_preserve_catch_handler, t); else t->result = scm_catch (SCM_BOOL_T, thunk, handler); @@ -931,15 +1005,13 @@ SCM_VALIDATE_THREAD (1, thread); t = SCM_I_THREAD_DATA (thread); - scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); + scm_i_scm_pthread_mutex_lock (&t->admin_mutex); if (!t->canceled) { t->canceled = 1; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); scm_i_pthread_cancel (t->pthread); } - else - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_mutex_unlock (&t->admin_mutex); return SCM_UNSPECIFIED; } @@ -957,13 +1029,12 @@ if (!scm_is_false (proc)) SCM_VALIDATE_THUNK (2, proc); - scm_i_pthread_mutex_lock (&thread_admin_mutex); - t = SCM_I_THREAD_DATA (thread); + scm_i_pthread_mutex_lock (&t->admin_mutex); if (!(t->exited || t->canceled)) t->cleanup_handler = proc; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_mutex_unlock (&t->admin_mutex); return SCM_UNSPECIFIED; } @@ -978,12 +1049,10 @@ SCM ret; SCM_VALIDATE_THREAD (1, thread); - - scm_i_pthread_mutex_lock (&thread_admin_mutex); t = SCM_I_THREAD_DATA (thread); + scm_i_pthread_mutex_lock (&t->admin_mutex); ret = (t->exited || t->canceled) ? SCM_BOOL_F : t->cleanup_handler; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); - + scm_i_pthread_mutex_unlock (&t->admin_mutex); return ret; } #undef FUNC_NAME @@ -994,33 +1063,82 @@ "terminates, unless the target @var{thread} has already terminated. ") #define FUNC_NAME s_scm_join_thread { + return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, + (SCM thread, SCM timeout, SCM timeoutval), +"Suspend execution of the calling thread until the target @var{thread} " +"terminates or until @var{timeout} has elapsed, unless the target " +"@var{thread} has already terminated. If @var{timeout_val} is specified and " +"@var{timeout} elapses before @{thread} terminates, it will be returned as " +"the value of this function; if @var{timeout_val} is not specified, " +"@var{join-thread} will throw a @var{join-timeout-exception} exception.") +#define FUNC_NAME s_scm_join_thread_timed +{ + int timed_out = 0; scm_i_thread *t; - SCM res; + scm_t_timespec ctimeout, *timeout_ptr = NULL; + SCM res = SCM_BOOL_F, ex = SCM_BOOL_F; SCM_VALIDATE_THREAD (1, thread); if (scm_is_eq (scm_current_thread (), thread)) SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL); - scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); - t = SCM_I_THREAD_DATA (thread); + scm_i_scm_pthread_mutex_lock (&t->admin_mutex); + + if (! SCM_UNBNDP (timeout)) + { + ctimeout = scm_to_timespec (timeout); + timeout_ptr = &ctimeout; + } + if (!t->exited) { while (1) { - block_self (t->join_queue, thread, &thread_admin_mutex, NULL); + int err = block_self + (t->join_queue, thread, &t->admin_mutex, timeout_ptr); + if (err == ETIMEDOUT) + { + timed_out = 1; + if (SCM_UNBNDP (timeoutval)) + ex = scm_cons (scm_join_timeout_exception_key, SCM_EOL); + else + res = timeoutval; + break; + } if (t->exited) break; - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_mutex_unlock (&t->admin_mutex); SCM_TICK; - scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); + scm_i_scm_pthread_mutex_lock (&t->admin_mutex); } } - res = t->result; + + if (!timed_out) + { + res = t->result; + ex = t->exception; + } - scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_mutex_unlock (&t->admin_mutex); - return res; + if (!scm_is_false (ex)) + scm_ithrow (SCM_CAR (ex), SCM_CDR (ex), 1); + + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a thread.") +#define FUNC_NAME s_scm_thread_p +{ + return SCM_I_IS_THREAD(obj) ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME @@ -1034,16 +1152,36 @@ debugging. */ +#define MUTEX_STATE_UNLOCKED_NOT_ABANDONED 0 +#define MUTEX_STATE_UNLOCKED_ABANDONED 1 +#define MUTEX_STATE_LOCKED_OWNED 2 +#define MUTEX_STATE_LOCKED_UNOWNED 3 + +SCM_GLOBAL_SYMBOL (scm_mutex_state_not_owned, "not-owned"); +SCM_GLOBAL_SYMBOL (scm_mutex_state_abandoned, "abandoned"); +SCM_GLOBAL_SYMBOL (scm_mutex_state_not_abandoned, "not-abandoned"); + +/*** Fat condition variables */ + typedef struct { scm_i_pthread_mutex_t lock; - SCM owner; - int level; /* how much the owner owns us. - < 0 for non-recursive mutexes */ - SCM waiting; /* the threads waiting for this mutex. */ -} fat_mutex; + SCM waiting; /* the threads waiting for this condition. */ +} fat_cond; -#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) +#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) +#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) + +static int +fat_mutex_state (fat_mutex *m) +{ + if (m->owner == SCM_UNDEFINED) + return MUTEX_STATE_UNLOCKED_NOT_ABANDONED; + else if (scm_is_false (m->owner)) + return MUTEX_STATE_LOCKED_UNOWNED; + else if (scm_c_thread_exited_p (m->owner)) + return MUTEX_STATE_UNLOCKED_ABANDONED; + else return MUTEX_STATE_LOCKED_OWNED; +} static SCM fat_mutex_mark (SCM mx) @@ -1080,7 +1218,7 @@ m = scm_gc_malloc (sizeof (fat_mutex), "mutex"); scm_i_pthread_mutex_init (&m->lock, NULL); - m->owner = SCM_BOOL_F; + m->owner = SCM_UNDEFINED; m->level = recursive? 0 : -1; m->waiting = SCM_EOL; SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m); @@ -1106,55 +1244,150 @@ } #undef FUNC_NAME -static char * -fat_mutex_lock (SCM mutex) +static SCM +fat_mutex_lock (SCM mutex, SCM thread, scm_t_timespec *timeout, int *ret) { fat_mutex *m = SCM_MUTEX_DATA (mutex); - SCM thread = scm_current_thread (); - char *msg = NULL; + SCM err = SCM_EOL; + int state = 0, try_lock = 1; + + struct timeval current_time; scm_i_scm_pthread_mutex_lock (&m->lock); - if (scm_is_false (m->owner)) - m->owner = thread; - else if (scm_is_eq (m->owner, thread)) + state = fat_mutex_state (m); + while (try_lock) { - if (m->level >= 0) - m->level++; - else - msg = "mutex already locked by current thread"; - } - else - { - while (1) + try_lock = 0; + switch (state) { - block_self (m->waiting, mutex, &m->lock, NULL); + case MUTEX_STATE_LOCKED_OWNED: if (scm_is_eq (m->owner, thread)) - break; - scm_i_pthread_mutex_unlock (&m->lock); - SCM_TICK; - scm_i_scm_pthread_mutex_lock (&m->lock); + { + if (m->level >= 0) + m->level++; + else + { + SCM msg = scm_from_locale_string + ("mutex already locked by thread"); + err = scm_cons(scm_misc_error_key, msg); + } + *ret = 0; + break; + } + case MUTEX_STATE_LOCKED_UNOWNED: + while (1) + { + block_self (m->waiting, mutex, &m->lock, timeout); + state = fat_mutex_state (m); + if (state == MUTEX_STATE_UNLOCKED_ABANDONED || + state == MUTEX_STATE_UNLOCKED_NOT_ABANDONED) + { + try_lock = 1; + break; + } + if (timeout != NULL) + { + gettimeofday (¤t_time, NULL); + if (current_time.tv_sec > timeout->tv_sec || + (current_time.tv_sec == timeout->tv_sec && + current_time.tv_usec * 1000 > timeout->tv_nsec)) + { + *ret = 0; + break; + } + } + scm_i_pthread_mutex_unlock (&m->lock); + SCM_TICK; + scm_i_scm_pthread_mutex_lock (&m->lock); + } + break; + case MUTEX_STATE_UNLOCKED_ABANDONED: + err = scm_cons (scm_abandoned_mutex_exception_key, SCM_EOL); + case MUTEX_STATE_UNLOCKED_NOT_ABANDONED: + if (SCM_I_IS_THREAD (thread)) + { + scm_i_thread *t = SCM_I_THREAD_DATA (thread); + + /* The current thread can lock mutexes from within its cleanup + handler, but we can't let other threads specify a canceled + thread as the owner of a mutex because it may have passed the + cleanup stage where it abandones its held mutexes. */ + + scm_i_pthread_mutex_lock (&t->admin_mutex); + if (t != SCM_I_CURRENT_THREAD && (t->exited || t->canceled)) + err = scm_cons (scm_misc_error_key, SCM_EOL); + else if (scm_is_null (t->mutexes)) + t->mutexes = scm_list_1 (mutex); + else + t->mutexes = scm_cons (mutex, t->mutexes); + scm_i_pthread_mutex_unlock (&t->admin_mutex); + } + m->owner = thread; + *ret = 1; + break; } + if (!try_lock) + break; } scm_i_pthread_mutex_unlock (&m->lock); - return msg; + return err; } SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, - (SCM mx), -"Lock @var{mutex}. If the mutex is already locked, the calling thread " + (SCM m), +"Lock @var{m}. If the mutex is already locked, the calling thread " "blocks until the mutex becomes available. The function returns when " -"the calling thread owns the lock on @var{mutex}. Locking a mutex that " +"the calling thread owns the lock on @var{m}. Locking a mutex that " "a thread already owns will succeed right away and will not block the " "thread. That is, Guile's mutexes are @emph{recursive}. ") #define FUNC_NAME s_scm_lock_mutex { - char *msg; + return scm_lock_mutex_timed (m, SCM_BOOL_F, SCM_I_CURRENT_THREAD->handle); +} +#undef FUNC_NAME - SCM_VALIDATE_MUTEX (1, mx); - msg = fat_mutex_lock (mx); - if (msg) - scm_misc_error (NULL, msg, SCM_EOL); - return SCM_BOOL_T; +SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, + (SCM m, SCM timeout, SCM thread), +"Lock @var{m}. If the mutex is already locked, the calling thread " +"blocks until the mutex becomes available or until @var{timeout} elapses, if " +"it is specified. When the function returns, the calling thread, or " +"@var{thread}, if specified, will own the lock on @var{m}. If @var{thread} is " +"@code{#f}, the mutex's state (as reported by @var{mutex-state}) will be " +"@code{locked/unowned}; otherwise, the state will be @code{locked/owned}. If " +"@{m} was previously held by a thread that terminated before unlocking it, a " +"call to this function will change the owner of the mutex, but a " +"@code{abadoned-mutex-exception} will be thrown. Locking a mutex that a " +"thread already owns will succeed right away and will not block the " +"thread. That is, Guile's mutexes are @emph{recursive}. @var{lock-mutex} " +"returns @code{#t} if @var{m} was successfully locked, @code{#f} otherwise.") +#define FUNC_NAME s_scm_lock_mutex_timed +{ + SCM exception; + int ret = 0; + scm_t_timespec cwaittime, *waittime = NULL; + + SCM_VALIDATE_MUTEX (1, m); + + if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) + { + cwaittime = scm_to_timespec (timeout); + waittime = &cwaittime; + } + + if (SCM_UNBNDP (thread)) + thread = SCM_I_CURRENT_THREAD->handle; + else if (! SCM_I_IS_THREAD (thread) && ! scm_is_false (thread)) + SCM_MISC_ERROR ("thread must be a thread or false", SCM_EOL); + + exception = fat_mutex_lock (m, thread, waittime, &ret); + if (scm_is_pair (exception)) + { + SCM key = SCM_CAR (exception); + SCM scm_msg = SCM_CDR (exception); + char *msg = scm_msg == SCM_EOL ? NULL : scm_to_locale_string (scm_msg); + scm_error (key, NULL, msg, SCM_EOL, SCM_BOOL_F); + } + return ret ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME @@ -1175,7 +1408,7 @@ *resp = 1; scm_i_pthread_mutex_lock (&m->lock); - if (scm_is_false (m->owner)) + if (m->owner == SCM_UNDEFINED) m->owner = thread; else if (scm_is_eq (m->owner, thread)) { @@ -1208,46 +1441,109 @@ } #undef FUNC_NAME -static char * -fat_mutex_unlock (fat_mutex *m) +static void +fat_mutex_unlock (SCM mutex) { - char *msg = NULL; - + fat_mutex *m = SCM_MUTEX_DATA (mutex); scm_i_scm_pthread_mutex_lock (&m->lock); - if (!scm_is_eq (m->owner, scm_current_thread ())) + if (SCM_I_IS_THREAD (m->owner)) { - if (scm_is_false (m->owner)) - msg = "mutex not locked"; - else - msg = "mutex not locked by current thread"; + scm_i_thread *t = SCM_I_THREAD_DATA (m->owner); + scm_i_pthread_mutex_lock (&t->admin_mutex); + scm_delete_x (t->mutexes, mutex); + scm_i_pthread_mutex_unlock (&t->admin_mutex); } - else if (m->level > 0) + if (m->level > 0) m->level--; else - m->owner = unblock_from_queue (m->waiting); + { + unblock_from_queue (m->waiting); + m->owner = SCM_UNDEFINED; + } scm_i_pthread_mutex_unlock (&m->lock); - - return msg; } SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, - (SCM mx), -"Unlocks @var{mutex} if the calling thread owns the lock on " -"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current " -"thread results in undefined behaviour. Once a mutex has been unlocked, " -"one thread blocked on @var{mutex} is awakened and grabs the mutex " -"lock. Every call to @code{lock-mutex} by this thread must be matched " -"with a call to @code{unlock-mutex}. Only the last call to " -"@code{unlock-mutex} will actually unlock the mutex. ") + (SCM m), +"Unlocks @var{m}. Once a mutex has been unlocked, one thread blocked on " +"@var{m} is awakened and grabs the mutex lock. For recursive mutexes, every " +"call to @code{lock-mutex} for a particular owner must be matched with a call " +"to @code{unlock-mutex}. Only the last call to @code{unlock-mutex} will " +"actually unlock the mutex.") #define FUNC_NAME s_scm_unlock_mutex { - char *msg; + return scm_unlock_mutex_timed (m, SCM_UNDEFINED, SCM_UNDEFINED); +} +#undef FUNC_NAME + +static int fat_cond_timedwait(SCM, SCM, const scm_t_timespec *); + +SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0, + (SCM mx, SCM cond, SCM timeout), +"Unlocks @var{mx}. Once a mutex has been unlocked, one thread blocked on " +"@var{mx} is awakened and grabs the mutex lock. If a condition variable " +"@var{cond} is specified, the current thread will block on @var{cond} until " +"awoken by a call to @var{signal-condition-variable} or " +"@var{broadcast-condition-variable}. (This behavior is very similar to that " +"of @var{wait-condition-variable}, except that @var{mx} is not re-locked when " +"the thread is woken up.) If @var{timeout} is specified and elapses before " +"@var{cond} is signalled, @code{unlock-mutex} returns @code{#f}; otherwise it " +"returns @code{#t}. For recursive mutexes, every call to @code{lock-mutex} " +"for a particular owner must be matched with a call to @code{unlock-mutex}. " +"Only the last call to @code{unlock-mutex} will actually unlock the mutex.") +#define FUNC_NAME s_scm_unlock_mutex_timed +{ + SCM ret = SCM_BOOL_T; + SCM_VALIDATE_MUTEX (1, mx); - - msg = fat_mutex_unlock (SCM_MUTEX_DATA (mx)); - if (msg) - scm_misc_error (NULL, msg, SCM_EOL); - return SCM_BOOL_T; + if (! (SCM_UNBNDP (cond))) + { + SCM_VALIDATE_CONDVAR (2, cond); + scm_t_timespec cwaittime, *waittime = NULL; + + if (! (SCM_UNBNDP (timeout))) + { + cwaittime = scm_to_timespec (timeout); + waittime = &cwaittime; + } + if (! fat_cond_timedwait (cond, mx, waittime)) + ret = SCM_BOOL_F; + } + + fat_mutex_unlock (mx); + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_mutex_state, "mutex-state", 1, 0, 0, + (SCM mx), +"Return the current state of the mutex @var{mx}, which is defined as follows: " +"If @var{mx} is owned by a thread, its state is @code{locked/owned}, and that " +"thread will be returned by this function; if @var{mx} has been locked but " +"the owner is @code{#f}, the state is @code{locked/unowned}, and the symbol " +"@code{not-owned} will be returned; if @var{mx} was owned by a thread that " +"terminated before unlocking it, the symbol @code{abandoned} will be " +"returned; otherwise this function returns the symbol @code{not-abandoned}.") +#define FUNC_NAME s_scm_mutex_state +{ + SCM_VALIDATE_MUTEX (1, mx); + fat_mutex *fm = SCM_MUTEX_DATA (mx); + switch (fat_mutex_state (fm)) + { + case MUTEX_STATE_LOCKED_OWNED: return fm->owner; + case MUTEX_STATE_LOCKED_UNOWNED: return scm_mutex_state_not_owned; + case MUTEX_STATE_UNLOCKED_ABANDONED: return scm_mutex_state_abandoned; + default: return scm_mutex_state_not_abandoned; + } +} +#undef FUNC_NAME + +SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a mutex.") +#define FUNC_NAME s_scm_mutex_p +{ + return SCM_MUTEXP (obj) ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME @@ -1276,16 +1572,6 @@ #endif -/*** Fat condition variables */ - -typedef struct { - scm_i_pthread_mutex_t lock; - SCM waiting; /* the threads waiting for this condition. */ -} fat_cond; - -#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) -#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) - static SCM fat_cond_mark (SCM cv) { @@ -1334,30 +1620,29 @@ const scm_t_timespec *waittime) { scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM old_owner = SCM_UNDEFINED; + fat_cond *c = SCM_CONDVAR_DATA (cond); fat_mutex *m = SCM_MUTEX_DATA (mutex); - const char *msg; - int err = 0; + int err = 0, ret = 0; while (1) { + old_owner = m->owner; + scm_i_scm_pthread_mutex_lock (&c->lock); - msg = fat_mutex_unlock (m); + fat_mutex_unlock (mutex); + t->block_asyncs++; - if (msg == NULL) - { - err = block_self (c->waiting, cond, &c->lock, waittime); - scm_i_pthread_mutex_unlock (&c->lock); - fat_mutex_lock (mutex); - } - else - scm_i_pthread_mutex_unlock (&c->lock); + + err = block_self (c->waiting, cond, &c->lock, waittime); + + scm_i_pthread_mutex_unlock (&c->lock); + fat_mutex_lock (mutex, old_owner, NULL, &ret); + t->block_asyncs--; scm_async_click (); - if (msg) - scm_misc_error (NULL, msg, SCM_EOL); - scm_remember_upto_here_2 (cond, mutex); if (err == 0) @@ -1392,16 +1677,7 @@ if (!SCM_UNBNDP (t)) { - if (scm_is_pair (t)) - { - waittime.tv_sec = scm_to_ulong (SCM_CAR (t)); - waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000; - } - else - { - waittime.tv_sec = scm_to_ulong (t); - waittime.tv_nsec = 0; - } + waittime = scm_to_timespec (t); waitptr = &waittime; } @@ -1432,7 +1708,7 @@ fat_cond_broadcast (fat_cond *c) { scm_i_scm_pthread_mutex_lock (&c->lock); - while (scm_is_true (unblock_from_queue (c->waiting))) + while (unblock_from_queue (c->waiting) != SCM_UNDEFINED) ; scm_i_pthread_mutex_unlock (&c->lock); } @@ -1448,6 +1724,15 @@ } #undef FUNC_NAME +SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a condition variable.") +#define FUNC_NAME s_scm_condition_variable_p +{ + return SCM_CONDVARP(obj) ? SCM_BOOL_T : SCM_BOOL_F; +} +#undef FUNC_NAME + /*** Marking stacks */ /* XXX - what to do with this? Do we need to handle this for blocked @@ -1806,6 +2091,7 @@ scm_set_smob_free (scm_tc16_condvar, fat_cond_free); scm_i_default_dynamic_state = SCM_BOOL_F; + scm_i_pthread_setspecific (scm_i_thread_key, SCM_I_CURRENT_THREAD); guilify_self_2 (SCM_BOOL_F); threads_initialized_p = 1; Index: threads.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v retrieving revision 1.49 diff -a -u -r1.49 threads.h --- threads.h 20 Oct 2007 11:09:58 -0000 1.49 +++ threads.h 29 Oct 2007 13:15:34 -0000 @@ -3,7 +3,7 @@ #ifndef SCM_THREADS_H #define SCM_THREADS_H -/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 2007 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -52,7 +52,12 @@ SCM cleanup_handler; SCM join_queue; + + scm_i_pthread_mutex_t admin_mutex; + SCM mutexes; + SCM result; + SCM exception; int canceled; int exited; @@ -159,13 +164,19 @@ SCM_API SCM scm_set_thread_cleanup_x (SCM thread, SCM proc); SCM_API SCM scm_thread_cleanup (SCM thread); SCM_API SCM scm_join_thread (SCM t); +SCM_API SCM scm_join_thread_timed (SCM t, SCM timeout, SCM timeout_val); +SCM_API SCM scm_thread_p (SCM o); SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_recursive_mutex (void); SCM_API SCM scm_lock_mutex (SCM m); +SCM_API SCM scm_lock_mutex_timed (SCM m, SCM abstime, SCM thread); SCM_API void scm_dynwind_lock_mutex (SCM mutex); SCM_API SCM scm_try_mutex (SCM m); SCM_API SCM scm_unlock_mutex (SCM m); +SCM_API SCM scm_unlock_mutex_timed (SCM m, SCM cond, SCM abstime); +SCM_API SCM scm_mutex_state (SCM m); +SCM_API SCM scm_mutex_p (SCM o); SCM_API SCM scm_make_condition_variable (void); SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex); @@ -173,6 +184,7 @@ SCM abstime); SCM_API SCM scm_signal_condition_variable (SCM cond); SCM_API SCM scm_broadcast_condition_variable (SCM cond); +SCM_API SCM scm_condition_variable_p (SCM o); SCM_API SCM scm_current_thread (void); SCM_API SCM scm_all_threads (void);