Based on an original proposal by Dan Barlow (Bordeaux-MP) this library is meant to make writing portable multi-threaded apps simple.
Read the current API documentation.
Tested (whatever that means) on the following platforms:
| implementation | version | Darwin (OS X) | Linux | Windows | ||
|---|---|---|---|---|---|---|
| PPC | x86 | PPC | x86 | x86 | ||
| Allegro | a7.0 | 6-0-0 | ||||
| a8.0 | 6-0-0 | 6-0-0 | ||||
| m8.0 | 6-0-0 | 6-0-0 | ||||
| ArmedBear | 0.0.9 | 6-1-0 | ||||
| CMU | 19c | [no threads] | ||||
| Corman | ||||||
| ECL | 0.9h | 6-0-0 | [no threads] | |||
| LispWorks | 4.4.6 | 6-0-0 | ||||
| MCL | 5.1 | |||||
| OpenMCL | 1.0 | 6-0-0 | ||||
| SBCL | 0.9.13 | [no threads] | 6-0-0 | 6-0-0 | ||
There is also some code in place for Corman Common Lisp and MCL-5.1, but I don't have either installed to test with. CLISP doesn't have threads, so don't even bother asking if I can get it working there, because I can't. Really.
Releases are available, and it is also ASDF-Installable.
You can download the current development tree at http://common-lisp.net/project/bordeaux-threads/darcs/bordeaux-threads/
bordeaux-threads-0.0.2/site/style.css 0000600 0001750 0001750 00000002663 10700014707 017121 0 ustar pierre pierre /* Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) */ tbody { border-top: thin dotted black; } .failure { background-color: #ff0; } .nonexistant { background-color: #ccc; } .perfect { background-color: #0f0; } .error { background-color: #f00; } .header { font-size: medium; background-color:#336699; color:#ffffff; border-style:solid; border-width: 5px; border-color:#002244; padding: 1mm 1mm 1mm 5mm; } .footer { font-size: small; font-style: italic; text-align: right; background-color:#336699; color:#ffffff; border-style:solid; border-width: 2px; border-color:#002244; padding: 1mm 1mm 1mm 1mm; } .footer a:link { font-weight:bold; color:#ffffff; background-color: #336699; text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; background-color: #336699; text-decoration:underline; } .footer a:hover { font-weight:bold; color:#002244; background-color: #336699; text-decoration:underline; } .check {font-size: x-small; text-align:right;} .check a:link { font-weight:bold; color:#a0a0ff; background-color: #FFFFFF; text-decoration:underline; } .check a:visited { font-weight:bold; color:#a0a0ff; background-color: #FFFFFF; text-decoration:underline; } .check a:hover { font-weight:bold; color:#000000; background-color: #FFFFFF; text-decoration:underline; } bordeaux-threads-0.0.2/src/ 0000700 0001750 0001750 00000000000 10700014707 015061 5 ustar pierre pierre bordeaux-threads-0.0.2/src/allegro.lisp 0000600 0001750 0001750 00000004101 10700014707 017375 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; documentation on the Allegro Multiprocessing interface can be found at ;;; http://www.franz.com/support/documentation/6.2/doc/multiprocessing.htm (eval-when (:compile-top-level :load-top-level :execute) (require :process)) #+multiprocessing (progn ;;; Thread Creation (defmethod make-thread (function &key name) (mp:process-run-function name function)) (defmethod current-thread () mp:*current-process*) (defmethod threadp ((object mp:process)) t) (defmethod thread-name ((thread mp:process)) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (mp:make-process-lock :name name)) (defmethod acquire-lock ((lock mp:process-lock) &optional (wait-p t)) (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0))) (defmethod release-lock ((lock mp:process-lock)) (mp:process-unlock lock)) (defmacro with-lock-held ((place) &body body) `(mp:with-process-lock (,place :norecursive t) ,@body)) (defmacro with-recursive-lock-held ((place &key timeout) &body body) `(mp:with-process-lock (,place :timeout ,timeout) ,@body)) ;;; Resource contention: condition variables (defmethod make-condition-variable () (mp:make-gate nil)) (defmethod condition-wait ((condition-variable vector) (lock mp:process-lock)) (release-lock lock) (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable) (acquire-lock lock) (mp:close-gate condition-variable)) (defmethod condition-notify ((condition-variable vector)) (mp:open-gate condition-variable)) (defmethod thread-yield () (mp:process-allow-schedule)) ;;; Introspection/debugging (defmethod all-threads () mp:*all-processes*) (defmethod interrupt-thread ((thread mp:process) function) (mp:process-interrupt thread function)) (defmethod destroy-thread ((thread mp:process)) (mp:process-kill thread)) (mark-supported) ) ; end PROGN bordeaux-threads-0.0.2/src/armedbear.lisp 0000600 0001750 0001750 00000002316 10700014707 017700 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; Thread Creation (defmethod make-thread (function &key name) (ext:make-thread function :name name)) (defmethod current-thread () (ext:current-thread)) (defmethod thread-name (thread) (ext:thread-name thread)) ;;; Yes, this is nasty (defmethod threadp (object) (handler-case (progn (thread-name object) t) (type-error () nil))) ;;; Resource contention: locks and recursive locks ;;; Don't know what the arguments to MAKE-THREAD-LOCK are, but it ;;; doesn't mind being a thunk (defmethod make-lock (&optional name) (declare (ignore name)) (ext:make-thread-lock)) (defmethod acquire-lock (lock &optional (wait-p t)) (ext:thread-lock lock)) (defmethod release-lock (lock) (ext:thread-unlock lock)) (defmacro with-lock-held ((place) &body body) `(ext:with-thread-lock (,place) ,@body)) ;;; Resource contention: condition variables (defmethod thread-yield () (sleep 0)) ;;; Introspection/debugging (defmethod interrupt-thread (thread function) (ext:interrupt-thread thread function)) (defmethod destroy-thread (thread) (ext:destroy-thread thread)) (mark-supported) bordeaux-threads-0.0.2/src/bordeaux-threads.lisp 0000600 0001750 0001750 00000034664 10700014707 021232 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (defpackage bordeaux-threads (:nicknames #:bt #:threads) (:documentation "BORDEAUX-MP is a proposed standard for a minimal MP/Threading interface. It is similar to the CLIM-SYS threading and lock support, but for the following broad differences: 1) Some behaviours are defined in additional detail: attention has been given to special variable interaction, whether and when cleanup forms are run. Some behaviours are defined in less detail: an implementation that does not support multiple threads is not required to use a new list (nil) for a lock, for example. 2) Many functions which would be difficult, dangerous or inefficient to provide on some implementations have been removed. Chiefly these are functions such as thread-wait which expect for efficiency that the thread scheduler is written in Lisp and 'hookable', which can't sensibly be done if the scheduler is external to the Lisp image, or the system has more than one CPU. 3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been added. 4) Posix-style condition variables have been added, as it's not otherwise possible to implement them correctly using the other operations that are specified. Threads may be implemented using whatever applicable techniques are provided by the operating system: user-space scheduling, kernel-based LWPs or anything else that does the job. Some parts of this specification can also be implemented in a Lisp that does not support multiple threads. Thread creation and some thread inspection operations will not work, but the locking functions are still present (though they may do nothing) so that thread-safe code can be compiled on both multithread and single-thread implementations without need of conditionals. To avoid conflict with existing MP/threading interfaces in implementations, these symbols live in the BORDEAUX-MP package. Implementations and/or users may also make them visible or exported in other more traditionally named packages.") (:use #:cl) (:export #:make-thread #:current-thread #:threadp #:thread-name #:*default-special-bindings* #:*supports-threads-p* #:make-lock #:acquire-lock #:release-lock #:with-lock-held #:make-recursive-lock #:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held #:make-condition-variable #:condition-wait #:condition-notify #:thread-yield #:all-threads #:interrupt-thread #:destroy-thread)) (in-package #:bordeaux-threads) (defvar *supports-threads-p* nil "This should be set to T if the running instance has thread support.") (defun mark-supported () (setf *supports-threads-p* t) (pushnew :bordeaux-threads *features*)) (define-condition bordeaux-mp-condition (error) ((message :initarg :message :reader message)) (:report (lambda (condition stream) (format stream (message condition))))) (defgeneric make-mp-support-error () (:documentation "Creates a BORDEAUX-MP condition which specifies whether there is no BORDEAUX-MP support for the implementation, no threads enabled for the system, or no support for a particular function.") (:method () (make-condition 'bordeaux-mp-condition :message (if *supports-threads-p* "There is no support for this method on this implementation." "There is no thread support in this instance.")))) ;;; Thread Creation (defgeneric make-thread (function &key name) (:documentation "Creates and returns a thread named NAME, which will call the function FUNCTION with no arguments: when FUNCTION returns, the thread terminates. NAME defaults to NIL if unsupplied. On systems that do not support multi-threading, MAKE-THREAD will signal an error. The interaction between threads and dynamic variables is in some cases complex, and depends on whether the variable has only a global binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ) or has been bound locally (e.g. with LET or LET*) in the calling thread. - Global bindings are shared between threads: the initial value of a global variable in the new thread will be the same as in the parent, and an assignment to such a variable in any thread will be visible to all threads in which the global binding is visible. - Local bindings are local to the thread they are introduced in, except that - Local bindings in the the caller of MAKE-THREAD may or may not be shared with the new thread that it creates: this is implementation-defined. Portable code should not depend on particular behaviour in this case, nor should it assign to such variables without first rebinding them in the new thread.") (:method (function &key name) (declare (ignore function name)) (error (make-mp-support-error)))) (defvar *default-special-bindings* '() "This variable holds an alist associating special variable symbols with forms to evaluate for binding values. Special variables named in this list will be locally bound in the new thread before it begins executing user code. This variable may be rebound around calls to MAKE-THREAD to add/alter default bindings. The effect of mutating this list is undefined, but earlier forms take precedence over later forms for the same symbol, so defaults may be overridden by consing to the head of the list." ;; Forms are evaluated in the new thread or in the calling thread? ;; Standard contents of this list: print/reader control, etc. Can ;; borrow the franz equivalent? ) (defgeneric current-thread () (:documentation "Returns the thread object for the calling thread. This is the same kind of object as would be returned by MAKE-THREAD.")) (defgeneric threadp (object) (:documentation "Returns true if object is a thread, otherwise NIL.") (:method (object) (declare (ignore object)) nil)) (defgeneric thread-name (thread) (:documentation "Returns the name of the thread, as supplied to MAKE-THREAD")) ;;; Resource contention: locks and recursive locks (defgeneric make-lock (&optional name) (:documentation "Creates a lock (a mutex) whose name is NAME. If the system does not support multiple threads this will still return some object, but it may not be used for very much.") ;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if ;; there's some good reason it should be said structure or that it ;; be freshly consed - EQ comparison of locks? (:method (&optional name) (declare (ignore name)) (list nil))) (defgeneric acquire-lock (lock &optional wait-p) (:documentation "Acquire the lock LOCK for the calling thread. WAIT-P governs what happens if the lock is not available: if WAIT-P is true, the calling thread will wait until the lock is available and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return immediately. ACQUIRE-LOCK returns true if the lock was acquired and NIL otherwise. This specification does not define what happens if a thread attempts to acquire a lock that it already holds. For applications that require locks to be safe when acquired recursively, see instead MAKE-RECURSIVE-LOCK and friends.") (:method (lock &optional wait-p) (declare (ignore lock wait-p)) t)) (defgeneric release-lock (lock) (:documentation "Release LOCK. It is an error to call this unless the lock has previously been acquired (and not released) by the same thread. If other threads are waiting for the lock, the ACQUIRE-LOCK call in one of them will now be able to continue. This function has no interesting return value.") (:method (lock) (declare (ignore lock)) (values))) (defmacro with-lock-held ((place) &body body) "Evaluates BODY with the lock named by PLACE, the value of which is a lock created by MAKE-LOCK. Before the forms in BODY are evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the forms in BODY have been evaluated, or if a non-local control transfer is caused (e.g. by THROW or SIGNAL), the lock is released as if by RELEASE-LOCK. Note that if the debugger is entered, it is unspecified whether the lock is released at debugger entry or at debugger exit when execution is restarted." `(when (acquire-lock ,place t) (unwind-protect (locally ,@body) (release-lock ,place)))) (defgeneric make-recursive-lock (&optional name) (:documentation "Create and return a recursive lock whose name is NAME. A recursive lock differs from an ordinary lock in that a thread that already holds the recursive lock can acquire it again without blocking. The thread must then release the lock twice before it becomes available for another thread.") (:method (&optional name) (declare (ignore name)) (list nil))) (defgeneric acquire-recursive-lock (lock) (:documentation "As for ACQUIRE-LOCK, but for recursive locks.") (:method (lock) (declare (ignore lock)) t)) (defgeneric release-recursive-lock (lock) (:documentation "Release the recursive LOCK. The lock will only become free after as many Release operations as there have been Acquire operations. See RELEASE-LOCK for other information.") (:method (lock) (declare (ignore lock)) (values))) (defmacro with-recursive-lock-held ((place &key timeout) &body body) "Evaluates BODY with the recursive lock named by PLACE, which is a reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See WITH-LOCK-HELD etc etc" `(when (acquire-recursive-lock ,place) (unwind-protect (locally ,@body) (release-recursive-lock ,place)))) ;;; Resource contention: condition variables ;;; A condition variable provides a mechanism for threads to put ;;; themselves to sleep while waiting for the state of something to ;;; change, then to be subsequently woken by another thread which has ;;; changed the state. ;;; ;;; A condition variable must be used in conjunction with a lock to ;;; protect access to the state of the object of interest. The ;;; procedure is as follows: ;;; ;;; Suppose two threads A and B, and some kind of notional event ;;; channel C. A is consuming events in C, and B is producing them. ;;; CV is a condition-variable ;;; ;;; 1) A acquires the lock that safeguards access to C ;;; 2) A threads and removes all events that are available in C ;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically ;;; releases the lock and puts A to sleep on CV ;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again ;;; before returning ;;; 5) Loop back to step 2, for as long as threading should continue ;;; ;;; When B generates an event E, it ;;; 1) acquires the lock guarding C ;;; 2) adds E to the channel ;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread ;;; 4) releases the lock ;;; ;;; To avoid the "lost wakeup" problem, the implementation must ;;; guarantee that CONDITION-WAIT in thread A atomically releases the ;;; lock and sleeps. If this is not guaranteed there is the ;;; possibility that thread B can add an event and call ;;; CONDITION-NOTIFY between the lock release and the sleep - in this ;;; case the notify call would not see A, which would be left sleeping ;;; despite there being an event available. (defgeneric thread-yield () (:documentation "Allows other threads to run. It may be necessary or desirable to call this periodically in some implementations; others may schedule threads automatically. On systems that do not support multi-threading, this does nothing.") (:method () (values))) (defgeneric make-condition-variable () (:documentation "Returns a new condition-variable object for use with CONDITION-WAIT and CONDITION-NOTIFY.")) (defgeneric condition-wait (condition-variable lock) (:documentation "Atomically release LOCK and enqueue the calling thread waiting for CONDITION-VARIABLE. The thread will resume when another thread has notified it using CONDITION-NOTIFY; it may also resume if interrupted by some external event or in other implementation-dependent circumstances: the caller must always test on waking that there is threading to be done, instead of assuming that it can go ahead. However and for whatever reason the thread is resumed, the system always reacquires LOCK before returning to the caller. It is an error to call this unless from the thread that holds LOCK. In an implementation that does not support multiple threads, this function signals an error.") (:method (condition-variable lock) (declare (ignore condition-variable lock)) (error (make-mp-support-error)))) (defgeneric condition-notify (condition-variable) (:documentation "Notify at least one of the threads waiting for CONDITION-VARIABLE. It is implementation-dependent whether one or more than one (and possibly all) threads are woken, but if the implementation is capable of waking only a single thread (not all are) this is probably preferable for efficiency reasons. The order of wakeup is unspecified and does not necessarily relate to the order that the threads went to sleep in. CONDITION-NOTIFY has no useful return value. In an implementation that does not support multiple threads, it has no effect.") (:method (condition-variable) (declare (ignore condition-variable)) (values))) ;;; Introspection/debugging ;;; The following functions may be provided for debugging purposes, ;;; but are not advised to be called from normal user code. (defgeneric all-threads () (:documentation "Returns a sequence of all of the threads. This may or may not be freshly-allocated, so the caller should not modify it.")) (defgeneric interrupt-thread (thread function) (:documentation "Interrupt THREAD and cause it to evaluate FUNCTION before continuing with the interrupted path of execution. This may not be a good idea if THREAD is holding locks or doing anything important. On systems that do not support multiple threads, this function signals an error.") (:method (thread function) (declare (ignore thread function)) (error (make-mp-support-error)))) (defgeneric destroy-thread (thread) (:documentation "Terminates the thread THREAD, which is an object as returned by MAKE-THREAD. This should be used with caution: it is implementation-defined whether the thread runs cleanup forms or releases its locks first. Destroying the calling thread is an error.") (:method :before (thread) (when (eq thread (current-thread)) (error (make-condition 'bordeaux-mp-condition :message "Can not destroy the current thread"))))) bordeaux-threads-0.0.2/src/cmu.lisp 0000600 0001750 0001750 00000004660 10700014707 016546 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) #+mp (progn (defstruct condition-var "CMUCL doesn't have conditions, so we need to create our own type." lock active) ;;; Thread Creation (defmethod make-thread (function &key name) (mp:make-process function :name name)) (defmethod current-thread () mp:*current-process*) (defmethod threadp (object) (mp:processp object)) (defmethod thread-name ((thread mp::process)) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (mp:make-lock name)) (defmethod acquire-lock ((lock mp:lock) &optional (wait-p t)) (if wait-p (mp::lock-wait lock "Lock") (mp::lock-wait-with-timeout lock "Lock" 0))) (defmethod release-lock ((lock mp:lock)) (setf (mp::lock-process lock) nil)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock-held (,place) ,@body)) (defmacro with-recursive-lock-held ((place &key timeout) &body body) `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) ;;; Note that the locks _are_ recursive, but not "balanced", and only ;;; checked if they are being held by the same process by with-lock-held. ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that ;;; it will wait for recursive locks by the same process as well. ;;; Resource contention: condition variables ;;; There's some stuff in x86-vm.lisp that might be worth investigating ;;; whether to build on. There's also process-wait and friends. (defmethod make-condition-variable () (make-condition-var :lock (make-lock))) (defmethod condition-wait ((condition-variable condition-var) (lock mp:lock)) (progn (setf (condition-var-active condition-variable) nil) (release-lock lock) (do () ((when (condition-var-active condition-variable) (acquire-lock lock) t)) (process-yield)))) (defmethod condition-notify ((condition-variable condition-var)) (with-lock-held ((condition-var-lock condition-variable)) (setf (condition-var-active condition-variable) t))) (defmethod process-yield () (mp:process-yield)) ;;; Introspection/debugging (defmethod all-threads () (mp:all-processes)) (defmethod interrupt-thread ((thread mp:process) function) (mp:process-interrupt thread function)) (defmethod destroy-thread ((thread mp:process)) (mp:destroy-process thread)) (mark-supported) ) ; end PROGN bordeaux-threads-0.0.2/src/condition-variables.lisp 0000600 0001750 0001750 00000001764 10700014707 021720 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; This file provides a portable implementation of condition ;;; variables (given a working WITH-LOCK-HELD and THREAD-YIELD), and ;;; should be used if there is no condition variable implementation in ;;; the host Lisp. (defclass condition-var () ((lock :initarg :lock :reader condition-var-lock) (active :accessor condition-var-active))) (defmethod make-condition-variable () (make-instance 'condition-var :lock (make-lock))) (defmethod condition-wait ((condition-variable condition-var) lock) (progn (setf (condition-var-active condition-variable) nil) (release-lock lock) (do () ((when (condition-var-active condition-variable) (acquire-lock lock) t)) (thread-yield)))) (defmethod condition-notify ((condition-variable condition-var)) (with-lock-held ((condition-var-lock condition-variable)) (setf (condition-var-active condition-variable) t))) bordeaux-threads-0.0.2/src/corman.lisp 0000600 0001750 0001750 00000000774 10700014707 017243 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (eval-when (:compile-toplevel :load-toplevel :execute) (require :threads)) ;;; Thread Creation (defmethod make-thread (function &key name) (declare (ignore name)) (threads:create-thread function)) (defmethod current-thread () threads:*current-thread*) ;;; Introspection/debugging (defmethod destroy-thread (thread) (threads:terminate-thread thread)) (mark-supported) bordeaux-threads-0.0.2/src/ecl.lisp 0000600 0001750 0001750 00000002611 10700014707 016517 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; documentation on the ECL Multiprocessing interface can be found at ;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing ;;; FIXME: Need some sort of *FEATURES* check ;;; Thread Creation (defmethod make-thread (function &key name) (mp:process-run-function (or name "") function)) (defmethod current-thread () mp::*current-process*) (defmethod threadp ((object mp:process)) t) (defmethod thread-name ((thread mp:process)) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (mp:make-lock :name name)) (defmethod acquire-lock ((lock mp:lock) &optional (wait-p t)) (mp:get-lock lock wait-p)) (defmethod release-lock ((lock mp:lock)) (mp:giveup-lock lock)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) ;; make-recursive-lock ;; acquire-recursive-lock ;; release-recursive-lock ;;; Resource contention: condition variables (defmethod thread-yield () ;; (mp:yield) (sleep 0)) ;;; Introspection/debugging (defmethod all-threads () (mp:all-processes)) (defmethod interrupt-thread ((thread mp:process) function) (mp:interrupt-process thread function)) (defmethod destroy-thread ((thread mp:process)) (mp:process-kill thread)) (mark-supported) bordeaux-threads-0.0.2/src/lispworks.lisp 0000600 0001750 0001750 00000003152 10700014707 020012 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; documentation on the LispWorks Multiprocessing interface can be found at ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm (mp:initialize-multiprocessing) ;;; Thread Creation (defmethod make-thread (function &key name) (mp:process-run-function name nil function)) (defmethod current-thread () mp:*current-process*) (defmethod threadp ((object mp:process)) t) (defmethod thread-name ((thread mp:process)) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (mp:make-lock :name name)) (defmethod acquire-lock ((lock mp:lock) &optional (wait-p t)) (mp:process-lock lock nil (if wait-p (if (typep wait-p 'number) wait-p nil) 0))) (defmethod release-lock ((lock mp:lock)) (mp:process-unlock lock)) ;;; Apparently this EVAL-WHEN is needed so that the macro is available ;;; when compiling condition-variables.lisp (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body))) ;;; Resource contention: condition variables (defmethod thread-yield () (mp:process-allow-scheduling)) ;;; Introspection/debugging (defmethod all-threads () (mp:list-all-processes)) (defmethod interrupt-thread ((thread mp:process) function) (mp:process-interrupt thread function)) (defmethod destroy-process ((thread mp:process)) (mp:process-kill thread)) (mark-supported) bordeaux-threads-0.0.2/src/mcl.lisp 0000600 0001750 0001750 00000001633 10700014707 016532 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; Thread Creation (defmethod make-thread (function &key name) (ccl:process-run-function name function)) (defmethod current-thread () ccl:*current-thread*) (defmethod threadp (object) (ccl:processp object)) (defmethod thread-name (thread) (ccl:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (ccl:make-lock name)) (defmacro with-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) (defmethod thread-yield () (ccl:process-allow-schedule)) ;;; Introspection/debugging (defmethod all-threadss () ccl:*all-processes*) (defmethod interrupt-thread (thread function) (ccl:process-interrupt thread function)) (defmethod destroy-thread (thread) (ccl:process-kill thread)) (mark-supported) bordeaux-threads-0.0.2/src/openmcl.lisp 0000600 0001750 0001750 00000004130 10700014707 017407 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; documentation on the OpenMCL Threads interface can be found at ;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html #+openmcl-native-threads (progn ;;; Thread Creation (defmethod make-thread (function &key name) (ccl:process-run-function name function)) (defmethod current-thread () ccl:*current-process*) (defmethod threadp ((object ccl:process)) t) (defmethod thread-name ((thread ccl:process)) (ccl:process-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (ccl:make-lock name)) (defmethod acquire-lock ((lock ccl:lock) &optional (wait-p t)) (if wait-p (ccl:grab-lock lock) (ccl:try-lock lock))) (defmethod release-lock ((lock ccl:lock)) (ccl:release-lock lock)) (defmacro with-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) (defmethod make-recursive-lock (&optional name) (ccl:make-lock name)) (defmethod acquire-recursive-lock ((lock ccl::recursive-lock)) (ccl:grab-lock lock)) (defmethod release-recursive-lock ((lock ccl::recursive-lock)) (ccl:release-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) ;;; Resource contention: condition variables (defmethod make-condition-variable () (ccl:make-semaphore)) (defmethod condition-wait ((condition-variable ccl:semaphore) (lock ccl:lock)) (unwind-protect (progn (release-lock lock) (ccl:wait-on-semaphore condition-variable)) (acquire-lock lock t))) (defmethod condition-notify ((condition-variable ccl:semaphore)) (ccl:signal-semaphore condition-variable)) (defmethod thread-yield () (ccl:process-allow-schedule)) ;;; Introspection/debugging (defmethod all-threads () (ccl:all-processes)) (defmethod interrupt-thread ((thread ccl:process) function) (ccl:process-interrupt thread function)) (defmethod destroy-thread ((thread ccl:process)) (ccl:process-kill thread)) (mark-supported) ) ; end PROGN bordeaux-threads-0.0.2/src/sbcl.lisp 0000600 0001750 0001750 00000004212 10700014707 016676 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; documentation on the SBCL Threads interface can be found at ;;; http://www.sbcl.org/manual/Threading.html #+sb-thread (progn ;;; Thread Creation (defmethod make-thread (function &key name) (sb-thread:make-thread function :name name)) (defmethod current-thread () sb-thread:*current-thread*) (defmethod threadp ((object sb-thread:thread)) t) (defmethod thread-name ((thread sb-thread:thread)) (sb-thread:thread-name thread)) ;;; Resource contention: locks and recursive locks (defmethod make-lock (&optional name) (sb-thread:make-mutex :name name)) (defmethod acquire-lock ((lock sb-thread:mutex) &optional (wait-p t)) (sb-thread:get-mutex lock nil wait-p)) (defmethod release-lock ((lock sb-thread:mutex)) (sb-thread:release-mutex lock)) (defmacro with-lock-held ((place) &body body) `(sb-thread:with-mutex (,place) ,@body)) (defmethod make-recursive-lock (&optional name) (sb-thread:make-mutex :name name)) ;;; XXX acquire-recursive-lock and release-recursive-lock are actually ;;; complicated because we can't use control stack tricks. We need to ;;; actually count something to check that the acquire/releases are ;;; balanced (defmacro with-recursive-lock-held ((place) &body body) `(sb-thread:with-recursive-lock (,place) ,@body)) ;;; Resource contention: condition variables (defmethod make-condition-variable () (sb-thread:make-waitqueue)) (defmethod condition-wait ((condition-variable sb-thread:waitqueue) (lock sb-thread:mutex)) (sb-thread:condition-wait condition-variable lock)) (defmethod condition-notify ((condition-variable sb-thread:waitqueue)) (sb-thread:condition-notify condition-variable)) (defmethod thread-yield () (sb-thread:release-foreground)) ;;; Introspection/debugging (defmethod all-threads () (sb-thread:list-all-threads)) (defmethod interrupt-thread ((thread sb-thread:thread) function) (sb-thread:interrupt-thread thread function)) (defmethod destroy-thread ((thread sb-thread:thread)) (sb-thread:terminate-thread thread)) (mark-supported) ) ; end PROGN bordeaux-threads-0.0.2/src/unsupported.lisp 0000600 0001750 0001750 00000000613 10700014707 020344 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package :bordeaux-threads) (defmethod current-thread () nil) (cerror "Ignore and continue" "There is no Bordeaux-Threads support for your implementation, some features may not work. Feel free to implement it, or bug one of the maintainers to do so if your lisp supports threads at all.") bordeaux-threads-0.0.2/test/ 0000700 0001750 0001750 00000000000 10700014707 015251 5 ustar pierre pierre bordeaux-threads-0.0.2/test/bordeaux-threads-test.lisp 0000600 0001750 0001750 00000005515 10700014707 022370 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (defpackage bordeaux-threads-test (:use #:cl #:bordeaux-threads #:lift)) (in-package #:bordeaux-threads-test) (deftestsuite test-bordeaux-threads () ((lock :initform (make-lock)))) (addtest should-have-current-thread (ensure (current-thread))) (addtest should-identify-threads-correctly (ensure (threadp (current-thread))) (ensure (threadp (make-thread (lambda () t) :name "foo"))) (ensure (not (threadp (make-lock))))) (addtest should-retrieve-thread-name (ensure-same (thread-name (make-thread (lambda () t) :name "foo")) "foo")) (addtest should-lock-without-contention (ensure (acquire-lock lock t)) (release-lock lock) (ensure (acquire-lock lock nil)) (release-lock lock)) (defparameter *shared* 0) (defparameter *lock* (make-lock)) (addtest should-have-thread-interaction ;; this simple test generates N process. Each process grabs and ;; releases the lock until SHARED has some value, it then ;; increments SHARED. the outer code first sets shared 1 which ;; gets the thing running and then waits for SHARED to reach some ;; value. this should, i think, stress test locks. (setf *shared* 0) (dotimes (i 1) (let* ((procs (loop for i from 1 upto 2 collect (make-thread (compile nil `(lambda () (loop named wait do (with-lock-held (*lock*) (when (= ,i *shared*) (incf *shared*) (return-from wait)))))) :name (format nil "Proc #~D" i))))) (with-lock-held (*lock*) (incf *shared*)) (block test (loop until (with-lock-held (*lock*) (= (1+ (length procs)) *shared*)) do (with-lock-held (*lock*) (ensure (>= (1+ (length procs)) *shared*)))))))) (defparameter *condition-variable* (make-condition-variable)) (addtest condition-variable (setf *shared* 0) (let ((num-procs 100)) (dotimes (i num-procs) (make-thread (compile nil `(lambda () (with-lock-held (*lock*) (loop until (= ,i *shared*) do (condition-wait *condition-variable* *lock*)) (incf *shared*)) (condition-notify *condition-variable*))))) (with-lock-held (*lock*) (loop until (= num-procs *shared*) do (condition-wait *condition-variable* *lock*))) (ensure-same num-procs *shared*))) bordeaux-threads-0.0.2/bordeaux-threads.asd 0000600 0001750 0001750 00000004620 10700014707 020230 0 ustar pierre pierre #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (defpackage bordeaux-threads-system (:use #:cl #:asdf)) (in-package :bordeaux-threads-system) (defsystem bordeaux-threads :description "" :long-description "" :author "Greg Pfeil