1 ;;;; -*- indent-tabs-mode: nil -*-
4 Copyright
2006, 2007 Greg Pfeil
6 Distributed under the MIT license
(see LICENSE file
)
9 (in-package #:bordeaux-threads
)
16 (defun start-multiprocessing ()
17 (mp::startup-idle-and-top-level-loops
))
19 (defun %make-thread
(function name
)
20 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
21 (mp:make-process function
:name name
)
22 #-
#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
23 (mp:make-process
(lambda ()
25 (multiple-value-list (funcall function
))))
26 (setf (getf (mp:process-property-list mp
:*current-process
*)
29 (values-list return-values
)))
32 (defun current-thread ()
35 (defmethod threadp (object)
38 (defun thread-name (thread)
39 (mp:process-name thread
))
41 ;;; Resource contention: locks and recursive locks
43 (deftype lock
() 'mp
::error-check-lock
)
45 (deftype recursive-lock
() 'mp
::recursive-lock
)
47 (defun lock-p (object)
48 (typep object
'mp
::error-check-lock
))
50 (defun recursive-lock-p (object)
51 (typep object
'mp
::recursive-lock
))
53 (defun make-lock (&optional name
)
54 (mp:make-lock
(or name
"Anonymous lock")
57 (defun acquire-lock (lock &optional
(wait-p t
))
59 (mp::lock-wait lock
"Lock wait")
60 (mp::lock-wait-with-timeout lock
"Lock wait" 0)))
62 (defun release-lock (lock)
63 (setf (mp::lock-process lock
) nil
))
65 (defmacro with-lock-held
((place) &body body
)
66 `(mp:with-lock-held
(,place
"Lock wait") ,@body
))
68 (defun make-recursive-lock (&optional name
)
69 (mp:make-lock
(or name
"Anonymous recursive lock")
72 (defun acquire-recursive-lock (lock &optional
(wait-p t
))
75 (defun release-recursive-lock (lock)
78 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
79 `(mp:with-lock-held
(,place
"Lock Wait" :timeout
,timeout
) ,@body
))
81 ;;; Note that the locks _are_ recursive, but not "balanced", and only
82 ;;; checked if they are being held by the same process by with-lock-held.
83 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
84 ;;; it will wait for recursive locks by the same process as well.
86 ;;; Resource contention: condition variables
88 ;;; There's some stuff in x86-vm.lisp that might be worth investigating
89 ;;; whether to build on. There's also process-wait and friends.
91 (defstruct condition-var
92 "CMUCL doesn't have conditions, so we need to create our own type."
97 (defun make-condition-variable (&key name
)
98 (make-condition-var :lock
(make-lock)
99 :name
(or name
"Anonymous condition variable")))
101 (defun condition-wait (condition-variable lock
&key timeout
)
102 (signal-error-if-condition-wait-timeout timeout
)
103 (check-type condition-variable condition-var
)
104 (with-lock-held ((condition-var-lock condition-variable
))
105 (setf (condition-var-active condition-variable
) nil
))
107 (mp:process-wait
"Condition Wait"
108 #'(lambda () (condition-var-active condition-variable
)))
112 (define-condition-wait-compiler-macro)
114 (defun condition-notify (condition-variable)
115 (check-type condition-variable condition-var
)
116 (with-lock-held ((condition-var-lock condition-variable
))
117 (setf (condition-var-active condition-variable
) t
))
120 (defun thread-yield ()
125 (defmacro with-timeout
((timeout) &body body
)
127 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
130 ;;; Introspection/debugging
132 (defun all-threads ()
135 (defun interrupt-thread (thread function
&rest args
)
136 (flet ((apply-function ()
138 (lambda () (apply function args
))
140 (declare (dynamic-extent #'apply-function
))
141 (mp:process-interrupt thread
(apply-function))))
143 (defun destroy-thread (thread)
144 (signal-error-if-current-thread thread
)
145 (mp:destroy-process thread
))
147 (defun thread-alive-p (thread)
148 (mp:process-active-p thread
))
150 (defun join-thread (thread)
151 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
152 (mp:process-join thread
)
153 #-
#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
155 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
156 (lambda () (not (mp:process-alive-p thread
))))
158 (getf (mp:process-property-list thread
) 'return-values
)))
159 (values-list return-values
))))