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 (defun make-lock (&optional name
)
17 (mp:make-process-lock
:name
(or name
"Anonymous lock")))
19 (defun make-recursive-lock (&optional name
)
20 (mp:make-process-lock
:name
(or name
"Anonymous recursive lock")))
22 (defun acquire-lock (lock &optional
(wait-p t
))
23 (mp:process-lock lock mp
:*current-process
* "Lock" (if wait-p nil
0)))
25 (defun release-lock (lock)
26 (mp:process-unlock lock
))
28 (defmacro with-lock-held
((place) &body body
)
29 `(mp:with-process-lock
(,place
:norecursive t
)
32 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
33 `(mp:with-process-lock
(,place
:timeout
,timeout
)
36 ;;; Resource contention: condition variables
38 (defun make-condition-variable (&key name
)
39 (declare (ignorable name
))
43 (mp:make-condition-variable
:name name
))
45 (defun condition-wait (condition-variable lock
)
49 (mp:process-wait
"wait for message" #'mp
:gate-open-p condition-variable
)
51 (mp:close-gate condition-variable
))
53 (mp:condition-variable-wait condition-variable lock
))
55 (defun condition-notify (condition-variable)
57 (mp:open-gate condition-variable
)
59 (mp:condition-variable-signal condition-variable
))
61 (defun thread-yield ()
62 (mp:process-allow-schedule
))
69 (defun start-multiprocessing ()
72 (defun %make-thread
(function name
)
74 (mp:process-run-function name function
)
76 (mp:process-run-function
80 (multiple-value-list (funcall function
))))
81 (setf (getf (mp:process-property-list mp
:*current-process
*)
84 (values-list return-values
)))))
86 (defun current-thread ()
89 (defun threadp (object)
90 (typep object
'mp
:process
))
92 (defun thread-name (thread)
93 (mp:process-name thread
))
97 (defmacro with-timeout
((timeout) &body body
)
99 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
102 ;;; Introspection/debugging
104 (defun all-threads ()
107 (defun interrupt-thread (thread function
&rest args
)
108 (apply #'mp
:process-interrupt thread function args
))
110 (defun destroy-thread (thread)
111 (signal-error-if-current-thread thread
)
112 (mp:process-kill thread
))
114 (defun thread-alive-p (thread)
115 (mp:process-alive-p thread
))
117 (defun join-thread (thread)
119 (values-list (mp:process-join thread
))
122 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
123 (complement #'mp
:process-alive-p
)
126 (getf (mp:process-property-list thread
) 'return-values
)))
127 (values-list return-values
))))