diff --git a/src/c/threads/mutex.d b/src/c/threads/mutex.d index c1c9f1e..a9296e6 100644 --- a/src/c/threads/mutex.d +++ b/src/c/threads/mutex.d @@ -4,6 +4,7 @@ */ /* Copyright (c) 2003, Juan Jose Garcia Ripoll. + Copyright (c) 2012, Matthew Mondor. ECL is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -29,82 +30,238 @@ * LOCKS or MUTEX */ + static void FEerror_not_a_lock(cl_object lock) { + FEwrong_type_argument(@'mp::lock', lock); } +cl_object +mp_recursive_lock_p(cl_object lock) +{ + cl_env_ptr env = ecl_process_env(); + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, lock->lock.recursive? Ct : Cnil); +} + +cl_object +mp_lock_name(cl_object lock) +{ + cl_env_ptr env = ecl_process_env(); + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, lock->lock.name); +} + + +/* + * New POSIX implementation. To debug race conditions, let's leave no chances + * in the implementation to cause any. Let's use the POSIX implementation as + * directly as possible, and deprecate the race-prone counter/owner API. + */ +#ifndef ECL_WINDOWS_THREADS + + +static int initialized = 0; + +static pthread_mutexattr_t mutexattr_normal; +static pthread_mutexattr_t mutexattr_recursive; + + static void -FEerror_not_a_recursive_lock(cl_object lock) +lock_init(void) { - FEerror("Attempted to recursively lock ~S which is already owned by ~S", - 2, lock, lock->lock.holder); + + pthread_mutexattr_init(&mutexattr_normal); + pthread_mutexattr_settype(&mutexattr_normal, + PTHREAD_MUTEX_ERRORCHECK); + + pthread_mutexattr_init(&mutexattr_recursive); + pthread_mutexattr_settype(&mutexattr_recursive, + PTHREAD_MUTEX_RECURSIVE); + + initialized = 1; } + static void -FEerror_not_owned(cl_object lock) +FEunknown_lock_error(cl_object lock, cl_object error) { - FEerror("Attempted to give up lock ~S that is not owned by process ~S", - 2, lock, mp_current_process()); + + FEerror("Error ~A when operating on lock ~A.", 2, error, lock); } static void -FEunknown_lock_error(cl_object lock) +FEerror_deprecated_lock_api(cl_object function, cl_object lock) { -#ifdef ECL_WINDOWS_THREADS - FEwin32_error("When acting on lock ~A, got an unexpected error.", 1, lock); -#else - FEerror("When acting on lock ~A, got an unexpected error.", 1, lock); -#endif + + FEerror("Called deprecated function ~A on lock ~A.", + 2, function, lock); } + cl_object ecl_make_lock(cl_object name, bool recursive) { cl_env_ptr the_env = ecl_process_env(); cl_object output = ecl_alloc_object(t_lock); ecl_disable_interrupts_env(the_env); + + if (!initialized) + lock_init(); + + pthread_mutex_init(&output->lock.mutex, + (recursive ? &mutexattr_recursive : &mutexattr_normal)); output->lock.name = name; -#ifdef ECL_WINDOWS_THREADS - output->lock.mutex = CreateMutex(NULL, FALSE, NULL); -#else - { - pthread_mutexattr_t mutexattr_recursive[1]; - pthread_mutexattr_init(mutexattr_recursive); - pthread_mutexattr_settype(mutexattr_recursive, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(&output->lock.mutex, mutexattr_recursive); - } -#endif output->lock.holder = Cnil; output->lock.counter = 0; output->lock.recursive = recursive; + ecl_set_finalizer_unprotected(output, Ct); ecl_enable_interrupts_env(the_env); return output; } -@(defun mp::make-lock (&key name ((:recursive recursive) Ct)) -@ - @(return ecl_make_lock(name, !Null(recursive))) -@) cl_object -mp_recursive_lock_p(cl_object lock) +mp_lock_holder(cl_object lock) { - cl_env_ptr env = ecl_process_env(); + if (type_of(lock) != t_lock) FEerror_not_a_lock(lock); - ecl_return1(env, lock->lock.recursive? Ct : Cnil); + FEerror_deprecated_lock_api( + ecl_cstring_to_base_string_or_nil("MP:LOCK-HOLDER"), + lock); } cl_object -mp_lock_name(cl_object lock) +mp_lock_mine_p(cl_object lock) +{ + + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + FEerror_deprecated_lock_api( + ecl_cstring_to_base_string_or_nil("MP:LOCK-MINE-P"), + lock); +} + +cl_object +mp_lock_count(cl_object lock) +{ + + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + FEerror_deprecated_lock_api( + ecl_cstring_to_base_string_or_nil("MP:LOCK-COUNT"), + lock); +} + +cl_object +mp_lock_count_mine(cl_object lock) { + + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + FEerror_deprecated_lock_api( + ecl_cstring_to_base_string_or_nil("MP:LOCK-COUNT-MINE"), + lock); +} + + +/* Now let's deal as directly as possible with mutexes. */ + +cl_object +mp_giveup_lock(cl_object lock) +{ + int rc; cl_env_ptr env = ecl_process_env(); + if (type_of(lock) != t_lock) FEerror_not_a_lock(lock); - ecl_return1(env, lock->lock.name); + if ((rc = pthread_mutex_unlock(&lock->lock.mutex)) != 0) + FEunknown_lock_error(lock, ecl_make_int(rc)); + + ecl_return1(env, Ct); +} + +cl_object +mp_get_lock_nowait(cl_object lock) +{ + int rc; + cl_env_ptr env = ecl_process_env(); + + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + if ((rc = pthread_mutex_trylock(&lock->lock.mutex)) != 0) + FEunknown_lock_error(lock, ecl_make_int(rc)); + + ecl_return1(env, lock); +} + +cl_object +mp_get_lock_wait(cl_object lock) +{ + int rc; + cl_env_ptr env = ecl_process_env(); + + if (type_of(lock) != t_lock) + FEerror_not_a_lock(lock); + if ((rc = pthread_mutex_lock(&lock->lock.mutex)) != 0) + FEunknown_lock_error(lock, ecl_make_int(rc)); + + ecl_return1(env, lock); +} + + +#endif /* !ECL_WINDOWS_THREADS */ + + +/* + * Old Windows implementation left as-is for now, but isolated separately. + */ +#ifdef ECL_WINDOWS_THREADS + + +static void +FEerror_not_a_recursive_lock(cl_object lock) +{ + FEerror("Attempted to recursively lock ~S which is already owned by ~S", + 2, lock, lock->lock.holder); +} + +static void +FEerror_not_owned(cl_object lock) +{ + FEerror("Attempted to give up lock ~S that is not owned by process ~S", + 2, lock, mp_current_process()); +} + +static void +FEunknown_lock_error(cl_object lock) +{ + FEwin32_error("When acting on lock ~A, got an unexpected error.", + 1, lock); +} + +cl_object +ecl_make_lock(cl_object name, bool recursive) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_object output = ecl_alloc_object(t_lock); + + ecl_disable_interrupts_env(the_env); + output->lock.name = name; + output->lock.mutex = CreateMutex(NULL, FALSE, NULL); + output->lock.holder = Cnil; + output->lock.counter = 0; + output->lock.recursive = recursive; + ecl_set_finalizer_unprotected(output, Ct); + ecl_enable_interrupts_env(the_env); + + return output; } cl_object @@ -158,12 +315,8 @@ mp_giveup_lock(cl_object lock) FEerror_not_owned(lock); if (--lock->lock.counter == 0) { lock->lock.holder = Cnil; -#ifdef ECL_WINDOWS_THREADS if (ReleaseMutex(lock->lock.mutex) == 0) FEunknown_lock_error(lock); -#else - pthread_mutex_unlock(&lock->lock.mutex); -#endif } ecl_return1(env, Ct); } @@ -186,7 +339,6 @@ mp_get_lock_nowait(cl_object lock) * interrupts. If an interupt happens right after we locked the mutex * but before we set count and owner, we are in trouble, since the * mutex might be locked. */ -#ifdef ECL_WINDOWS_THREADS switch (WaitForSingleObject(lock->lock.mutex, 0)) { case WAIT_OBJECT_0: lock->lock.counter++; @@ -199,18 +351,6 @@ mp_get_lock_nowait(cl_object lock) FEunknown_lock_error(lock); ecl_return1(env, Cnil); } -#else - rc = pthread_mutex_trylock(&lock->lock.mutex); - if (rc == 0) { - lock->lock.counter++; - lock->lock.holder = own_process; - ecl_return1(env, lock); - } else { - if (rc != EBUSY) - FEunknown_lock_error(lock); - ecl_return1(env, Cnil); - } -#endif } cl_object @@ -231,7 +371,6 @@ mp_get_lock_wait(cl_object lock) * interrupts. If an interupt happens right after we locked the mutex * but before we set count and owner, we are in trouble, since the * mutex might be locked. */ -#ifdef ECL_WINDOWS_THREADS switch (WaitForSingleObject(lock->lock.mutex, INFINITE)) { case WAIT_OBJECT_0: lock->lock.counter++; @@ -244,19 +383,17 @@ mp_get_lock_wait(cl_object lock) FEunknown_lock_error(lock); ecl_return1(env, Cnil); } -#else - rc = pthread_mutex_lock(&lock->lock.mutex); - if (rc == 0) { - lock->lock.counter++; - lock->lock.holder = own_process; - ecl_return1(env, lock); - } else { - FEunknown_lock_error(lock); - ecl_return1(env, Cnil); - } -#endif } + +#endif /* ECL_WINDOWS_THREADS */ + + +@(defun mp::make-lock (&key name ((:recursive recursive) Ct)) +@ + @(return ecl_make_lock(name, !Null(recursive))) +@) + @(defun mp::get-lock (lock &optional (wait Ct)) @ if (Null(wait)) @@ -264,3 +401,4 @@ mp_get_lock_wait(cl_object lock) else return mp_get_lock_wait(lock); @) + diff --git a/src/lsp/mp.lsp b/src/lsp/mp.lsp index ce0a9c5..38ca207 100644 --- a/src/lsp/mp.lsp +++ b/src/lsp/mp.lsp @@ -107,23 +107,33 @@ by ALLOW-WITH-INTERRUPTS." (defmacro with-lock ((lock-form &rest options) &body body) #-threads `(progn ,@body) - ;; Why do we need %count? Even if get-lock succeeeds, an interrupt may - ;; happen between the end of get-lock and when we save the output of - ;; the function. That means we lose the information and ignore that - ;; the lock was actually acquired. Furthermore, a lock can be recursive - ;; and mp:lock-holder is also not reliable. - ;; - ;; Next notice how we need to disable interrupts around the body and - ;; the get-lock statement, to ensure that the unlocking is done with - ;; interrupts disabled. #+threads - (ext:with-unique-names (lock count) - `(let* ((,lock ,lock-form) - (,count (mp:lock-count-mine ,lock))) + #-windows + (ext:with-unique-names (lock) + `(let* ((,lock ,lock-form)) (without-interrupts (unwind-protect (with-restored-interrupts (mp::get-lock ,lock) (locally ,@body)) - (when (> (mp:lock-count-mine ,lock) ,count) - (mp::giveup-lock ,lock))))))) + (mp::giveup-lock ,lock))))) + #+windows + (ext:with-unique-names (lock count) + ;; Why do we need %count? Even if get-lock succeeeds, an interrupt may + ;; happen between the end of get-lock and when we save the output of + ;; the function. That means we lose the information and ignore that + ;; the lock was actually acquired. Furthermore, a lock can be recursive + ;; and mp:lock-holder is also not reliable. + ;; + ;; Next notice how we need to disable interrupts around the body and + ;; the get-lock statement, to ensure that the unlocking is done with + ;; interrupts disabled. + `(let* ((,lock ,lock-form) + (,count (mp:lock-count-mine ,lock))) + (without-interrupts + (unwind-protect + (with-restored-interrupts + (mp::get-lock ,lock) + (locally ,@body)) + (when (> (mp:lock-count-mine ,lock) ,count) + (mp::giveup-lock ,lock)))))))