From 4f04a30ccb5f4129c0720f6b10bbad3ef9244cb6 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Sun, 13 Apr 2008 19:51:23 -0400 Subject: [PATCH] latest set of SRFI-18 support changes to core threads --- doc/ref/api-scheduling.texi | 33 +++++++- libguile/threads.c | 162 ++++++++++++++++++++++------------------ libguile/threads.h | 5 +- test-suite/tests/threads.test | 46 ++++++++++++ 4 files changed, 168 insertions(+), 78 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index ec136fb..29eed5e 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -409,17 +409,21 @@ function is equivalent to calling `make-mutex' and specifying the @code{recursive} flag. @end deffn address@hidden {Scheme Procedure} lock-mutex mutex [timeout] address@hidden {Scheme Procedure} lock-mutex mutex [timeout [owner]] @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. address@hidden {C Function} scm_lock_mutex_timed (mutex, timeout, owner) +Lock @var{mutex}. If the mutex is already locked, 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. +When @var{owner} is given, it specifies an owner for @var{mutex} other +than the calling thread. @var{owner} may also be @code{#f}, +indicating that the mutex should be locked but left unowned. + For standard mutexes (@code{make-mutex}), and error is signalled if the thread has itself already locked @var{mutex}. @@ -471,6 +475,27 @@ returned by @code{current-time} or a pair as returned by returned. Otherwise the function returns @code{#t}. @end deffn address@hidden {Scheme Procedure} mutex-owner mutex address@hidden {C Function} scm_mutex_owner (mutex) +Return the current owner of @var{mutex}, in the form of a thread or address@hidden (indicating no owner). Note that a mutex may be unowned but +still locked. address@hidden deffn + address@hidden {Scheme Procedure} mutex-level mutex address@hidden {C Function} scm_mutex_level (mutex) +Return the current lock level of @var{mutex}. If @var{mutex} is +currently unlocked, this value will be 0; otherwise, it will be the +number of times @var{mutex} has been recursively locked by its current +owner. address@hidden deffn + address@hidden {Scheme Procedure} mutex-locked? mutex address@hidden {C Function} scm_mutex_locked_p (mutex) +Return @code{#t} if @var{mutex} is locked, regardless of ownership; +otherwise, return @code{#f}. address@hidden deffn + @deffn {Scheme Procedure} make-condition-variable @deffnx {C Function} scm_make_condition_variable () Return a new condition variable. diff --git a/libguile/threads.c b/libguile/threads.c index 68c5f79..938644c 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -511,9 +511,9 @@ guilify_self_2 (SCM parent) typedef struct { scm_i_pthread_mutex_t lock; SCM owner; - int level; /* how much the owner owns us. - < 0 for non-recursive mutexes */ + int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ + int recursive; /* allow recursive locking? */ int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */ int allow_external_unlock; /* is it an error to unlock a mutex that is not owned by the current thread? */ @@ -1154,8 +1154,9 @@ make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock) m = scm_gc_malloc (sizeof (fat_mutex), "mutex"); scm_i_pthread_mutex_init (&m->lock, NULL); m->owner = SCM_BOOL_F; - m->level = recursive? 0 : -1; + m->level = 0; + m->recursive = recursive; m->unchecked_unlock = unchecked_unlock; m->allow_external_unlock = external_unlock; @@ -1211,79 +1212,77 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error"); static SCM -fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) +fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) { fat_mutex *m = SCM_MUTEX_DATA (mutex); - SCM thread = scm_current_thread (); - scm_i_thread *t = SCM_I_THREAD_DATA (thread); - + SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner; 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; - scm_i_pthread_mutex_lock (&t->admin_mutex); - 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)) + + while (1) { - if (m->level >= 0) + if (m->level == 0) { + m->owner = new_owner; m->level++; - *ret = 1; - } - else - err = scm_cons (scm_misc_error_key, - scm_from_locale_string ("mutex already locked by " - "current thread")); - } - else - { - int first_iteration = 1; - while (1) - { - if (scm_is_eq (m->owner, thread) || scm_c_thread_exited_p (m->owner)) + + if (SCM_I_IS_THREAD (new_owner)) { + scm_i_thread *t = SCM_I_THREAD_DATA (new_owner); scm_i_pthread_mutex_lock (&t->admin_mutex); 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) + *ret = 1; + break; + } + else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner)) + { + m->owner = new_owner; + err = scm_cons (scm_abandoned_mutex_error_key, + scm_from_locale_string ("lock obtained on abandoned " + "mutex")); + *ret = 1; + break; + } + else if (scm_is_eq (m->owner, new_owner)) + { + if (m->recursive) + { + m->level++; + *ret = 1; + } + else { - if (timeout != NULL) + err = scm_cons (scm_misc_error_key, + scm_from_locale_string ("mutex already locked " + "by thread")); + *ret = 0; + } + break; + } + else + { + 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)) { - 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; - } + *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); + SCM_TICK; + scm_i_scm_pthread_mutex_lock (&m->lock); } + block_self (m->waiting, mutex, &m->lock, timeout); } scm_i_pthread_mutex_unlock (&m->lock); return err; @@ -1291,11 +1290,11 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) SCM scm_lock_mutex (SCM mx) { - return scm_lock_mutex_timed (mx, SCM_UNDEFINED); + return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED); } -SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0, - (SCM m, SCM timeout), +SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, + (SCM m, SCM timeout, SCM owner), "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 " @@ -1315,7 +1314,7 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 1, 0, waittime = &cwaittime; } - exception = fat_mutex_lock (m, waittime, &ret); + exception = fat_mutex_lock (m, waittime, owner, &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; @@ -1346,7 +1345,7 @@ SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, to_timespec (scm_from_int(0), &cwaittime); waittime = &cwaittime; - exception = fat_mutex_lock (mutex, waittime, &ret); + exception = fat_mutex_lock (mutex, waittime, SCM_UNDEFINED, &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; @@ -1373,15 +1372,19 @@ fat_mutex_unlock (SCM mutex, SCM cond, int err = 0, ret = 0; scm_i_scm_pthread_mutex_lock (&m->lock); - if (!scm_is_eq (m->owner, scm_current_thread ())) + + SCM owner = m->owner; + + if (!scm_is_eq (owner, scm_current_thread ())) { - if (scm_is_false (m->owner)) + if (m->level == 0) { if (!m->unchecked_unlock) { scm_i_pthread_mutex_unlock (&m->lock); scm_misc_error (NULL, "mutex not locked", SCM_EOL); } + owner = scm_current_thread (); } else if (!m->allow_external_unlock) { @@ -1392,8 +1395,6 @@ fat_mutex_unlock (SCM mutex, SCM cond, if (! (SCM_UNBNDP (cond))) { - int lock_ret = 0; - c = SCM_CONDVAR_DATA (cond); while (1) { @@ -1402,8 +1403,9 @@ fat_mutex_unlock (SCM mutex, SCM cond, scm_i_scm_pthread_mutex_lock (&c->lock); if (m->level > 0) m->level--; - else + if (m->level == 0) m->owner = unblock_from_queue (m->waiting); + scm_i_pthread_mutex_unlock (&m->lock); t->block_asyncs++; @@ -1430,7 +1432,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, if (brk) { if (relock) - fat_mutex_lock (mutex, NULL, &lock_ret); + scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); scm_i_pthread_mutex_unlock (&c->lock); break; } @@ -1449,8 +1451,9 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (m->level > 0) m->level--; - else + if (m->level == 0) m->owner = unblock_from_queue (m->waiting); + scm_i_pthread_mutex_unlock (&m->lock); ret = 1; } @@ -1501,22 +1504,27 @@ SCM_DEFINE (scm_mutex_p, "mutex?", 1, 0, 0, } #undef FUNC_NAME -#if 0 - SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0, (SCM mx), "Return the thread owning @var{mx}, or @code{#f}.") #define FUNC_NAME s_scm_mutex_owner { + SCM owner; + fat_mutex *m = NULL; + SCM_VALIDATE_MUTEX (1, mx); - return (SCM_MUTEX_DATA(mx))->owner; + m = SCM_MUTEX_DATA (mx); + scm_i_pthread_mutex_lock (&m->lock); + owner = m->owner; + scm_i_pthread_mutex_unlock (&m->lock); + + return owner; } #undef FUNC_NAME SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0, (SCM mx), - "Return the lock level of a recursive mutex, or -1\n" - "for a standard mutex.") + "Return the lock level of mutex @var{mx}.") #define FUNC_NAME s_scm_mutex_level { SCM_VALIDATE_MUTEX (1, mx); @@ -1524,7 +1532,15 @@ SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0, } #undef FUNC_NAME -#endif +SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, + (SCM mx), + "Returns @code{#t} if the mutex @var{mx} is locked.") +#define FUNC_NAME s_scm_mutex_locked_p +{ + SCM_VALIDATE_MUTEX (1, mx); + return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F; +} +#undef FUNC_NAME static SCM fat_cond_mark (SCM cv) diff --git a/libguile/threads.h b/libguile/threads.h index e1944a5..d10e0f8 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -170,12 +170,15 @@ SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_recursive_mutex (void); SCM_API SCM scm_make_mutex_with_flags (SCM flags); SCM_API SCM scm_lock_mutex (SCM m); -SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout); +SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); 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_mutex_locked_p (SCM m); +SCM_API SCM scm_mutex_owner (SCM m); +SCM_API SCM scm_mutex_level (SCM m); SCM_API SCM scm_make_condition_variable (void); SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex); diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 62ee0cd..9cd062d 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -279,6 +279,52 @@ (not (thread-cleanup (current-thread))))) ;; + ;; mutex ownership + ;; + + (with-test-prefix "mutex-ownership" + (pass-if "mutex ownership for locked mutex" + (let ((m (make-mutex))) + (lock-mutex m) + (eq? (mutex-owner m) (current-thread)))) + + (pass-if "mutex ownership for unlocked mutex" + (let ((m (make-mutex))) + (not (mutex-owner m)))) + + (pass-if "locking mutex on behalf of other thread" + (let* ((m (make-mutex)) + (t (begin-thread 'foo))) + (lock-mutex m #f t) + (eq? (mutex-owner m) t))) + + (pass-if "locking mutex with no owner" + (let ((m (make-mutex))) + (lock-mutex m #f #f) + (not (mutex-owner m))))) + + ;; + ;; mutex lock levels + ;; + + (with-test-prefix "mutex-lock-levels" + + (pass-if "unlocked level is 0" + (let ((m (make-mutex))) + (and (not (mutex-locked? m)) (eqv? (mutex-level m) 0)))) + + (pass-if "non-recursive lock level is 1" + (let ((m (make-mutex))) + (lock-mutex m) + (and (mutex-locked? m) (eqv? (mutex-level m) 1)))) + + (pass-if "recursive lock level is >1" + (let ((m (make-mutex 'recursive))) + (lock-mutex m) + (lock-mutex m) + (and (mutex-locked? m) (eqv? (mutex-level m) 2))))) + + ;; ;; mutex behavior ;; -- 1.5.4.3