1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; 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 (defvar *thread-join-mutex
* nil
)
13 ;;; initialize *thread-join-mutex* for loading thread
14 ;;; NB: all existing threads at time of loading(even those not created by B-T)
15 ;;; will become "joinable".
16 (eval-when (:load-toplevel
)
19 (unless (mt:symbol-value-thread
'*thread-join-mutex
* thr
)
22 :function
#'mt
:mutex-lock
23 :arguments
(list (setf (mt:symbol-value-thread
'*thread-join-mutex
* T
)
28 (defun %make-thread
(function name
)
31 (let ((*thread-join-mutex
* (mt:make-mutex
)))
32 (mt:with-mutex-lock
(*thread-join-mutex
*)
35 :initial-bindings mt
:*default-special-bindings
*))
37 (defun current-thread ()
40 (defun threadp (object)
43 (defun thread-name (thread)
44 (mt:thread-name thread
))
46 ;;; Resource contention: locks and recursive locks
48 (defun make-lock (&optional name
)
49 (mt:make-mutex
:name
(or name
"Anonymous lock")))
51 (defun acquire-lock (lock &optional
(wait-p t
))
52 (mt:mutex-lock lock
:timeout
(if wait-p nil
0)))
54 (defun release-lock (lock)
55 (mt:mutex-unlock lock
))
57 (defmacro with-lock-held
((place) &body body
)
58 `(mt:with-mutex-lock
(,place
) ,@body
))
60 (defun make-recursive-lock (&optional name
)
61 (mt:make-mutex
:name
(or name
"Anonymous recursive lock")
64 (defmacro with-recursive-lock-held
((place) &body body
)
65 `(mt:with-mutex-lock
(,place
) ,@body
))
67 ;;; Resource contention: condition variables
69 (defun make-condition-variable (&key name
)
70 (mt:make-exemption
:name
(or name
"Anonymous condition variable")))
72 (defun condition-wait (condition-variable lock
)
73 (mt:exemption-wait condition-variable lock
))
75 (defun condition-notify (condition-variable)
76 (mt:exemption-signal condition-variable
))
78 (defun thread-yield ()
83 (defmacro with-timeout
((timeout) &body body
)
85 `(mt:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
88 ;;; Introspection/debugging
90 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
92 (delete-if-not #'mt
:thread-active-p
(mt:list-threads
)))
94 (defun interrupt-thread (thread function
)
95 (mt:thread-interrupt thread
:function function
))
97 (defun destroy-thread (thread)
98 ;;; VTZ: actually we can kill ourselelf.
99 ;;; suicide is part of our contemporary life :)
100 (signal-error-if-current-thread thread
)
101 (mt:thread-interrupt thread
:function t
))
103 (defun thread-alive-p (thread)
104 (mt:thread-active-p thread
))
106 ;;; VTZ: the current implementation is trivial and may cause contention
107 ;;; if the thread is tried to be joined immediately after its creation
108 ;;; or if :initial-bindings argument of make-thread cause entering the debugger
109 (defun thread-join (thread)
110 (loop while
(mt:thread-active-p thread
) do
111 (let ((jmx (mt:symbol-value-thread
'*thread-join-mutex
* thread
)))
112 (when jmx
; mutex may have not been created
113 (mt:mutex-lock jmx
) ; wait
114 ; give chance other threads to wait/join as well
115 (mt:mutex-unlock jmx
)))))