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 LispWorks Multiprocessing interface can be found at
12 ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm
19 (defun start-multiprocessing ()
20 (mp:initialize-multiprocessing
))
22 (defun %make-thread
(function name
)
23 (mp:process-run-function
27 (multiple-value-list (funcall function
))))
28 (setf (mp:process-property
'return-values
)
30 (values-list return-values
)))))
32 (defun current-thread ()
33 #-
#.
(cl:if
(cl:find-symbol
(cl:string
'#:get-current-process
) :mp
) '(and) '(or))
35 ;; introduced in LispWorks 5.1
36 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:get-current-process
) :mp
) '(and) '(or))
37 (mp:get-current-process
))
39 (defun threadp (object)
40 (mp:process-p object
))
42 (defun thread-name (thread)
43 (mp:process-name thread
))
45 ;;; Resource contention: locks and recursive locks
48 (deftype lock
() 'mp
:lock
)
50 #-
(or lispworks4 lispworks5
)
51 (deftype recursive-lock
()
52 '(and mp
:lock
(satisfies mp
:lock-recursive-p
)))
54 (defun lock-p (object)
55 (typep object
'mp
:lock
))
57 (defun recursive-lock-p (object)
58 #+(or lispworks4 lispworks5
)
60 #-
(or lispworks4 lispworks5
) ; version 6+
61 (and (typep object
'mp
:lock
)
62 (mp:lock-recursive-p object
)))
64 (defun make-lock (&optional name
)
65 (mp:make-lock
:name
(or name
"Anonymous lock")
66 #-
(or lispworks4 lispworks5
) :recursivep
67 #-
(or lispworks4 lispworks5
) nil
))
69 (defun acquire-lock (lock &optional
(wait-p t
))
70 (mp:process-lock lock nil
71 (cond ((null wait-p
) 0)
72 ((numberp wait-p
) wait-p
)
75 (defun release-lock (lock)
76 (mp:process-unlock lock
))
78 (defmacro with-lock-held
((place) &body body
)
79 `(mp:with-lock
(,place
) ,@body
))
81 (defun make-recursive-lock (&optional name
)
82 (mp:make-lock
:name
(or name
"Anonymous recursive lock")
83 #-
(or lispworks4 lispworks5
) :recursivep
84 #-
(or lispworks4 lispworks5
) t
))
86 (defun acquire-recursive-lock (lock &optional
(wait-p t
))
87 (acquire-lock lock wait-p
))
89 (defun release-recursive-lock (lock)
92 (defmacro with-recursive-lock-held
((place) &body body
)
93 `(mp:with-lock
(,place
) ,@body
))
95 ;;; Resource contention: condition variables
97 #+(or lispworks6 lispworks7
)
98 (defun make-condition-variable (&key name
)
99 (mp:make-condition-variable
:name
(or name
"Anonymous condition variable")))
101 #+(or lispworks6 lispworks7
)
102 (defun condition-wait (condition-variable lock
&key timeout
)
103 (mp:condition-variable-wait condition-variable lock
:timeout timeout
)
106 #+(or lispworks6 lispworks7
)
107 (defun condition-notify (condition-variable)
108 (mp:condition-variable-signal condition-variable
))
110 (defun thread-yield ()
111 (mp:process-allow-scheduling
))
113 ;;; Introspection/debugging
115 (defun all-threads ()
116 (mp:list-all-processes
))
118 (defun interrupt-thread (thread function
&rest args
)
119 (apply #'mp
:process-interrupt thread function args
))
121 (defun destroy-thread (thread)
122 (signal-error-if-current-thread thread
)
123 (mp:process-kill thread
))
125 (defun thread-alive-p (thread)
126 (mp:process-alive-p thread
))
128 (declaim (inline %join-thread
))
129 (defun %join-thread
(thread)
130 #-
#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
131 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
132 (complement #'mp
:process-alive-p
)
134 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
135 (mp:process-join thread
))
137 (defun join-thread (thread)
138 (%join-thread thread
)
140 (mp:process-property
'return-values thread
)))
141 (values-list return-values
)))