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 (mp:make-condition-variable
:name name
))
41 (defun condition-wait (condition-variable lock
)
42 (mp:condition-variable-wait condition-variable lock
))
44 (defun condition-notify (condition-variable)
45 (mp:condition-variable-signal condition-variable
))
47 (defun thread-yield ()
48 (mp:process-allow-schedule
))
55 (defun start-multiprocessing ()
58 (defvar *thread-results
* (make-hash-table :weak-keys t
))
60 (defvar *thread-join-lock
* (make-lock "Bordeaux threads join lock"))
62 (defun %make-thread
(function name
)
63 (mp:process-run-function
66 (let ((result (funcall function
)))
67 (with-lock-held (*thread-join-lock
*)
68 (setf (gethash (current-thread) *thread-results
*)
71 (defun current-thread ()
74 (defun threadp (object)
75 (typep object
'mp
:process
))
77 (defun thread-name (thread)
78 (mp:process-name thread
))
82 (defmacro with-timeout
((timeout) &body body
)
84 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
87 ;;; Introspection/debugging
92 (defun interrupt-thread (thread function
&rest args
)
93 (apply #'mp
:process-interrupt thread function args
))
95 (defun destroy-thread (thread)
96 (signal-error-if-current-thread thread
)
97 (mp:process-kill thread
))
99 (defun thread-alive-p (thread)
100 (mp:process-alive-p thread
))
102 (defun join-thread (thread)
103 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
104 (complement #'mp
:process-alive-p
)
106 (with-lock-held (*thread-join-lock
*)
108 (gethash thread
*thread-results
*)
109 (remhash thread
*thread-results
*))))