diff -r 55086ac1a3f3 bordeaux-threads.asd --- a/bordeaux-threads.asd Wed Feb 23 13:29:32 2011 +0100 +++ b/bordeaux-threads.asd Tue Mar 01 15:36:35 2011 +0100 @@ -50,7 +50,7 @@ #-thread-support "impl-null") #+(and thread-support lispworks (not lispworks6)) (:file "impl-lispworks-condition-variables") - #+(and thread-support (or armedbear digitool)) + #+(and thread-support digitool) (:file "condition-variables") (:file "default-implementations")))) :in-order-to ((asdf:test-op (asdf:load-op bordeaux-threads-test))) diff -r 55086ac1a3f3 src/impl-abcl.lisp --- a/src/impl-abcl.lisp Wed Feb 23 13:29:32 2011 +0100 +++ b/src/impl-abcl.lisp Tue Mar 01 15:36:35 2011 +0100 @@ -3,6 +3,8 @@ #| Copyright 2006, 2007 Greg Pfeil +Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011. + Distributed under the MIT license (see LICENSE file) |# @@ -22,33 +24,118 @@ (defun current-thread () (threads:current-thread)) +(defun threadp (object) + (typep object 'thread)) + (defun thread-name (thread) (threads:thread-name thread)) -(defun threadp (object) - (typep object 'thread)) - ;;; Resource contention: locks and recursive locks +(defstruct mutex name lock) +(defstruct (mutex-recursive (:include mutex))) + +;; Making methods constants in this manner avoids the runtime expense of +;; introspection involved in JCALL with string arguments. +(defconstant +lock+ + (jmethod "java.util.concurrent.locks.ReentrantLock" "lock")) +(defconstant +try-lock+ + (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock")) +(defconstant +is-held-by-current-thread+ + (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread")) +(defconstant +unlock+ + (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock")) +(defconstant +get-hold-count+ + (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount")) + (defun make-lock (&optional name) - (declare (ignore name)) - (threads:make-thread-lock)) + (make-mutex + :name (or name "Anonymous lock") + :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) (defun acquire-lock (lock &optional (wait-p t)) - (declare (ignore wait-p)) - (threads:thread-lock lock)) + (check-type lock mutex) + (when (jcall +is-held-by-current-thread+ (mutex-lock lock)) + (warn "Non-recursive lock being reacquired by owner.")) + (if wait-p + (progn + (jcall +lock+ (mutex-lock lock)) + t) + (jcall +try-lock+ (mutex-lock lock)))) (defun release-lock (lock) - (threads:thread-unlock lock)) + (check-type lock mutex) + (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) + (error "Attempt to release lock not held by calling thread.")) + (jcall +unlock+ (mutex-lock lock)) + (values)) +#+nil (defmacro with-lock-held ((place) &body body) - `(threads:with-thread-lock (,place) ,@body)) + (let ((m (gensym))) + `(let ((,m ,place)) + (when (acquire-lock ,m) + (unwind-protect + (progn + ,@body) + (release-lock ,m)))))) + +(defun make-recursive-lock (&optional name) + (make-mutex-recursive + :name (or name "Anonymous lock") + :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) + +(defun acquire-recursive-lock (lock &optional (wait-p t)) + (check-type lock mutex-recursive) + (if wait-p + (progn + (jcall +lock+ (mutex-recursive-lock lock)) + t) + (jcall +try-lock+ (mutex-recursive-lock lock)))) + + +(defun release-recursive-lock (lock) + (check-type lock mutex-recursive) + (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) + (error "Attempt to release lock not held by calling thread.")) + (when (> (jcall +get-hold-count+ (mutex-lock lock)) 1) + (do () + ((= (jcall +get-hold-count+ (mutex-lock lock)) 1)) + (jcall +unlock+ (mutex-lock lock)))) + (jcall +unlock+ (mutex-lock lock)) + (values)) + +#+nil +(defmacro with-recursive-lock-held ((place) &body body) + (let ((m (gensym))) + `(let ((,m ,place)) + (when (acquire-recursive-lock ,m) + (unwind-protect + (progn + ,@body) + (release-lock ,m)))))) ;;; Resource contention: condition variables (defun thread-yield () (sleep 0.01)) +(defstruct condition-variable + name) + +(defun condition-wait (condition lock) + (check-type condition condition-variable) + (release-lock lock) + (do () + ((acquire-lock lock nil)) + (threads:synchronized-on condition + (threads:object-wait condition)))) + +(defun condition-notify (condition) + (check-type condition condition-variable) + (threads:synchronized-on condition + (threads:object-notify-all condition))) + ;;; Introspection/debugging (defun all-threads ()