2 Copyright
2006, 2007 Greg Pfeil
4 Distributed under the MIT license
(see LICENSE file
)
7 (in-package #:bordeaux-threads
)
11 (defun make-thread (function &rest keys
&key name
)
12 (declare (ignore name
))
13 (apply #'mp
:make-process function keys
))
15 (defun current-thread ()
18 (defmethod threadp (object)
21 (defun thread-name (thread)
22 (mp:process-name thread
))
24 ;;; Resource contention: locks and recursive locks
26 (defun make-lock (&optional name
)
29 (defun acquire-lock (lock &optional
(wait-p t
))
31 (mp::lock-wait lock
"Lock")
32 (mp::lock-wait-with-timeout lock
"Lock" 0)))
34 (defun release-lock (lock)
35 (setf (mp::lock-process lock
) nil
))
37 (defmacro with-lock-held
((place) &body body
)
38 `(mp:with-lock-held
(,place
) ,@body
))
40 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
41 `(mp:with-lock-held
(,place
"Lock Wait" :timeout
,timeout
) ,@body
))
43 ;;; Note that the locks _are_ recursive, but not "balanced", and only
44 ;;; checked if they are being held by the same process by with-lock-held.
45 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
46 ;;; it will wait for recursive locks by the same process as well.
48 ;;; Resource contention: condition variables
50 ;;; There's some stuff in x86-vm.lisp that might be worth investigating
51 ;;; whether to build on. There's also process-wait and friends.
53 (defstruct condition-var
54 "CMUCL doesn't have conditions, so we need to create our own type."
58 (defun make-condition-variable ()
59 (make-condition-var :lock
(make-lock)))
61 (defun condition-wait (condition-variable lock
)
62 (check-type condition-variable condition-var
)
63 (with-lock-held ((condition-var-lock condition-variable
))
64 (setf (condition-var-active condition-variable
) nil
))
66 (mp:process-wait
"Condition Wait"
67 #'(lambda () (condition-var-active condition-variable
)))
71 (defun condition-notify (condition-variable)
72 (check-type condition-variable condition-var
)
73 (with-lock-held ((condition-var-lock condition-variable
))
74 (setf (condition-var-active condition-variable
) t
))
77 (defun thread-yield ()
82 (defmacro with-timeout
((timeout) &body body
)
83 `(mp:with-timeout
(,timeout
)
86 ;;; Introspection/debugging
91 (defun interrupt-thread (thread function
)
92 (mp:process-interrupt thread function
))
94 (defun destroy-thread (thread)
95 (signal-error-if-current-thread thread
)
96 (mp:destroy-process thread
))
98 (defun thread-alive-p (thread)
99 (mp:process-active-p thread
))