1 ;;;; -*- indent-tabs-mode: nil -*-
4 Copyright
2006, 2007 Greg Pfeil
6 Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson
2011.
8 Distributed under the MIT license
(see LICENSE file
)
11 (in-package #:bordeaux-threads
)
13 ;;; the implementation of the Armed Bear thread interface can be found in
14 ;;; src/org/armedbear/lisp/LispThread.java
21 (defun %make-thread
(function name
)
22 (threads:make-thread function
:name name
))
24 (defun current-thread ()
25 (threads:current-thread
))
27 (defun thread-name (thread)
28 (threads:thread-name thread
))
30 (defun threadp (object)
31 (typep object
'thread
))
33 ;;; Resource contention: locks and recursive locks
35 (defstruct mutex name lock
)
36 (defstruct (mutex-recursive (:include mutex
)))
38 ;; Making methods constants in this manner avoids the runtime expense of
39 ;; introspection involved in JCALL with string arguments.
41 (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
42 (defconstant +try-lock
+
43 (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
44 (defconstant +is-held-by-current-thread
+
45 (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
47 (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
48 (defconstant +get-hold-count
+
49 (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
51 (deftype lock
() 'mutex
)
53 (deftype recursive-lock
() 'mutex-recursive
)
55 (defun lock-p (object)
56 (typep object
'mutex
))
58 (defun recursive-lock-p (object)
59 (typep object
'mutex-recursive
))
61 (defun make-lock (&optional name
)
63 :name
(or name
"Anonymous lock")
64 :lock
(jnew "java.util.concurrent.locks.ReentrantLock")))
66 (defun acquire-lock (lock &optional
(wait-p t
))
67 (check-type lock mutex
)
68 (when (jcall +is-held-by-current-thread
+ (mutex-lock lock
))
69 (error "Non-recursive lock being reacquired by owner."))
72 (jcall +lock
+ (mutex-lock lock
))
74 (t (jcall +try-lock
+ (mutex-lock lock
)))))
76 (defun release-lock (lock)
77 (check-type lock mutex
)
78 (unless (jcall +is-held-by-current-thread
+ (mutex-lock lock
))
79 (error "Attempt to release lock not held by calling thread."))
80 (jcall +unlock
+ (mutex-lock lock
))
83 (defun make-recursive-lock (&optional name
)
85 :name
(or name
"Anonymous lock")
86 :lock
(jnew "java.util.concurrent.locks.ReentrantLock")))
88 (defun acquire-recursive-lock (lock &optional
(wait-p t
))
89 (check-type lock mutex-recursive
)
92 (jcall +lock
+ (mutex-recursive-lock lock
))
94 (t (jcall +try-lock
+ (mutex-recursive-lock lock
)))))
96 (defun release-recursive-lock (lock)
97 (check-type lock mutex-recursive
)
98 (unless (jcall +is-held-by-current-thread
+ (mutex-lock lock
))
99 (error "Attempt to release lock not held by calling thread."))
100 (jcall +unlock
+ (mutex-lock lock
))
103 ;;; Resource contention: condition variables
105 (defun thread-yield ()
106 (java:jstatic
"yield" "java.lang.Thread"))
108 (defstruct condition-variable
109 (name "Anonymous condition variable"))
111 (defun condition-wait (condition lock
&key timeout
)
112 (threads:synchronized-on condition
115 ;; Since giving a zero time value to threads:object-wait means
116 ;; an indefinite wait, use some arbitrary small number.
117 (threads:object-wait condition
119 least-positive-single-float
121 (threads:object-wait condition
)))
125 (defun condition-notify (condition)
126 (threads:synchronized-on condition
127 (threads:object-notify condition
)))
129 ;;; Introspection/debugging
131 (defun all-threads ()
133 (threads:mapcar-threads
(lambda (thread)
134 (push thread threads
)))
137 (defun interrupt-thread (thread function
&rest args
)
138 (apply #'threads
:interrupt-thread thread function args
))
140 (defun destroy-thread (thread)
141 (signal-error-if-current-thread thread
)
142 (threads:destroy-thread thread
))
144 (defun thread-alive-p (thread)
145 (threads:thread-alive-p thread
))
147 (defun join-thread (thread)
148 (threads:thread-join thread
))