>
> Works for me. I'll try to have something to you this weekend.
>
Okay, find attached a patch against HEAD containing the aforementioned
changes to the core for supporting SRFI-18. I'm still looping my test
code, but I thought I should get something out to you guys this
evening. In addition to the code changes, the patch includes relevant
Changelog, doc, and threads.test updates. Let me know what you think.
Regards,
Julian
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 <[EMAIL PROTECTED]>
+
+ * 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 <[EMAIL PROTECTED]>
* 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
[EMAIL PROTECTED] {Scheme Procedure} thread? obj
[EMAIL PROTECTED] {C Function} scm_thread_p (obj)
+Return @code{#t} iff @var{obj} is a thread; otherwise, return
[EMAIL PROTECTED]
[EMAIL PROTECTED] deffn
+
@c begin (texi-doc-string "guile" "join-thread")
[EMAIL PROTECTED] {Scheme Procedure} join-thread thread
[EMAIL PROTECTED] {Scheme Procedure} join-thread thread [timeout]
@deffnx {C Function} scm_join_thread (thread)
[EMAIL PROTECTED] {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
[EMAIL PROTECTED] have an exit value of @code{#f}.
[EMAIL PROTECTED] have an exit value of @code{#f}. When
[EMAIL PROTECTED] is given, it specifies a point in time where the waiting
+should be aborted. It can be either an integer as returned by
[EMAIL PROTECTED] 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
[EMAIL PROTECTED] {Scheme Procedure} mutex? obj
[EMAIL PROTECTED] {C Function} scm_mutex_p (obj)
+Return @code{#t} iff @var{obj} is a mutex; otherwise, return
[EMAIL PROTECTED]
[EMAIL PROTECTED] 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
[EMAIL PROTECTED] {Scheme Procedure} lock-mutex mutex
[EMAIL PROTECTED] {Scheme Procedure} lock-mutex mutex [timeout]
@deffnx {C Function} scm_lock_mutex (mutex)
[EMAIL PROTECTED] {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
[EMAIL PROTECTED] 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
[EMAIL PROTECTED] {Scheme Procedure} unlock-mutex mutex
[EMAIL PROTECTED] {Scheme Procedure} unlock-mutex mutex [condvar [timeout]]
@deffnx {C Function} scm_unlock_mutex (mutex)
[EMAIL PROTECTED] {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
[EMAIL PROTECTED] (This behavior is very similar to that of
[EMAIL PROTECTED], 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
[EMAIL PROTECTED] 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
[EMAIL PROTECTED] {Scheme Procedure} condition-variable? obj
[EMAIL PROTECTED] {C Function} scm_condition_variable_p (obj)
+Return @code{#t} iff @var{obj} is a condition variable; otherwise,
+return @code{#f}.
[EMAIL PROTECTED] 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 <[EMAIL PROTECTED]>
+
+ * 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 <[EMAIL PROTECTED]>
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)))))
