diff --git a/bordeaux-threads.asd b/bordeaux-threads.asd --- a/bordeaux-threads.asd +++ b/bordeaux-threads.asd @@ -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 --git a/src/impl-abcl.lisp b/src/impl-abcl.lisp --- a/src/impl-abcl.lisp +++ b/src/impl-abcl.lisp @@ -30,25 +30,103 @@ ;;; Resource contention: locks and recursive locks +(defstruct mutex-abstract + name + lock) +(defstruct (mutex (:include mutex-abstract))) +(defstruct (mutex-recursive (:include mutex-abstract))) + +;; Making methods constants in this manner avoids the time 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)) + (when (and (typep lock 'mutex) + (jcall +is-held-by-current-thread+ (mutex-lock lock))) + (error "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)) + (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) + (error "Attempt to release lock not held by calling thread.")) + (when (and (typep lock 'mutex) + (> (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)) (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"))) + +(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)))))) + +(defun acquire-recursive-lock (lock &optional (wait-p t)) + (assert (typep lock 'mutex-recursive)) + (acquire-lock lock wait-p)) + +(defun release-recursive-lock (lock) + (assert (typep lock 'mutex-recursive)) + (release-lock lock)) ;;; 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 ()