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
)
11 ;;; documentation on the Allegro Multiprocessing interface can be found at
12 ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
14 ;;; Resource contention: locks and recursive locks
16 (deftype lock
() 'mp
:process-lock
)
18 (deftype recursive-lock
() 'mp
:process-lock
)
20 (defun lock-p (object)
21 (typep object
'mp
:process-lock
))
23 (defun recursive-lock-p (object)
24 (typep object
'mp
:process-lock
))
26 (defun make-lock (&optional name
)
27 (mp:make-process-lock
:name
(or name
"Anonymous lock")))
29 (defun make-recursive-lock (&optional name
)
30 (mp:make-process-lock
:name
(or name
"Anonymous recursive lock")))
32 (defun acquire-lock (lock &optional
(wait-p t
))
33 (mp:process-lock lock mp
:*current-process
* "Lock" (if wait-p nil
0)))
35 (defun release-lock (lock)
36 (mp:process-unlock lock
))
38 (defmacro with-lock-held
((place) &body body
)
39 `(mp:with-process-lock
(,place
:norecursive t
)
42 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
43 `(mp:with-process-lock
(,place
:timeout
,timeout
)
46 ;;; Resource contention: condition variables
48 (defun make-condition-variable (&key name
)
49 (declare (ignorable name
))
53 (mp:make-condition-variable
:name name
))
55 (defun condition-wait (condition-variable lock
&key timeout
)
60 (mp:process-wait-with-timeout
"wait for message" timeout
61 #'mp
:gate-open-p condition-variable
)
62 (mp:process-wait
"wait for message" #'mp
:gate-open-p condition-variable
))
64 (mp:close-gate condition-variable
))
66 (mp:condition-variable-wait condition-variable lock
:timeout timeout
)
69 (defun condition-notify (condition-variable)
71 (mp:open-gate condition-variable
)
73 (mp:condition-variable-signal condition-variable
))
75 (defun thread-yield ()
76 (mp:process-allow-schedule
))
83 (defun start-multiprocessing ()
86 (defun %make-thread
(function name
)
88 (mp:process-run-function name function
)
90 (mp:process-run-function
94 (multiple-value-list (funcall function
))))
95 (setf (getf (mp:process-property-list mp
:*current-process
*)
98 (values-list return-values
)))))
100 (defun current-thread ()
101 mp
:*current-process
*)
103 (defun threadp (object)
104 (typep object
'mp
:process
))
106 (defun thread-name (thread)
107 (mp:process-name thread
))
111 (defmacro with-timeout
((timeout) &body body
)
113 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
116 ;;; Introspection/debugging
118 (defun all-threads ()
121 (defun interrupt-thread (thread function
&rest args
)
122 (apply #'mp
:process-interrupt thread function args
))
124 (defun destroy-thread (thread)
125 (signal-error-if-current-thread thread
)
126 (mp:process-kill thread
))
128 (defun thread-alive-p (thread)
129 (mp:process-alive-p thread
))
131 (defun join-thread (thread)
133 (values-list (mp:process-join thread
))
136 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
137 (complement #'mp
:process-alive-p
)
140 (getf (mp:process-property-list thread
) 'return-values
)))
141 (values-list return-values
))))