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 ;;; documentation on the Allegro Multiprocessing interface can be found at
12 ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
16 (defun %make-thread
(function name
)
17 (mp:process-run-function name function
))
19 (defun current-thread ()
22 (defun threadp (object)
23 (typep object
'mp
:process
))
25 (defun thread-name (thread)
26 (mp:process-name thread
))
28 ;;; Resource contention: locks and recursive locks
30 (defun make-lock (&optional name
)
31 (mp:make-process-lock
:name
(or name
"Anonymous lock")))
33 (defun make-recursive-lock (&optional name
)
34 (mp:make-process-lock
:name
(or name
"Anonymous recursive lock")))
36 (defun acquire-lock (lock &optional
(wait-p t
))
37 (mp:process-lock lock mp
:*current-process
* "Lock" (if wait-p nil
0)))
39 (defun release-lock (lock)
40 (mp:process-unlock lock
))
42 (defmacro with-lock-held
((place) &body body
)
43 `(mp:with-process-lock
(,place
:norecursive t
)
46 (defmacro with-recursive-lock-held
((place &key timeout
) &body body
)
47 `(mp:with-process-lock
(,place
:timeout
,timeout
)
50 ;;; Resource contention: condition variables
52 (defun make-condition-variable (&key name
)
53 (declare (ignore name
))
56 (defun condition-wait (condition-variable lock
)
58 (mp:process-wait
"wait for message" #'mp
:gate-open-p condition-variable
)
60 (mp:close-gate condition-variable
))
62 (defun condition-notify (condition-variable)
63 (mp:open-gate condition-variable
))
65 (defun thread-yield ()
66 (mp:process-allow-schedule
))
70 (defmacro with-timeout
((timeout) &body body
)
72 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
75 ;;; Introspection/debugging
80 (defun interrupt-thread (thread function
)
81 (mp:process-interrupt thread function
))
83 (defun destroy-thread (thread)
84 (signal-error-if-current-thread thread
)
85 (mp:process-kill thread
))
87 (defun thread-alive-p (thread)
88 (mp:process-alive-p thread
))
90 (defun join-thread (thread)
91 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
92 (complement #'mp
:process-alive-p
) thread
))