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 (mp:make-process function
:name name
))
22 (defun current-thread ()
25 (defmethod threadp (object)
28 (defun thread-name (thread)
29 (mp:process-name thread
))
31 ;;; Resource contention: locks and recursive locks
33 (defun make-lock (&optional name
)
34 (mp:make-lock
(or name
"Anonymous lock")))
36 (defun acquire-lock (lock &optional
(wait-p t
))
38 (mp::lock-wait lock
"Lock")
39 (mp::lock-wait-with-timeout lock
"Lock" 0)))
41 (defun release-lock (lock)
42 (setf (mp::lock-process lock
) nil
))
44 (defmacro with-lock-held
((place) &body body
)
45 `(mp:with-lock-held
(,place
) ,@body
))
47 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
48 `(mp:with-lock-held
(,place
"Lock Wait" :timeout
,timeout
) ,@body
))
50 ;;; Note that the locks _are_ recursive, but not "balanced", and only
51 ;;; checked if they are being held by the same process by with-lock-held.
52 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
53 ;;; it will wait for recursive locks by the same process as well.
55 ;;; Resource contention: condition variables
57 ;;; There's some stuff in x86-vm.lisp that might be worth investigating
58 ;;; whether to build on. There's also process-wait and friends.
60 (defstruct condition-var
61 "CMUCL doesn't have conditions, so we need to create our own type."
66 (defun make-condition-variable (&key name
)
67 (make-condition-var :lock
(make-lock)
68 :name
(or name
"Anonymous condition variable")))
70 (defun condition-wait (condition-variable lock
)
71 (check-type condition-variable condition-var
)
72 (with-lock-held ((condition-var-lock condition-variable
))
73 (setf (condition-var-active condition-variable
) nil
))
75 (mp:process-wait
"Condition Wait"
76 #'(lambda () (condition-var-active condition-variable
)))
80 (defun condition-notify (condition-variable)
81 (check-type condition-variable condition-var
)
82 (with-lock-held ((condition-var-lock condition-variable
))
83 (setf (condition-var-active condition-variable
) t
))
86 (defun thread-yield ()
91 (defmacro with-timeout
((timeout) &body body
)
93 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
96 ;;; Introspection/debugging
101 (defun interrupt-thread (thread function
&rest args
)
102 (flet ((apply-function ()
104 (lambda () (apply function args
))
106 (declare (dynamic-extent #'apply-function
))
107 (mp:process-interrupt thread
(apply-function))))
109 (defun destroy-thread (thread)
110 (signal-error-if-current-thread thread
)
111 (mp:destroy-process thread
))
113 (defun thread-alive-p (thread)
114 (mp:process-active-p thread
))
116 (defun join-thread (thread)
117 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
118 (lambda () (not (mp:process-alive-p thread
)))))