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 (defun make-lock (&optional name
)
44 (mp:make-lock
(or name
"Anonymous lock")))
46 (defun acquire-lock (lock &optional
(wait-p t
))
48 (mp::lock-wait lock
"Lock")
49 (mp::lock-wait-with-timeout lock
"Lock" 0)))
51 (defun release-lock (lock)
52 (setf (mp::lock-process lock
) nil
))
54 (defmacro with-lock-held
((place) &body body
)
55 `(mp:with-lock-held
(,place
) ,@body
))
57 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
58 `(mp:with-lock-held
(,place
"Lock Wait" :timeout
,timeout
) ,@body
))
60 ;;; Note that the locks _are_ recursive, but not "balanced", and only
61 ;;; checked if they are being held by the same process by with-lock-held.
62 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
63 ;;; it will wait for recursive locks by the same process as well.
65 ;;; Resource contention: condition variables
67 ;;; There's some stuff in x86-vm.lisp that might be worth investigating
68 ;;; whether to build on. There's also process-wait and friends.
70 (defstruct condition-var
71 "CMUCL doesn't have conditions, so we need to create our own type."
76 (defun make-condition-variable (&key name
)
77 (make-condition-var :lock
(make-lock)
78 :name
(or name
"Anonymous condition variable")))
80 (defun condition-wait (condition-variable lock
)
81 (check-type condition-variable condition-var
)
82 (with-lock-held ((condition-var-lock condition-variable
))
83 (setf (condition-var-active condition-variable
) nil
))
85 (mp:process-wait
"Condition Wait"
86 #'(lambda () (condition-var-active condition-variable
)))
90 (defun condition-notify (condition-variable)
91 (check-type condition-variable condition-var
)
92 (with-lock-held ((condition-var-lock condition-variable
))
93 (setf (condition-var-active condition-variable
) t
))
96 (defun thread-yield ()
101 (defmacro with-timeout
((timeout) &body body
)
103 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
106 ;;; Introspection/debugging
108 (defun all-threads ()
111 (defun interrupt-thread (thread function
&rest args
)
112 (flet ((apply-function ()
114 (lambda () (apply function args
))
116 (declare (dynamic-extent #'apply-function
))
117 (mp:process-interrupt thread
(apply-function))))
119 (defun destroy-thread (thread)
120 (signal-error-if-current-thread thread
)
121 (mp:destroy-process thread
))
123 (defun thread-alive-p (thread)
124 (mp:process-active-p thread
))
126 (defun join-thread (thread)
127 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:process-join
) :mp
) '(and) '(or))
128 (mp:process-join thread
)
129 #-
#.
(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 (lambda () (not (mp:process-alive-p thread
))))
134 (getf (mp:process-property-list thread
) 'return-values
)))
135 (values-list return-values
))))