Index: doc/ref/ChangeLog =================================================================== RCS file: /sources/guile/guile/guile-core/doc/ref/ChangeLog,v retrieving revision 1.357 diff -a -u -r1.357 ChangeLog --- doc/ref/ChangeLog 1 Feb 2008 21:02:15 -0000 1.357 +++ doc/ref/ChangeLog 11 Feb 2008 02:36:49 -0000 @@ -1,3 +1,11 @@ +2008-02-10 Julian Graham + + * api-scheduling.texi (Threads): Add documentation for new + functions "scm_thread_p" and new "scm_join_thread_timed". + (Mutexes and Condition Variables): Add documentation for new + functions "scm_mutex_p", "scm_lock_mutex_timed", + "scm_unlock_mutex_timed", and "scm_condition_variable_p". + 2008-02-01 Neil Jerram * api-scheduling.texi (Threads): Add "C Function scm_join_thread" Index: doc/ref/api-scheduling.texi =================================================================== RCS file: /sources/guile/guile/guile-core/doc/ref/api-scheduling.texi,v retrieving revision 1.19 diff -a -u -r1.19 api-scheduling.texi --- doc/ref/api-scheduling.texi 1 Feb 2008 21:02:15 -0000 1.19 +++ doc/ref/api-scheduling.texi 11 Feb 2008 02:36:50 -0000 @@ -267,12 +267,23 @@ @emph{exit value} of the thread and the thread is terminated. @end deftypefn address@hidden {Scheme Procedure} thread? obj address@hidden {C Function} scm_thread_p (obj) +Return @code{#t} iff @var{obj} is a thread; otherwise, return address@hidden address@hidden deffn + @c begin (texi-doc-string "guile" "join-thread") address@hidden {Scheme Procedure} join-thread thread address@hidden {Scheme Procedure} join-thread thread [timeout] @deffnx {C Function} scm_join_thread (thread) address@hidden {C Function} scm_join_thread_timed (thread, timeout) Wait for @var{thread} to terminate and return its exit value. Threads that have not been created with @code{call-with-new-thread} or address@hidden have an exit value of @code{#f}. address@hidden have an exit value of @code{#f}. When address@hidden is given, it specifies a point in time where the waiting +should be aborted. It can be either an integer as returned by address@hidden or a pair as returned by @code{gettimeofday}. +When the waiting is aborted, @code{#f} is returned. @end deffn @deffn {Scheme Procedure} thread-exited? thread @@ -368,16 +379,28 @@ Return a new standard mutex. It is initially unlocked. @end deffn address@hidden {Scheme Procedure} mutex? obj address@hidden {C Function} scm_mutex_p (obj) +Return @code{#t} iff @var{obj} is a mutex; otherwise, return address@hidden address@hidden deffn + @deffn {Scheme Procedure} make-recursive-mutex @deffnx {C Function} scm_make_recursive_mutex () Create a new recursive mutex. It is initialloy unlocked. @end deffn address@hidden {Scheme Procedure} lock-mutex mutex address@hidden {Scheme Procedure} lock-mutex mutex [timeout] @deffnx {C Function} scm_lock_mutex (mutex) address@hidden {C Function} scm_lock_mutex_timed (mutex, timeout) Lock @var{mutex}. If the mutex is already locked by another thread then block and return only when @var{mutex} has been acquired. +When @var{timeout} is given, it specifies a point in time where the +waiting should be aborted. It can be either an integer as returned +by @code{current-time} or a pair as returned by @code{gettimeofday}. +When the waiting is aborted, @code{#f} is returned. + For standard mutexes (@code{make-mutex}), and error is signalled if the thread has itself already locked @var{mutex}. @@ -386,6 +409,10 @@ call increments the lock count. An additional @code{unlock-mutex} will be required to finally release. +If @var{mutex} was locked by a thread that exited before unlocking it, +the next attempt to lock @var{mutex} will succeed, but address@hidden will be signalled. + When a system async (@pxref{System asyncs}) is activated for a thread blocked in @code{lock-mutex}, the wait is interrupted and the async is executed. When the async returns, the wait resumes. @@ -404,10 +431,23 @@ the return is @code{#f}. @end deffn address@hidden {Scheme Procedure} unlock-mutex mutex address@hidden {Scheme Procedure} unlock-mutex mutex [condvar [timeout]] @deffnx {C Function} scm_unlock_mutex (mutex) address@hidden {C Function} scm_unlock_mutex_timed (mutex, condvar, timeout) Unlock @var{mutex}. An error is signalled if @var{mutex} is not locked by the calling thread. + +If @var{condvar} is given, it specifies a condition variable upon +which the calling thread will wait to be signalled before unlocking address@hidden (This behavior is very similar to that of address@hidden, except that the mutex is left in an +unlocked state when the function returns.) + +When @var{timeout} is also given, it specifies a point in time where +the waiting should be aborted. It can be either an integer as +returned by @code{current-time} or a pair as returned by address@hidden When the waiting is aborted, @code{#f} is +returned. @end deffn @deffn {Scheme Procedure} make-condition-variable @@ -415,6 +455,12 @@ Return a new condition variable. @end deffn address@hidden {Scheme Procedure} condition-variable? obj address@hidden {C Function} scm_condition_variable_p (obj) +Return @code{#t} iff @var{obj} is a condition variable; otherwise, +return @code{#f}. address@hidden deffn + @deffn {Scheme Procedure} wait-condition-variable condvar mutex [time] @deffnx {C Function} scm_wait_condition_variable (condvar, mutex, time) Wait until @var{condvar} has been signalled. While waiting, Index: libguile/ChangeLog =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/ChangeLog,v retrieving revision 1.2430 diff -a -u -r1.2430 ChangeLog --- libguile/ChangeLog 7 Feb 2008 09:54:46 -0000 1.2430 +++ libguile/ChangeLog 11 Feb 2008 02:37:10 -0000 @@ -1,3 +1,24 @@ +2008-02-10 Julian Graham + + * threads.c (scm_to_timespec, scm_join_thread_timed, scm_thread_p, + scm_lock_mutex_timed, scm_unlock_mutex_timed, scm_mutex_p, + scm_condition_variable_p): New functions. + (thread_mark): Updated to mark new struct field `mutexes'. + (do_thread_exit): Notify threads waiting on mutexes locked by exiting + thread. + (scm_join_thread, scm_mutex_lock): Reimplement in terms of their new, + timed counterparts. + (scm_abandoned_mutex_error_key): New symbol. + (fat_mutex_lock): Reimplement to support timeouts and abandonment. + (fat_mutex_trylock, scm_try_mutex): Remove fat_mutex_trylock and + reimplement scm_try_mutex as a lock attempt with a timeout of zero. + (fat_mutex_unlock): Allow unlocking from other threads. + (scm_timed_wait_condition_variable): Updated to use scm_to_timespec. + * threads.h (scm_i_thread)[mutexes]: New field. + (scm_join_thread_timed, scm_thread_p, scm_lock_mutex_timed, + scm_unlock_mutex_timed, scm_mutex_p, scm_condition_variable_p): + Prototypes for new functions. + 2008-02-07 Ludovic Courtès Fix bug #21378. Index: libguile/threads.c =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v retrieving revision 1.91 diff -a -u -r1.91 threads.c --- libguile/threads.c 7 Feb 2008 01:24:31 -0000 1.91 +++ libguile/threads.c 11 Feb 2008 02:37:16 -0000 @@ -49,6 +49,7 @@ #include "libguile/gc.h" #include "libguile/init.h" #include "libguile/scmsigs.h" +#include "libguile/strings.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. @@ -134,6 +155,7 @@ scm_gc_mark (t->result); scm_gc_mark (t->cleanup_handler); scm_gc_mark (t->join_queue); + scm_gc_mark (t->mutexes); scm_gc_mark (t->dynwinds); scm_gc_mark (t->active_asyncs); scm_gc_mark (t->continuation_root); @@ -418,6 +440,7 @@ t->handle = SCM_BOOL_F; t->result = 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; @@ -478,6 +501,26 @@ t->block_asyncs = 0; } + +/*** Fat mutexes */ + +/* We implement our own mutex type since we want them to be 'fair', we + want to do fancy things while waiting for them (like running + asyncs) and we might want to add things that are nice for + debugging. +*/ + +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 * @@ -503,6 +546,18 @@ while (scm_is_true (unblock_from_queue (t->join_queue))) ; + 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; @@ -989,14 +1044,22 @@ } #undef FUNC_NAME -SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, - (SCM thread), +SCM scm_join_thread (SCM thread) +{ + return scm_join_thread_timed (thread, SCM_BOOL_F); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 1, 0, + (SCM thread, SCM timeout), "Suspend execution of the calling thread until the target @var{thread} " "terminates, unless the target @var{thread} has already terminated. ") -#define FUNC_NAME s_scm_join_thread +#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; SCM_VALIDATE_THREAD (1, thread); if (scm_is_eq (scm_current_thread (), thread)) @@ -1005,11 +1068,23 @@ 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, &t->admin_mutex, NULL); + int err = block_self (t->join_queue, thread, &t->admin_mutex, + timeout_ptr); + if (err == ETIMEDOUT) + { + timed_out = 1; + break; + } if (t->exited) break; scm_i_pthread_mutex_unlock (&t->admin_mutex); @@ -1017,7 +1092,11 @@ scm_i_scm_pthread_mutex_lock (&t->admin_mutex); } } - res = t->result; + + if (!timed_out) + { + res = t->result; + } scm_i_pthread_mutex_unlock (&t->admin_mutex); @@ -1025,26 +1104,14 @@ } #undef FUNC_NAME - - -/*** Fat mutexes */ - -/* We implement our own mutex type since we want them to be 'fair', we - want to do fancy things while waiting for them (like running - asyncs) and we might want to add things that are nice for - debugging. -*/ - -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)) +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 static SCM fat_mutex_mark (SCM mx) @@ -1107,55 +1174,121 @@ } #undef FUNC_NAME -static char * -fat_mutex_lock (SCM mutex) +SCM_SYMBOL (scm_abandoned_mutex_error_key, "locking-abandoned-mutex-error"); + +static SCM +fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) { fat_mutex *m = SCM_MUTEX_DATA (mutex); + SCM thread = scm_current_thread (); - char *msg = NULL; + scm_i_thread *t = SCM_I_THREAD_DATA (thread); + + SCM err = SCM_BOOL_F; + + struct timeval current_time; scm_i_scm_pthread_mutex_lock (&m->lock); if (scm_is_false (m->owner)) - m->owner = thread; + { + m->owner = thread; + scm_i_pthread_mutex_lock (&t->admin_mutex); + 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); + *ret = 1; + } else if (scm_is_eq (m->owner, thread)) { if (m->level >= 0) m->level++; else - msg = "mutex already locked by current thread"; + err = scm_cons (scm_misc_error_key, + scm_from_locale_string ("mutex already locked by " + "current thread")); + *ret = 0; } else { + int first_iteration = 1; while (1) { - block_self (m->waiting, mutex, &m->lock, NULL); - 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 (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner)) + { + scm_i_pthread_mutex_lock (&t->admin_mutex); + 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); + *ret = 1; + if (scm_c_thread_exited_p (m->owner)) + { + m->owner = thread; + err = scm_cons (scm_abandoned_mutex_error_key, + scm_from_locale_string ("lock obtained on " + "abandoned mutex")); + } + break; + } + else if (!first_iteration) + { + 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); + } + else + first_iteration = 0; + block_self (m->waiting, mutex, &m->lock, timeout); } } scm_i_pthread_mutex_unlock (&m->lock); - return msg; + return err; } -SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, - (SCM mx), +SCM scm_lock_mutex (SCM mx) +{ + return scm_lock_mutex_timed (mx, SCM_BOOL_F); +} + +SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0, + (SCM m, SCM timeout), "Lock @var{mutex}. 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 " "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 +#define FUNC_NAME s_scm_lock_mutex_timed { - char *msg; + SCM exception; + int ret = 0; + scm_t_timespec cwaittime, *waittime = NULL; - SCM_VALIDATE_MUTEX (1, mx); - msg = fat_mutex_lock (mx); - if (msg) - scm_misc_error (NULL, msg, SCM_EOL); - return SCM_BOOL_T; + SCM_VALIDATE_MUTEX (1, m); + + if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) + { + cwaittime = scm_to_timespec (timeout); + waittime = &cwaittime; + } + + exception = fat_mutex_lock (m, waittime, &ret); + if (!scm_is_false (exception)) + scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); + return ret ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME @@ -1168,71 +1301,56 @@ SCM_F_WIND_EXPLICITLY); } -static char * -fat_mutex_trylock (fat_mutex *m, int *resp) -{ - char *msg = NULL; - SCM thread = scm_current_thread (); - - *resp = 1; - scm_i_pthread_mutex_lock (&m->lock); - if (scm_is_false (m->owner)) - m->owner = thread; - else if (scm_is_eq (m->owner, thread)) - { - if (m->level >= 0) - m->level++; - else - msg = "mutex already locked by current thread"; - } - else - *resp = 0; - scm_i_pthread_mutex_unlock (&m->lock); - return msg; -} - SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, (SCM mutex), "Try to lock @var{mutex}. If the mutex is already locked by someone " "else, return @code{#f}. Else lock the mutex and return @code{#t}. ") #define FUNC_NAME s_scm_try_mutex { - char *msg; - int res; + SCM exception; + int ret = 0; + scm_t_timespec cwaittime, *waittime = NULL; SCM_VALIDATE_MUTEX (1, mutex); + + cwaittime = scm_to_timespec (scm_from_int(0)); + waittime = &cwaittime; - msg = fat_mutex_trylock (SCM_MUTEX_DATA (mutex), &res); - if (msg) - scm_misc_error (NULL, msg, SCM_EOL); - return scm_from_bool (res); + exception = fat_mutex_lock (mutex, waittime, &ret); + if (!scm_is_false (exception)) + scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); + return ret ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME -static char * -fat_mutex_unlock (fat_mutex *m) +static void +fat_mutex_unlock (SCM mx) { - char *msg = NULL; - + fat_mutex *m = SCM_MUTEX_DATA (mx); scm_i_scm_pthread_mutex_lock (&m->lock); - if (!scm_is_eq (m->owner, scm_current_thread ())) + if (m->level > 0) + m->level--; + else { - 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); + m->owner = unblock_from_queue (m->waiting); + scm_i_pthread_mutex_lock (&t->admin_mutex); + scm_delete_x (t->mutexes, mx); + scm_i_pthread_mutex_unlock (&t->admin_mutex); } - else if (m->level > 0) - m->level--; - else - m->owner = unblock_from_queue (m->waiting); scm_i_pthread_mutex_unlock (&m->lock); +} + +static int +fat_cond_timedwait (SCM, SCM, const scm_t_timespec *); - return msg; +SCM scm_unlock_mutex (SCM mx) +{ + return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED); } -SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, - (SCM mx), +SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0, + (SCM mx, SCM cond, SCM timeout), "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, " @@ -1240,18 +1358,39 @@ "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. ") -#define FUNC_NAME s_scm_unlock_mutex +#define FUNC_NAME s_scm_unlock_mutex_timed { - char *msg; + 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_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 + #if 0 SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0, @@ -1335,30 +1474,25 @@ const scm_t_timespec *waittime) { scm_i_thread *t = SCM_I_CURRENT_THREAD; + 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) { 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, 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) @@ -1393,16 +1527,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; } @@ -1449,6 +1574,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 Index: libguile/threads.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v retrieving revision 1.50 diff -a -u -r1.50 threads.h --- libguile/threads.h 7 Feb 2008 01:24:31 -0000 1.50 +++ libguile/threads.h 11 Feb 2008 02:37:17 -0000 @@ -54,6 +54,7 @@ SCM join_queue; scm_i_pthread_mutex_t admin_mutex; + SCM mutexes; SCM result; int canceled; @@ -162,13 +163,18 @@ 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_API SCM scm_thread_p (SCM t); 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 timeout); 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 timeout); +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); @@ -176,6 +182,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); Index: test-suite/tests/threads.test =================================================================== RCS file: /sources/guile/guile/guile-core/test-suite/tests/threads.test,v retrieving revision 1.7 diff -a -u -r1.7 threads.test --- test-suite/tests/threads.test 20 Oct 2007 11:09:58 -0000 1.7 +++ test-suite/tests/threads.test 11 Feb 2008 02:37:17 -0000 @@ -138,6 +138,85 @@ (equal? result '(10 8 6 4 2 0))))) ;; + ;; timed mutex locking + ;; + + (with-test-prefix "lock-mutex" + + (pass-if "timed locking fails if timeout exceeded" + (let ((m (make-mutex))) + (lock-mutex m) + (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) + (not (join-thread t))))) + + (pass-if "timed locking succeeds if mutex unlocked within timeout" + (let* ((m (make-mutex)) + (c (make-condition-variable)) + (cm (make-mutex))) + (lock-mutex cm) + (let ((t (begin-thread (begin (lock-mutex cm) + (signal-condition-variable c) + (unlock-mutex cm) + (lock-mutex m + (+ (current-time) 2)))))) + (lock-mutex m) + (wait-condition-variable c cm) + (unlock-mutex cm) + (sleep 1) + (unlock-mutex m) + (join-thread t))))) + + ;; + ;; timed mutex unlocking + ;; + + (with-test-prefix "unlock-mutex" + + (pass-if "timed unlocking returns #f if timeout exceeded" + (let ((m (make-mutex)) + (c (make-condition-variable))) + (lock-mutex m) + (not (unlock-mutex m c 0)))) + + (pass-if "timed unlocking returns #t if condition signaled" + (let ((m1 (make-mutex)) + (m2 (make-mutex)) + (c1 (make-condition-variable)) + (c2 (make-condition-variable))) + (lock-mutex m1) + (let ((t (begin-thread (begin (lock-mutex m1) + (signal-condition-variable c1) + (lock-mutex m2) + (unlock-mutex m1) + (unlock-mutex m2 + c2 + (+ (current-time) + 1)))))) + (wait-condition-variable c1 m1) + (unlock-mutex m1) + (lock-mutex m2) + (signal-condition-variable c2) + (unlock-mutex m2) + (join-thread t))))) + + ;; + ;; timed joining + ;; + + (with-test-prefix "join-thread" + + (pass-if "timed joining fails if timeout exceeded" + (let* ((m (make-mutex)) + (c (make-condition-variable)) + (t (begin-thread (begin (lock-mutex m) + (wait-condition-variable c m))))) + (not (join-thread t (+ (current-time) 1))))) + + (pass-if "timed joining succeeds if thread exits within timeout" + (let ((t (begin-thread (begin (sleep 1) #t)))) + (join-thread t (+ (current-time) 2))))) + + ;; ;; thread cancellation ;; @@ -185,4 +264,20 @@ (eq? (join-thread t) 'bar)))) (pass-if "initial handler is false" - (not (thread-cleanup (current-thread))))))) + (not (thread-cleanup (current-thread))))) + + ;; + ;; mutex behavior + ;; + + (with-test-prefix "mutex-behavior" + + (pass-if "locking abandoned mutex throws exception" + (let* ((m (make-mutex)) + (t (begin-thread (lock-mutex m))) + (success #f)) + (join-thread t) + (catch 'locking-abandoned-mutex-error + (lambda () (lock-mutex m)) + (lambda key (set! success #t))) + success)))))