pax_global_header00006660000000000000000000000064146355625070014527gustar00rootroot0000000000000052 comment=21619023facf4709b58d240af816f3f7b488d2f6 bordeaux-threads-0.9.4/000077500000000000000000000000001463556250700150025ustar00rootroot00000000000000bordeaux-threads-0.9.4/.github/000077500000000000000000000000001463556250700163425ustar00rootroot00000000000000bordeaux-threads-0.9.4/.github/workflows/000077500000000000000000000000001463556250700203775ustar00rootroot00000000000000bordeaux-threads-0.9.4/.github/workflows/gh-pages-deployment.yml000066400000000000000000000013121463556250700247700ustar00rootroot00000000000000name: GitHub Pages on: push: branches: [ master ] paths: [ 'docs/**' ] workflow_dispatch: inputs: jobs: build-deploy: runs-on: ubuntu-22.04 concurrency: group: ${{ github.workflow }}-${{ github.ref }} steps: - uses: actions/checkout@v4 with: submodules: true fetch-depth: 0 - name: Setup Hugo uses: peaceiris/actions-hugo@v3 with: hugo-version: '0.124.1' extended: true - name: Build run: hugo -s docs --minify - name: Deploy uses: peaceiris/actions-gh-pages@v4 with: deploy_key: ${{ secrets.ACTIONS_DEPLOY_KEY }} publish_dir: ./docs/public bordeaux-threads-0.9.4/.gitignore000066400000000000000000000000351463556250700167700ustar00rootroot00000000000000docs/.hugo_build.lock public bordeaux-threads-0.9.4/.gitmodules000066400000000000000000000001701463556250700171550ustar00rootroot00000000000000[submodule "docs/themes/techdoc"] path = docs/themes/techdoc url = https://github.com/thingsym/hugo-theme-techdoc.git bordeaux-threads-0.9.4/.travis.yml000066400000000000000000000017601463556250700171170ustar00rootroot00000000000000os: linux dist: focal language: generic env: jobs: - LISP=sbcl - LISP=ccl - LISP=ecl - LISP=abcl - LISP=clisp - LISP=allegro # - LISP=sbcl32 # - lisp=ccl32 # - LISP=cmucl jobs: fast_finish: true allow_failures: - env: LISP=clisp - env: LISP=allegro # - env: LISP=sbcl32 # - env: LISP=ccl32 # - env: LISP=cmucl notifications: email: on_success: change on_failure: always irc: channels: - "chat.freenode.net#iolib" on_success: change on_failure: always use_notice: true skip_join: true install: - curl -L https://raw.githubusercontent.com/lispci/cl-travis/master/install.sh | sh script: - cl -e "(cl:in-package :cl-user) (prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri) (ql:quickload :bordeaux-threads/test :verbose t) (5am:run! :bordeaux-threads) (uiop:quit (if (5am:run! :bordeaux-threads-2) 0 -1))" bordeaux-threads-0.9.4/CONTRIBUTORS000066400000000000000000000011601463556250700166600ustar00rootroot00000000000000-*- outline -*- Based on original Bordeaux-MP spec by Dan Barlow Contributors: * Attila Lendvai - better handling of unsupported Lisps * Vladimir Sekissov - fixes for CMUCL implementation * Pierre Thierry - added license information * Stelian Ionescu - finished conversion from generic functions - enabled running thread-safe code in unthreaded lisps * Douglas Crosher - added Scieneer Common Lisp support * Daniel Kochmański - semaphores implementation bordeaux-threads-0.9.4/LICENSE000066400000000000000000000017771463556250700160230ustar00rootroot00000000000000Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. bordeaux-threads-0.9.4/README.md000066400000000000000000000005011463556250700162550ustar00rootroot00000000000000Bordeaux-Threads is a Common Lisp threading library. It exposes generic primitives required for synchronization in multi-threading programming, such as threads, mutexes, semaphores and condition variables, as well as some atomic operations. You can read its manual [here](https://sionescu.github.io/bordeaux-threads/). bordeaux-threads-0.9.4/apiv1/000077500000000000000000000000001463556250700160225ustar00rootroot00000000000000bordeaux-threads-0.9.4/apiv1/bordeaux-threads.lisp000066400000000000000000000157331463556250700221650ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS -*- ;;;; The above modeline is required for Genera. Do not change. #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (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-threading-support-error () (:documentation "Creates a BORDEAUX-THREADS condition which specifies whether there is no BORDEAUX-THREADS 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.")))) ;;; Timeouts #-sbcl (define-condition timeout (serious-condition) ((length :initform nil :initarg :length :reader timeout-length)) (:report (lambda (c s) (if (timeout-length c) (format s "A timeout set to ~A seconds occurred." (timeout-length c)) (format s "A timeout occurred."))))) #-sbcl (define-condition interrupt () ((tag :initarg :tag :reader interrupt-tag))) #-(or sbcl genera) (defmacro with-timeout ((timeout) &body body) "Execute `BODY' and signal a condition of type TIMEOUT if the execution of BODY does not complete within `TIMEOUT' seconds. On implementations which do not support WITH-TIMEOUT natively and don't support threads either it has no effect." (declare (ignorable timeout body)) #+thread-support (once-only (timeout) (with-gensyms (ok-tag interrupt-tag caller interrupt-thread c) `(let (,interrupt-thread) (unwind-protect-case () (catch ',ok-tag (let* ((,interrupt-tag (gensym "INTERRUPT-TAG-")) (,caller (current-thread))) (setf ,interrupt-thread (make-thread #'(lambda () (sleep ,timeout) (interrupt-thread ,caller #'(lambda () (signal 'interrupt :tag ,interrupt-tag)))) :name (format nil "WITH-TIMEOUT thread serving: ~S." (thread-name ,caller)))) (handler-bind ((interrupt #'(lambda (,c) (when (eql ,interrupt-tag (interrupt-tag ,c)) (error 'timeout :length ,timeout))))) (throw ',ok-tag (progn ,@body))))) (:normal (when (and ,interrupt-thread (thread-alive-p ,interrupt-thread)) ;; There's a potential race condition between THREAD-ALIVE-P ;; and DESTROY-THREAD but calling the latter when a thread already ;; terminated should not be a grave matter. (ignore-errors (destroy-thread ,interrupt-thread)))))))) #-thread-support `(error (make-threading-support-error))) ;;; Semaphores ;;; We provide this structure definition unconditionally regardless of the fact ;;; it may not be used not to prevent warnings from compiling default functions ;;; for semaphore in default-implementations.lisp. (defstruct %semaphore lock condition-variable counter) #-(or ccl sbcl) (deftype semaphore () '%semaphore) ;;; Thread Creation ;;; See default-implementations.lisp for MAKE-THREAD. ;; Forms are evaluated in the new thread or in the calling thread? (defvar *default-special-bindings* nil "This variable holds an alist associating special variable symbols to forms to evaluate. 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.") (defmacro defbindings (name docstring &body initforms) (check-type docstring string) `(defparameter ,name (list ,@(loop for (special form) in initforms collect `(cons ',special ',form))) ,docstring)) ;; Forms are evaluated in the new thread or in the calling thread? (defbindings *standard-io-bindings* "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX." (*package* (find-package :common-lisp-user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) (*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) (*print-right-margin* nil) (*random-state* (make-random-state t)) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) (*readtable* (copy-readtable nil))) (defun binding-default-specials (function special-bindings) "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls FUNCTION." (let ((specials (remove-duplicates special-bindings :from-end t :key #'car))) (named-lambda %binding-default-specials-wrapper () (progv (mapcar #'car specials) (loop for (nil . form) in specials collect (eval form)) (funcall function))))) ;;; FIXME: This test won't work if CURRENT-THREAD ;;; conses a new object each time (defun signal-error-if-current-thread (thread) (when (eq thread (current-thread)) (error 'bordeaux-mp-condition :message "Cannot destroy the current thread"))) (defparameter *no-condition-wait-timeout-message* "CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.") (defun signal-error-if-condition-wait-timeout (timeout) (when timeout (error 'bordeaux-mp-condition :message *no-condition-wait-timeout-message*))) (defmacro define-condition-wait-compiler-macro () `(define-compiler-macro condition-wait (&whole whole condition-variable lock &key timeout) (declare (ignore condition-variable lock)) (when timeout (simple-style-warning *no-condition-wait-timeout-message*)) whole)) bordeaux-threads-0.9.4/apiv1/condition-variables.lisp000066400000000000000000000020351463556250700226470ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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. (defstruct condition-var name lock active) (defun condition-wait (condition-variable lock &key timeout) (signal-error-if-condition-wait-timeout timeout) (check-type condition-variable condition-var) (setf (condition-var-active condition-variable) nil) (release-lock lock) (do () ((when (condition-var-active condition-variable) (acquire-lock lock) t)) (thread-yield)) t) (define-condition-wait-compiler-macro) (defun condition-notify (condition-variable) (check-type condition-variable condition-var) (with-lock-held ((condition-var-lock condition-variable)) (setf (condition-var-active condition-variable) t))) bordeaux-threads-0.9.4/apiv1/default-implementations.lisp000066400000000000000000000343141463556250700235520ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS -*- ;;;; The above modeline is required for Genera. Do not change. (in-package #:bordeaux-threads) ;;; Helper macros (defmacro defdfun (name args doc &body body) `(eval-when (:compile-toplevel :load-toplevel :execute) (unless (fboundp ',name) (defun ,name ,args ,@body)) (setf (documentation ',name 'function) (or (documentation ',name 'function) ,doc)))) (defmacro defdmacro (name args doc &body body) `(eval-when (:compile-toplevel :load-toplevel :execute) (unless (fboundp ',name) (defmacro ,name ,args ,@body)) (setf (documentation ',name 'function) (or (documentation ',name 'function) ,doc)))) ;;; Thread Creation (defdfun start-multiprocessing () "If the host implementation uses user-level threads, start the scheduler and multiprocessing, otherwise do nothing. It is safe to call repeatedly." nil) (defdfun make-thread (function &key name (initial-bindings *default-special-bindings*)) "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 \"Anonymous thread\" 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, such as the ones introduced by INITIAL-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." (%make-thread (binding-default-specials function initial-bindings) (or name "Anonymous thread"))) (defdfun %make-thread (function name) "The actual implementation-dependent function that creates threads." (declare (ignore function name)) (error (make-threading-support-error))) (defdfun current-thread () "Returns the thread object for the calling thread. This is the same kind of object as would be returned by MAKE-THREAD." nil) (defdfun threadp (object) "Returns true if object is a thread, otherwise NIL." (declare (ignore object)) nil) (defdfun thread-name (thread) "Returns the name of the thread, as supplied to MAKE-THREAD." (declare (ignore thread)) "Main thread") ;;; Resource contention: locks and recursive locks (defdfun lock-p (object) "Returns T if OBJECT is a lock; returns NIL otherwise." (declare (ignore object)) nil) (defdfun recursive-lock-p (object) "Returns T if OBJECT is a recursive lock; returns NIL otherwise." (declare (ignore object)) nil) (defdfun make-lock (&optional name) "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? (declare (ignore name)) (list nil)) (defdfun acquire-lock (lock &optional wait-p) "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." (declare (ignore lock wait-p)) t) (defdfun release-lock (lock) "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." (declare (ignore lock)) (values)) (defdmacro 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)))) (defdfun make-recursive-lock (&optional name) "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." (declare (ignore name)) (list nil)) (defdfun acquire-recursive-lock (lock) "As for ACQUIRE-LOCK, but for recursive locks." (declare (ignore lock)) t) (defdfun release-recursive-lock (lock) "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." (declare (ignore lock)) (values)) (defdmacro 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" (declare (ignore timeout)) `(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. (defdfun thread-yield () "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." (values)) (defdfun make-condition-variable (&key name) "Returns a new condition-variable object for use with CONDITION-WAIT and CONDITION-NOTIFY." (declare (ignore name)) nil) (defdfun condition-wait (condition-variable lock &key timeout) "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. It is an error to call function this unless from the thread that holds LOCK. If TIMEOUT is nil or not provided, the call blocks until a notification is received. If TIMEOUT is non-nil, the call will return after at most TIMEOUT seconds (approximately), whether or not a notification has occurred. Either NIL or T will be returned. A return of NIL indicates that the timeout has expired without receiving a notification. A return of T indicates that a notification was received. In an implementation that does not support multiple threads, this function signals an error." (declare (ignore condition-variable lock timeout)) (error (make-threading-support-error))) (defdfun condition-notify (condition-variable) "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." (declare (ignore condition-variable)) (values)) ;;; Resource contention: semaphores (defdfun make-semaphore (&key name (count 0)) "Create a semaphore with the supplied NAME and initial counter value COUNT." (make-%semaphore :lock (make-lock name) :condition-variable (make-condition-variable :name name) :counter count)) (defdfun signal-semaphore (semaphore &key (count 1)) "Increment SEMAPHORE by COUNT. If there are threads waiting on this semaphore, then COUNT of them are woken up." (with-lock-held ((%semaphore-lock semaphore)) (incf (%semaphore-counter semaphore) count) (dotimes (v count) (condition-notify (%semaphore-condition-variable semaphore)))) (values)) (defdfun wait-on-semaphore (semaphore &key timeout) "Decrement the count of SEMAPHORE by 1 if the count would not be negative. Else blocks until the semaphore can be decremented. Returns generalized boolean T on success. If TIMEOUT is given, it is the maximum number of seconds to wait. If the count cannot be decremented in that time, returns NIL without decrementing the count." (with-lock-held ((%semaphore-lock semaphore)) (if (>= (%semaphore-counter semaphore) 1) (decf (%semaphore-counter semaphore)) (let ((deadline (when timeout (+ (get-internal-real-time) (* timeout internal-time-units-per-second))))) ;; we need this loop because of a spurious wakeup possibility (loop until (>= (%semaphore-counter semaphore) 1) do (cond ((null (condition-wait (%semaphore-condition-variable semaphore) (%semaphore-lock semaphore) :timeout timeout)) (return-from wait-on-semaphore)) ;; unfortunately cv-wait may return T on timeout too ((and deadline (>= (get-internal-real-time) deadline)) (return-from wait-on-semaphore)) (timeout (setf timeout (/ (- deadline (get-internal-real-time)) internal-time-units-per-second))))) (decf (%semaphore-counter semaphore)))))) (defdfun semaphore-p (object) "Returns T if OBJECT is a semaphore; returns NIL otherwise." (typep object 'semaphore)) ;;; Introspection/debugging ;;; The following functions may be provided for debugging purposes, ;;; but are not advised to be called from normal user code. (defdfun all-threads () "Returns a sequence of all of the threads. This may not be freshly-allocated, so the caller should not modify it." (error (make-threading-support-error))) (defdfun interrupt-thread (thread function) "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." (declare (ignore thread function)) (error (make-threading-support-error))) (defdfun destroy-thread (thread) "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." (declare (ignore thread)) (error (make-threading-support-error))) (defdfun thread-alive-p (thread) "Returns true if THREAD is alive, that is, if DESTROY-THREAD has not been called on it." (declare (ignore thread)) (error (make-threading-support-error))) (defdfun join-thread (thread) "Wait until THREAD terminates. If THREAD has already terminated, return immediately. The return values of the thread function are returned." (declare (ignore thread)) (error (make-threading-support-error))) bordeaux-threads-0.9.4/apiv1/impl-abcl.lisp000066400000000000000000000103641463556250700205570ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011. Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; the implementation of the Armed Bear thread interface can be found in ;;; src/org/armedbear/lisp/LispThread.java (deftype thread () 'threads:thread) ;;; Thread Creation (defun %make-thread (function name) (threads:make-thread function :name name)) (defun current-thread () (threads:current-thread)) (defun thread-name (thread) (threads:thread-name thread)) (defun threadp (object) (typep object 'thread)) ;;; Resource contention: locks and recursive locks (defstruct mutex name lock) (defstruct (mutex-recursive (:include mutex))) ;; Making methods constants in this manner avoids the runtime expense of ;; introspection involved in JCALL with string arguments. (defconstant +lock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "lock")) (defconstant +try-lock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock")) (defconstant +is-held-by-current-thread+ (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread")) (defconstant +unlock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock")) (defconstant +get-hold-count+ (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount")) (deftype lock () 'mutex) (deftype recursive-lock () 'mutex-recursive) (defun lock-p (object) (typep object 'mutex)) (defun recursive-lock-p (object) (typep object 'mutex-recursive)) (defun make-lock (&optional name) (make-mutex :name (or name "Anonymous lock") :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) (defun acquire-lock (lock &optional (wait-p t)) (check-type lock mutex) (when (jcall +is-held-by-current-thread+ (mutex-lock lock)) (error "Non-recursive lock being reacquired by owner.")) (cond (wait-p (jcall +lock+ (mutex-lock lock)) t) (t (jcall +try-lock+ (mutex-lock lock))))) (defun release-lock (lock) (check-type lock mutex) (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) (error "Attempt to release lock not held by calling thread.")) (jcall +unlock+ (mutex-lock lock)) (values)) (defun make-recursive-lock (&optional name) (make-mutex-recursive :name (or name "Anonymous lock") :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) (defun acquire-recursive-lock (lock &optional (wait-p t)) (check-type lock mutex-recursive) (cond (wait-p (jcall +lock+ (mutex-recursive-lock lock)) t) (t (jcall +try-lock+ (mutex-recursive-lock lock))))) (defun release-recursive-lock (lock) (check-type lock mutex-recursive) (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) (error "Attempt to release lock not held by calling thread.")) (jcall +unlock+ (mutex-lock lock)) (values)) ;;; Resource contention: condition variables (defun thread-yield () (java:jstatic "yield" "java.lang.Thread")) (defstruct condition-variable (name "Anonymous condition variable")) (defun condition-wait (condition lock &key timeout) (threads:synchronized-on condition (release-lock lock) (if timeout ;; Since giving a zero time value to threads:object-wait means ;; an indefinite wait, use some arbitrary small number. (threads:object-wait condition (if (zerop timeout) least-positive-single-float timeout)) (threads:object-wait condition))) (acquire-lock lock) t) (defun condition-notify (condition) (threads:synchronized-on condition (threads:object-notify condition))) ;;; Introspection/debugging (defun all-threads () (let ((threads ())) (threads:mapcar-threads (lambda (thread) (push thread threads))) (reverse threads))) (defun interrupt-thread (thread function &rest args) (apply #'threads:interrupt-thread thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (threads:destroy-thread thread)) (defun thread-alive-p (thread) (threads:thread-alive-p thread)) (defun join-thread (thread) (threads:thread-join thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-allegro.lisp000066400000000000000000000073031463556250700213020ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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/8.1/doc/multiprocessing.htm ;;; Resource contention: locks and recursive locks (deftype lock () 'mp:process-lock) (deftype recursive-lock () 'mp:process-lock) (defun lock-p (object) (typep object 'mp:process-lock)) (defun recursive-lock-p (object) (typep object 'mp:process-lock)) (defun make-lock (&optional name) (mp:make-process-lock :name (or name "Anonymous lock"))) (defun make-recursive-lock (&optional name) (mp:make-process-lock :name (or name "Anonymous recursive lock"))) (defun acquire-lock (lock &optional (wait-p t)) (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0))) (defun release-lock (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 (defun make-condition-variable (&key name) (declare (ignorable name)) #-(version>= 9) (mp:make-gate nil) #+(version>= 9) (mp:make-condition-variable :name name)) (defun condition-wait (condition-variable lock &key timeout) #-(version>= 9) (progn (release-lock lock) (if timeout (mp:process-wait-with-timeout "wait for message" timeout #'mp:gate-open-p condition-variable) (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable)) (acquire-lock lock) (mp:close-gate condition-variable)) #+(version>= 9) (mp:condition-variable-wait condition-variable lock :timeout timeout) t) (defun condition-notify (condition-variable) #-(version>= 9) (mp:open-gate condition-variable) #+(version>= 9) (mp:condition-variable-signal condition-variable)) (defun thread-yield () (mp:process-allow-schedule)) (deftype thread () 'mp:process) ;;; Thread Creation (defun start-multiprocessing () (mp:start-scheduler)) (defun %make-thread (function name) #+smp (mp:process-run-function name function) #-smp (mp:process-run-function name (named-lambda %join-thread-wrapper () (let ((return-values (multiple-value-list (funcall function)))) (setf (getf (mp:process-property-list mp:*current-process*) 'return-values) return-values) (values-list return-values))))) (defun current-thread () mp:*current-process*) (defun threadp (object) (typep object 'mp:process)) (defun thread-name (thread) (mp:process-name thread)) ;;; Timeouts (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) ;;; Introspection/debugging (defun all-threads () mp:*all-processes*) (defun interrupt-thread (thread function &rest args) (apply #'mp:process-interrupt thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mp:process-kill thread)) (defun thread-alive-p (thread) (mp:process-alive-p thread)) (defun join-thread (thread) #+smp (values-list (mp:process-join thread)) #-smp (progn (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread) (let ((return-values (getf (mp:process-property-list thread) 'return-values))) (values-list return-values)))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-clasp.lisp000066400000000000000000000053011463556250700207530ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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 (deftype thread () 'mp:process) ;;; Thread Creation (defun %make-thread (function name) (mp:process-run-function name function bordeaux-threads:*default-special-bindings*)) (defun current-thread () mp:*current-process*) (defun threadp (object) (typep object 'mp:process)) (defun thread-name (thread) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mp:mutex) (deftype recursive-lock () '(and mp:mutex (satisfies mp:recursive-lock-p))) (defun lock-p (object) (typep object 'mp:mutex)) (defun recursive-lock-p (object) (and (typep object 'mp:mutex) (mp:recursive-lock-p object))) (defun make-lock (&optional name) (mp:make-lock :name (or name :anonymous))) (defun acquire-lock (lock &optional (wait-p t)) (mp:get-lock lock wait-p)) (defun release-lock (lock) (mp:giveup-lock lock)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) (defun make-recursive-lock (&optional name) (mp:make-recursive-mutex (or name :anonymous-recursive-lock))) (defun acquire-recursive-lock (lock &optional (wait-p t)) (mp:get-lock lock wait-p)) (defun release-recursive-lock (lock) (mp:giveup-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (declare (ignore name)) (mp:make-condition-variable)) (defun condition-wait (condition-variable lock &key timeout) (if timeout (mp:condition-variable-timedwait condition-variable lock timeout) (mp:condition-variable-wait condition-variable lock)) t) (defun condition-notify (condition-variable) (mp:condition-variable-signal condition-variable)) (defun thread-yield () (mp:process-yield)) ;;; Introspection/debugging (defun all-threads () (mp:all-processes)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (mp:interrupt-process thread (apply-function)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mp:process-kill thread)) (defun thread-alive-p (thread) (mp:process-active-p thread)) (defun join-thread (thread) (mp:process-join thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-clisp.lisp000066400000000000000000000054121463556250700207660ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'mt:thread) ;;; Thread Creation (defun %make-thread (function name) (mt:make-thread function :name name :initial-bindings mt:*default-special-bindings*)) (defun current-thread () (mt:current-thread)) (defun threadp (object) (mt:threadp object)) (defun thread-name (thread) (mt:thread-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mt:mutex) (deftype recursive-lock () '(and mt:mutex (satisfies mt:mutex-recursive-p))) (defun lock-p (object) (typep object 'mt:mutex)) (defun recursive-lock-p (object) (and (typep object 'mt:mutex) (mt:mutex-recursive-p object))) (defun make-lock (&optional name) (mt:make-mutex :name (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (mt:mutex-lock lock :timeout (if wait-p nil 0))) (defun release-lock (lock) (mt:mutex-unlock lock)) (defmacro with-lock-held ((place) &body body) `(mt:with-mutex-lock (,place) ,@body)) (defun make-recursive-lock (&optional name) (mt:make-mutex :name (or name "Anonymous recursive lock") :recursive-p t)) (defun acquire-recursive-lock (lock &optional (wait-p t)) (acquire-lock lock wait-p)) (defun release-recursive-lock (lock) (release-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(mt:with-mutex-lock (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (mt:make-exemption :name (or name "Anonymous condition variable"))) (defun condition-wait (condition-variable lock &key timeout) (mt:exemption-wait condition-variable lock :timeout timeout) t) (defun condition-notify (condition-variable) (mt:exemption-signal condition-variable)) (defun thread-yield () (mt:thread-yield)) ;;; Timeouts (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) ;;; Introspection/debugging ;;; VTZ: mt:list-threads returns all threads that are not garbage collected. (defun all-threads () (delete-if-not #'mt:thread-active-p (mt:list-threads))) (defun interrupt-thread (thread function &rest args) (mt:thread-interrupt thread :function function :arguments args)) (defun destroy-thread (thread) ;;; VTZ: actually we can kill ourselelf. ;;; suicide is part of our contemporary life :) (signal-error-if-current-thread thread) (mt:thread-interrupt thread :function t)) (defun thread-alive-p (thread) (mt:thread-active-p thread)) (defun join-thread (thread) (values-list (mt:thread-join thread))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-clozure.lisp000066400000000000000000000056471463556250700213510ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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 (deftype thread () 'ccl:process) ;;; Thread Creation (defun %make-thread (function name) (ccl:process-run-function name function)) (defun current-thread () ccl:*current-process*) (defun threadp (object) (typep object 'ccl:process)) (defun thread-name (thread) (ccl:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'ccl:lock) (deftype recursive-lock () 'ccl:lock) (defun lock-p (object) (typep object 'ccl:lock)) (defun recursive-lock-p (object) (typep object 'ccl:lock)) (defun make-lock (&optional name) (ccl:make-lock (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (if wait-p (ccl:grab-lock lock) (ccl:try-lock lock))) (defun release-lock (lock) (ccl:release-lock lock)) (defmacro with-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) (defun make-recursive-lock (&optional name) (ccl:make-lock (or name "Anonymous recursive lock"))) (defun acquire-recursive-lock (lock) (ccl:grab-lock lock)) (defun release-recursive-lock (lock) (ccl:release-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (declare (ignore name)) (ccl:make-semaphore)) (defun condition-wait (condition-variable lock &key timeout) (release-lock lock) (unwind-protect (if timeout (ccl:timed-wait-on-semaphore condition-variable timeout) (ccl:wait-on-semaphore condition-variable)) (acquire-lock lock t)) t) (defun condition-notify (condition-variable) (ccl:signal-semaphore condition-variable)) (defun thread-yield () (ccl:process-allow-schedule)) ;;; Semaphores (deftype semaphore () 'ccl:semaphore) (defun make-semaphore (&key name (count 0)) (declare (ignore name)) (ccl:make-semaphore :count count)) (defun signal-semaphore (semaphore &key (count 1)) (dotimes (c count) (ccl:signal-semaphore semaphore))) (defun wait-on-semaphore (semaphore &key timeout) (if timeout (ccl:timed-wait-on-semaphore semaphore timeout) (ccl:wait-on-semaphore semaphore))) ;;; Introspection/debugging (defun all-threads () (ccl:all-processes)) (defun interrupt-thread (thread function &rest args) (declare (dynamic-extent args)) (apply #'ccl:process-interrupt thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (ccl:process-kill thread)) (defun thread-alive-p (thread) (not (ccl:process-exhausted-p thread))) (defun join-thread (thread) (ccl:join-process thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-cmucl.lisp000066400000000000000000000114461463556250700207630ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'mp::process) ;;; Thread Creation (defun start-multiprocessing () (mp::startup-idle-and-top-level-loops)) (defun %make-thread (function name) #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (mp:make-process function :name name) #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (mp:make-process (named-lambda %join-thread-wrapper () (let ((return-values (multiple-value-list (funcall function)))) (setf (getf (mp:process-property-list mp:*current-process*) 'return-values) return-values) (values-list return-values))) :name name)) (defun current-thread () mp:*current-process*) (defun threadp (object) (mp:processp object)) (defun thread-name (thread) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mp::error-check-lock) (deftype recursive-lock () 'mp::recursive-lock) (defun lock-p (object) (typep object 'mp::error-check-lock)) (defun recursive-lock-p (object) (typep object 'mp::recursive-lock)) (defun make-lock (&optional name) (mp:make-lock (or name "Anonymous lock") :kind :error-check)) (defun acquire-lock (lock &optional (wait-p t)) (if wait-p (mp::lock-wait lock "Lock wait") (mp::lock-wait-with-timeout lock "Lock wait" 0))) (defun release-lock (lock) (setf (mp::lock-process lock) nil)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock-held (,place "Lock wait") ,@body)) (defun make-recursive-lock (&optional name) (mp:make-lock (or name "Anonymous recursive lock") :kind :recursive)) (defun acquire-recursive-lock (lock &optional (wait-p t)) (acquire-lock lock)) (defun release-recursive-lock (lock) (release-lock lock)) (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. (defstruct condition-var "CMUCL doesn't have conditions, so we need to create our own type." name lock active) (defun make-condition-variable (&key name) (make-condition-var :lock (make-lock) :name (or name "Anonymous condition variable"))) (defun condition-wait (condition-variable lock &key timeout) (signal-error-if-condition-wait-timeout timeout) (check-type condition-variable condition-var) (with-lock-held ((condition-var-lock condition-variable)) (setf (condition-var-active condition-variable) nil)) (release-lock lock) (mp:process-wait "Condition Wait" #'(lambda () (condition-var-active condition-variable))) (acquire-lock lock) t) (defun condition-notify (condition-variable) (check-type condition-variable condition-var) (with-lock-held ((condition-var-lock condition-variable)) (setf (condition-var-active condition-variable) t)) (thread-yield)) (defun thread-yield () (mp:process-yield)) ;;; Timeouts (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) ;;; Introspection/debugging (defun all-threads () (mp:all-processes)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (lambda () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (mp:process-interrupt thread (apply-function)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mp:destroy-process thread)) (defun thread-alive-p (thread) (mp:process-active-p thread)) (defun join-thread (thread) #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (mp:process-join thread) #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (progn (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (lambda () (not (mp:process-alive-p thread)))) (let ((return-values (getf (mp:process-property-list thread) 'return-values))) (values-list return-values)))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-corman.lisp000066400000000000000000000007551463556250700211400ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) ;;; Thread Creation (defun %make-thread (function name) (declare (ignore name)) (threads:create-thread function)) (defun current-thread () threads:*current-thread*) ;;; Introspection/debugging (defun destroy-thread (thread) (signal-error-if-current-thread thread) (threads:terminate-thread thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-ecl.lisp000066400000000000000000000061371463556250700204240ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (eval-when (:compile-toplevel :execute) (when (>= ext:+ecl-version-number+ 230909) (pushnew :has-timeouts *features*))) ;;; documentation on the ECL Multiprocessing interface can be found at ;;; https://ecl.common-lisp.dev/static/manual/Native-threads.html (deftype thread () 'mp:process) ;;; Thread Creation (defun %make-thread (function name) (mp:process-run-function name function)) (defun current-thread () mp::*current-process*) (defun threadp (object) (typep object 'mp:process)) (defun thread-name (thread) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mp:lock) (deftype recursive-lock () '(and mp:lock (satisfies mp:recursive-lock-p))) (defun lock-p (object) (typep object 'mp:lock)) (defun recursive-lock-p (object) (and (typep object 'mp:lock) (mp:recursive-lock-p object))) (defun make-lock (&optional name) (mp:make-lock :name (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (mp:get-lock lock wait-p)) (defun release-lock (lock) (mp:giveup-lock lock)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) (defun make-recursive-lock (&optional name) (mp:make-lock :name (or name "Anonymous recursive lock") :recursive t)) (defun acquire-recursive-lock (lock &optional (wait-p t)) (mp:get-lock lock wait-p)) (defun release-recursive-lock (lock) (mp:giveup-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (declare (ignore name)) (mp:make-condition-variable)) (defun condition-wait (condition-variable lock &key timeout) (if timeout #-has-timeouts (handler-case (with-timeout (timeout) (mp:condition-variable-wait condition-variable lock)) (timeout () (acquire-lock lock) nil)) #+has-timeouts (mp:condition-variable-timedwait condition-variable lock timeout) (mp:condition-variable-wait condition-variable lock))) (defun condition-notify (condition-variable) (mp:condition-variable-signal condition-variable)) (defun thread-yield () (mp:process-yield)) ;;; Introspection/debugging (defun all-threads () (mp:all-processes)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (mp:interrupt-process thread (apply-function)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mp:process-kill thread)) (defun thread-alive-p (thread) (mp:process-active-p thread)) (defun join-thread (thread) (mp:process-join thread)) (eval-when (:compile-toplevel :execute) (setf *features* (remove :has-timeouts *features*))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-genera.lisp000066400000000000000000000167431463556250700211260ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*- #| Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'process:process) (defvar *thread-recursive-lock-key* 0) ;;; Thread Creation (defun %make-thread (function name) (flet ((top-level () (let* ((*thread-recursive-lock-key* 0) (return-values (multiple-value-list (funcall function)))) (setf (si:process-spare-slot-4 scl:*current-process*) return-values) (values-list return-values)))) (declare (dynamic-extent #'top-level)) (process:process-run-function name #'top-level))) (defun current-thread () scl:*current-process*) (defun threadp (object) (process:process-p object)) (defun thread-name (thread) (process:process-name thread)) ;;; Resource contention: locks and recursive locks (defstruct (lock (:constructor make-lock-internal)) lock lock-argument) (defun make-lock (&optional name) (let ((lock (process:make-lock (or name "Anonymous lock")))) (make-lock-internal :lock lock :lock-argument nil))) (defun acquire-lock (lock &optional (wait-p t)) (check-type lock lock) (let ((lock-argument (process:make-lock-argument (lock-lock lock)))) (cond (wait-p (process:with-no-other-processes (process:lock (lock-lock lock) lock-argument) (setf (lock-lock-argument lock) lock-argument) t)) (t (process:with-no-other-processes (when (process:lock-lockable-p (lock-lock lock)) (process:lock (lock-lock lock) lock-argument) (setf (lock-lock-argument lock) lock-argument) t)))))) (defun release-lock (lock) (check-type lock lock) (process:with-no-other-processes (process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil)))) (defstruct (recursive-lock (:constructor make-recursive-lock-internal)) lock lock-arguments) (defun make-recursive-lock (&optional name) (make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock") :recursive t) :lock-arguments (make-hash-table :test #'equal))) (defun acquire-recursive-lock (lock) (check-type lock recursive-lock) (acquire-recursive-lock-internal lock)) (defun acquire-recursive-lock-internal (lock &optional timeout) (let ((key (cons (incf *thread-recursive-lock-key*) scl:*current-process*)) (lock-argument (process:make-lock-argument (recursive-lock-lock lock)))) (cond (timeout (process:with-no-other-processes (when (process:lock-lockable-p (recursive-lock-lock lock)) (process:lock (recursive-lock-lock lock) lock-argument) (setf (gethash key (recursive-lock-lock-arguments lock)) lock-argument) t))) (t (process:with-no-other-processes (process:lock (recursive-lock-lock lock) lock-argument) (setf (gethash key (recursive-lock-lock-arguments lock)) lock-argument) t))))) (defun release-recursive-lock (lock) (check-type lock recursive-lock) (let* ((key (cons *thread-recursive-lock-key* scl:*current-process*)) (lock-argument (gethash key (recursive-lock-lock-arguments lock)))) (process:with-no-other-processes (prog1 (process:unlock (recursive-lock-lock lock) lock-argument) (decf *thread-recursive-lock-key*) (remhash key (recursive-lock-lock-arguments lock)))))) (defmacro with-recursive-lock-held ((place &key timeout) &body body) `(with-recursive-lock-held-internal ,place ,timeout #'(lambda () ,@body))) (defun with-recursive-lock-held-internal (lock timeout function) (check-type lock recursive-lock) (assert (typep timeout '(or null (satisfies zerop))) (timeout) 'bordeaux-mp-condition :message ":TIMEOUT value must be either NIL or 0") (when (acquire-recursive-lock-internal lock timeout) (unwind-protect (funcall function) (release-recursive-lock lock)))) ;;; Resource contention: condition variables (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (condition-variable (:constructor %make-condition-variable)) name (waiters nil)) ) (defun make-condition-variable (&key name) (%make-condition-variable :name name)) (defun condition-wait (condition-variable lock &key timeout) (check-type condition-variable condition-variable) (check-type lock lock) (process:with-no-other-processes (let ((waiter (cons scl:*current-process* nil))) (process:atomic-updatef (condition-variable-waiters condition-variable) #'(lambda (waiters) (append waiters (scl:ncons waiter)))) (let ((expired? t)) (unwind-protect (progn (release-lock lock) (process:block-with-timeout timeout (format nil "Waiting~@[ on ~A~]" (condition-variable-name condition-variable)) #'(lambda (waiter expired?-loc) (when (not (null (cdr waiter))) (setf (sys:location-contents expired?-loc) nil) t)) waiter (sys:value-cell-location 'expired?)) expired?) (unless expired? (acquire-lock lock))))))) (defun condition-notify (condition-variable) (check-type condition-variable condition-variable) (let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable)))) (when waiter (setf (cdr waiter) t) (process:wakeup (car waiter)))) (values)) (defun thread-yield () (scl:process-allow-schedule)) ;;; Timeouts (defmacro with-timeout ((timeout) &body body) "Execute `BODY' and signal a condition of type TIMEOUT if the execution of BODY does not complete within `TIMEOUT' seconds." `(with-timeout-internal ,timeout #'(lambda () ,@body))) (defun with-timeout-internal (timeout function) ;; PROCESS:WITH-TIMEOUT either returns NIL on timeout or signals an error which, ;; unforutnately, does not have a distinguished type (i.e., it's a SYS:FATAL-ERROR). ;; So, rather than try to catch the error and signal our condition, we instead ;; ensure the return value from the PROCESS:WITH-TIMEOUT is never NIL if there is ;; no timeout. (Sigh) (let ((result (process:with-timeout (timeout) (cons 'success (multiple-value-list (funcall function)))))) (if result (values-list (cdr result)) (error 'timeout :length timeout)))) ;;; Introspection/debugging (defun all-threads () process:*all-processes*) (defun interrupt-thread (thread function &rest args) (declare (dynamic-extent args)) (apply #'process:process-interrupt thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (process:process-kill thread :force)) (defun thread-alive-p (thread) (process:process-active-p thread)) (defun join-thread (thread) (process:process-wait (format nil "Join ~S" thread) #'(lambda (thread) (not (process:process-active-p thread))) thread) (values-list (si:process-spare-slot-4 thread))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-lispworks-condition-variables.lisp000066400000000000000000000157441463556250700256540ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package #:bordeaux-threads) ;; Lispworks condition support is simulated, albeit via a lightweight wrapper over ;; its own polling-based wait primitive. Waiters register with the condition variable, ;; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval. ;; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm ;; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup ;; on every poll (or have to serialize on the condition variable) and a mechanism is put ;; in place to unregister any waiter that exits wait for other reasons, ;; and to resend any (single) notification that may have been consumed before this (corner ;; case). Much of the complexity present is to support single notification (as recommended in ;; the spec); but a distinct condition-notify-all is provided for reference. ;; Single-notification follows a first-in first-out ordering ;; ;; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least ;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager. ;; While not true zero like a true native solution, the use of the Lispworks native checks appear ;; fast enough to be an equivalent substitute (thread count will cause issue before the ;; waiting overhead becomes significant) (defstruct (condition-variable (:constructor make-lw-condition (name))) name (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t) (wait-tlist (cons nil nil) :type cons :read-only t) (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t) ;; unconsumed-notifications is to track :remove-from-consideration ;; for entries that may have exited prematurely - notification is sent through ;; to someone else, and offender is removed from hash and list (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t)) (defun make-condition-variable (&key name) (make-lw-condition name)) (defmacro with-cv-access (condition-variable &body body) (let ((cv-sym (gensym)) (slots '(lock wait-tlist wait-hash unconsumed-notifications))) `(let ((,cv-sym ,condition-variable)) (with-slots ,slots ,cv-sym (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body))) (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore ,@body))))) (defmacro defcvfun (function-name (condition-variable &rest args) &body body) `(defun ,function-name (,condition-variable ,@args) (with-cv-access ,condition-variable ,@body))) #+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun ; utility function thath assumes process is locked on condition-variable's lock. (defcvfun do-notify-single (condition-variable) ; assumes already locked (let ((id (caar wait-tlist))) (when id (pop (car wait-tlist)) (unless (car wait-tlist) ; check for empty (setf (cdr wait-tlist) nil)) (funcall (gethash id wait-hash)) ; call waiter-wakeup (remhash id wait-hash) ; absence of entry = permission to proceed (setf (gethash id unconsumed-notifications) t)))) ;; Added for completeness/to show how it's done in this paradigm; but ;; The symbol for this call is not exposed in the api (defcvfun condition-notify-all (condition-variable) (locked (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup)) (clrhash wait-hash) (clrhash unconsumed-notifications) ; don't care as everyone just got notified (setf (car wait-tlist) nil) (setf (cdr wait-tlist) nil))) ;; Currently implemented so as to notify only one waiting thread (defcvfun condition-notify (condition-variable) (locked (do-notify-single condition-variable))) (defun delete-from-tlist (tlist element) (let ((deleter (lambda () (setf (car tlist) (cdar tlist)) (unless (car tlist) (setf (cdr tlist) nil))))) (loop for cons in (car tlist) do (if (eq element (car cons)) (progn (funcall deleter) (return nil)) (let ((cons cons)) (setq deleter (lambda () (setf (cdr cons) (cddr cons)) (unless (cdr cons) (setf (cdr tlist) cons))))))))) (defun add-to-tlist-tail (tlist element) (let ((new-link (cons element nil))) (cond ((car tlist) (setf (cddr tlist) new-link) (setf (cdr tlist) new-link)) (t (setf (car tlist) new-link) (setf (cdr tlist) new-link))))) (defcvfun condition-wait (condition-variable lock- &key timeout) (signal-error-if-condition-wait-timeout timeout) (mp:process-unlock lock-) (unwind-protect ; for the re-taking of the lock. Guarding all of the code (let ((wakeup-allowed-to-proceed nil) (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait"))) ;; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and ;; search the hashtable. That it is locked is for safety/completeness, although ;; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is ;; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became ;; non-atomic in its assigments (let ((id (cons nil nil)) (clean-exit nil)) (locked (add-to-tlist-tail wait-tlist id) (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t))))) (unwind-protect (progn (mp:process-wait "Waiting for notification" (lambda () (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed) (locked (not (gethash id wait-hash)))))) (locked (remhash id unconsumed-notifications)) (setq clean-exit t)) ; Notification was consumed ;; Have to call remove-from-consideration just in case process was interrupted ;; rather than having condition met (unless clean-exit ; clean-exit is just an optimization (locked (when (gethash id wait-hash) ; not notified - must have been interrupted ;; Have to unsubscribe (remhash id wait-hash) (delete-from-tlist wait-tlist id)) ;; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification! (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter (do-notify-single condition-variable))))))) (mp:process-lock lock-)) t) (define-condition-wait-compiler-macro) bordeaux-threads-0.9.4/apiv1/impl-lispworks.lisp000066400000000000000000000077271463556250700217240ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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 (deftype thread () 'mp:process) ;;; Thread Creation (defun start-multiprocessing () (mp:initialize-multiprocessing)) (defun %make-thread (function name) (mp:process-run-function name nil (named-lambda %join-thread-wrapper () (let ((return-values (multiple-value-list (funcall function)))) (setf (mp:process-property 'return-values) return-values) (values-list return-values))))) (defun current-thread () #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) mp:*current-process* ;; introduced in LispWorks 5.1 #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) (mp:get-current-process)) (defun threadp (object) (mp:process-p object)) (defun thread-name (thread) (mp:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mp:lock) #-(or lispworks4 lispworks5) (deftype recursive-lock () '(and mp:lock (satisfies mp:lock-recursive-p))) (defun lock-p (object) (typep object 'mp:lock)) (defun recursive-lock-p (object) #+(or lispworks4 lispworks5) nil #-(or lispworks4 lispworks5) ; version 6+ (and (typep object 'mp:lock) (mp:lock-recursive-p object))) (defun make-lock (&optional name) (mp:make-lock :name (or name "Anonymous lock") #-(or lispworks4 lispworks5) :recursivep #-(or lispworks4 lispworks5) nil)) (defun acquire-lock (lock &optional (wait-p t)) (mp:process-lock lock nil (cond ((null wait-p) 0) ((numberp wait-p) wait-p) (t nil)))) (defun release-lock (lock) (mp:process-unlock lock)) (defmacro with-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) (defun make-recursive-lock (&optional name) (mp:make-lock :name (or name "Anonymous recursive lock") #-(or lispworks4 lispworks5) :recursivep #-(or lispworks4 lispworks5) t)) (defun acquire-recursive-lock (lock &optional (wait-p t)) (acquire-lock lock wait-p)) (defun release-recursive-lock (lock) (release-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(mp:with-lock (,place) ,@body)) ;;; Resource contention: condition variables #-(or lispworks4 lispworks5) (defun make-condition-variable (&key name) (mp:make-condition-variable :name (or name "Anonymous condition variable"))) #-(or lispworks4 lispworks5) (defun condition-wait (condition-variable lock &key timeout) (mp:condition-variable-wait condition-variable lock :timeout timeout)) #-(or lispworks4 lispworks5) (defun condition-notify (condition-variable) (mp:condition-variable-signal condition-variable)) (defun thread-yield () (mp:process-allow-scheduling)) ;;; Introspection/debugging (defun all-threads () (mp:list-all-processes)) (defun interrupt-thread (thread function &rest args) (apply #'mp:process-interrupt thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mp:process-kill thread)) (defun thread-alive-p (thread) (mp:process-alive-p thread)) (declaim (inline %join-thread)) (defun %join-thread (thread) #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread) #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) (mp:process-join thread)) (defun join-thread (thread) (%join-thread thread) (let ((return-values (mp:process-property 'return-values thread))) (values-list return-values))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-mcl.lisp000066400000000000000000000027441463556250700204340ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'ccl::process) ;;; Thread Creation (defun %make-thread (function name) (ccl:process-run-function name function)) (defun current-thread () ccl:*current-process*) (defun threadp (object) (ccl::processp object)) (defun thread-name (thread) (ccl:process-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'ccl:lock) (defun lock-p (object) (typep object 'ccl:lock)) (defun make-lock (&optional name) (ccl:make-lock (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (if wait-p (ccl:process-lock lock ccl:*current-process*) ;; this is broken, but it's better than a no-op (ccl:without-interrupts (when (null (ccl::lock.value lock)) (ccl:process-lock lock ccl:*current-process*))))) (defun release-lock (lock) (ccl:process-unlock lock)) (defmacro with-lock-held ((place) &body body) `(ccl:with-lock-grabbed (,place) ,@body)) (defun thread-yield () (ccl:process-allow-schedule)) ;;; Introspection/debugging (defun all-threads () ccl:*all-processes*) (defun interrupt-thread (thread function &rest args) (declare (dynamic-extent args)) (apply #'ccl:process-interrupt thread function args)) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (ccl:process-kill thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-mezzano.lisp000066400000000000000000000070351463556250700213420ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Copyright 2016 Henry Harrington Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'mezzano.supervisor:thread) ;;; Thread Creation (defun %make-thread (function name) (mezzano.supervisor:make-thread function :name name)) (defun current-thread () (mezzano.supervisor:current-thread)) (defun threadp (object) (mezzano.supervisor:threadp object)) (defun thread-name (thread) (mezzano.supervisor:thread-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mezzano.supervisor:mutex) (defun lock-p (object) (mezzano.supervisor:mutex-p object)) (defun make-lock (&optional name) (mezzano.supervisor:make-mutex name)) (defun acquire-lock (lock &optional (wait-p t)) (mezzano.supervisor:acquire-mutex lock wait-p)) (defun release-lock (lock) (mezzano.supervisor:release-mutex lock)) (defmacro with-lock-held ((place) &body body) `(mezzano.supervisor:with-mutex (,place) ,@body)) (defstruct (recursive-lock (:constructor make-recursive-lock (&optional name &aux (mutex (mezzano.supervisor:make-mutex name))))) mutex (depth 0)) (defun call-with-recursive-lock-held (lock function) (cond ((mezzano.supervisor:mutex-held-p (recursive-lock-mutex lock)) (unwind-protect (progn (incf (recursive-lock-depth lock)) (funcall function)) (decf (recursive-lock-depth lock)))) (t (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock)) (multiple-value-prog1 (funcall function) (assert (zerop (recursive-lock-depth lock)))))))) (defmacro with-recursive-lock-held ((place) &body body) `(call-with-recursive-lock-held ,place (lambda () ,@body))) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (mezzano.supervisor:make-condition-variable name)) (defun condition-wait (condition-variable lock &key timeout) (mezzano.supervisor:condition-wait condition-variable lock timeout)) (defun condition-notify (condition-variable) (mezzano.supervisor:condition-notify condition-variable)) (defun thread-yield () (mezzano.supervisor:thread-yield)) ;;; Timeouts ;;; Semaphores (deftype semaphore () 'mezzano.sync:semaphore) (defun make-semaphore (&key name (count 0)) (mezzano.sync:make-semaphore :name name :value count)) (defun signal-semaphore (semaphore &key (count 1)) (dotimes (c count) (mezzano.sync:semaphore-up semaphore))) (defun wait-on-semaphore (semaphore &key timeout) (mezzano.supervisor:event-wait-for (semaphore :timeout timeout) (mezzano.sync:semaphore-down semaphore :wait-p nil))) ;;; Introspection/debugging (defun all-threads () (mezzano.supervisor:all-threads)) (defun interrupt-thread (thread function &rest args) (mezzano.supervisor:establish-thread-foothold thread (named-lambda %interrupt-thread-wrapper () (apply function args)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mezzano.supervisor:terminate-thread thread)) (defun thread-alive-p (thread) (not (eql (mezzano.supervisor:thread-state thread) :dead))) (defun join-thread (thread) (signal-error-if-current-thread thread) ;; THREAD-JOIN can return non-lists if the thread was destroyed. (let ((values (mezzano.supervisor:thread-join thread))) (if (listp values) (values-list values) nil))) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-mkcl.lisp000066400000000000000000000050251463556250700206020ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2006, 2007 Greg Pfeil Copyright 2010 Jean-Claude Beaudoin. Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'mt:thread) ;;; Thread Creation (defun %make-thread (function name) (mt:thread-run-function name function)) (defun current-thread () mt::*thread*) (defun threadp (object) (typep object 'mt:thread)) (defun thread-name (thread) (mt:thread-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'mt:lock) (deftype recursive-lock () '(and mt:lock (satisfies mt:recursive-lock-p))) (defun lock-p (object) (typep object 'mt:lock)) (defun recursive-lock-p (object) (and (typep object 'mt:lock) (mt:recursive-lock-p object))) (defun make-lock (&optional name) (mt:make-lock :name (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (mt:get-lock lock wait-p)) (defun release-lock (lock) (mt:giveup-lock lock)) (defmacro with-lock-held ((place) &body body) `(mt:with-lock (,place) ,@body)) (defun make-recursive-lock (&optional name) (mt:make-lock :name (or name "Anonymous recursive lock") :recursive t)) (defun acquire-recursive-lock (lock &optional (wait-p t)) (mt:get-lock lock wait-p)) (defun release-recursive-lock (lock) (mt:giveup-lock lock)) (defmacro with-recursive-lock-held ((place) &body body) `(mt:with-lock (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (declare (ignore name)) (mt:make-condition-variable)) (defun condition-wait (condition-variable lock &key timeout) (signal-error-if-condition-wait-timeout timeout) (mt:condition-wait condition-variable lock) t) (define-condition-wait-compiler-macro) (defun condition-notify (condition-variable) (mt:condition-signal condition-variable)) (defun thread-yield () (mt:thread-yield)) ;;; Introspection/debugging (defun all-threads () (mt:all-threads)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (mt:interrupt-thread thread (apply-function)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (mt:thread-kill thread)) (defun thread-alive-p (thread) (mt:thread-active-p thread)) (defun join-thread (thread) (mt:thread-join thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-sbcl.lisp000066400000000000000000000070141463556250700205770ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| 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 (deftype thread () 'sb-thread:thread) ;;; Thread Creation (defun %make-thread (function name) (sb-thread:make-thread function :name name)) (defun current-thread () sb-thread:*current-thread*) (defun threadp (object) (typep object 'sb-thread:thread)) (defun thread-name (thread) (sb-thread:thread-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'sb-thread:mutex) (deftype recursive-lock () 'sb-thread:mutex) (defun lock-p (object) (typep object 'sb-thread:mutex)) (defun recursive-lock-p (object) (typep object 'sb-thread:mutex)) (defun make-lock (&optional name) (sb-thread:make-mutex :name (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) #+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) (sb-thread:grab-mutex lock :waitp wait-p) #-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) (sb-thread:get-mutex lock nil wait-p)) (defun release-lock (lock) (sb-thread:release-mutex lock)) (defmacro with-lock-held ((place) &body body) `(sb-thread:with-mutex (,place) ,@body)) (defun make-recursive-lock (&optional name) (sb-thread:make-mutex :name (or name "Anonymous recursive lock"))) ;;; 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 (defun make-condition-variable (&key name) (sb-thread:make-waitqueue :name (or name "Anonymous condition variable"))) (defun condition-wait (condition-variable lock &key timeout) (let ((success (sb-thread:condition-wait condition-variable lock :timeout timeout))) (when (not success) (acquire-lock lock)) success)) (defun condition-notify (condition-variable) (sb-thread:condition-notify condition-variable)) (defun thread-yield () (sb-thread:thread-yield)) ;;; Timeouts (deftype timeout () 'sb-ext:timeout) (defmacro with-timeout ((timeout) &body body) `(sb-ext:with-timeout ,timeout ,@body)) ;;; Semaphores (deftype semaphore () 'sb-thread:semaphore) (defun make-semaphore (&key name (count 0)) (sb-thread:make-semaphore :name name :count count)) (defun signal-semaphore (semaphore &key (count 1)) (sb-thread:signal-semaphore semaphore count)) (defun wait-on-semaphore (semaphore &key timeout) (sb-thread:wait-on-semaphore semaphore :timeout timeout)) ;;; Introspection/debugging (defun all-threads () (sb-thread:list-all-threads)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (sb-thread:interrupt-thread thread (apply-function)))) (defun destroy-thread (thread) (signal-error-if-current-thread thread) (sb-thread:terminate-thread thread)) (defun thread-alive-p (thread) (sb-thread:thread-alive-p thread)) (defun join-thread (thread) (sb-thread:join-thread thread)) (mark-supported) bordeaux-threads-0.9.4/apiv1/impl-scl.lisp000066400000000000000000000053301463556250700204340ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- #| Copyright 2008 Scieneer Pty Ltd Distributed under the MIT license (see LICENSE file) |# (in-package #:bordeaux-threads) (deftype thread () 'thread:thread) (defun %make-thread (function name) (thread:thread-create function :name name)) (defun current-thread () thread:*thread*) (defun threadp (object) (typep object 'thread:thread)) (defun thread-name (thread) (thread:thread-name thread)) ;;; Resource contention: locks and recursive locks (deftype lock () 'thread:lock) (deftype recursive-lock () 'thread:recursive-lock) (defun lock-p (object) (typep object 'thread:lock)) (defun recursive-lock-p (object) (typep object 'thread:recursive-lock)) (defun make-lock (&optional name) (thread:make-lock (or name "Anonymous lock"))) (defun acquire-lock (lock &optional (wait-p t)) (thread::acquire-lock lock nil wait-p)) (defun release-lock (lock) (thread::release-lock lock)) (defmacro with-lock-held ((place) &body body) `(thread:with-lock-held (,place) ,@body)) (defun make-recursive-lock (&optional name) (thread:make-lock (or name "Anonymous recursive lock") :type :recursive)) ;;; 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) `(thread:with-lock-held (,place) ,@body)) ;;; Resource contention: condition variables (defun make-condition-variable (&key name) (thread:make-cond-var (or name "Anonymous condition variable"))) (defun condition-wait (condition-variable lock &key timeout) (if timeout (thread:cond-var-timedwait condition-variable lock timeout) (thread:cond-var-wait condition-variable lock)) t) (defun condition-notify (condition-variable) (thread:cond-var-broadcast condition-variable)) (defun thread-yield () (mp:process-yield)) ;;; Introspection/debugging (defun all-threads () (mp:all-processes)) (defun interrupt-thread (thread function &rest args) (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (thread:thread-interrupt thread (apply-function)))) (defun destroy-thread (thread) (thread:destroy-thread thread)) (defun thread-alive-p (thread) (mp:process-alive-p thread)) (defun join-thread (thread) (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (named-lambda %thread-completedp () (not (mp:process-alive-p thread))))) (mark-supported) bordeaux-threads-0.9.4/apiv1/pkgdcl.lisp000066400000000000000000000060231463556250700201600ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- ;;;; The above modeline is required for Genera. Do not change. (cl:defpackage :bordeaux-threads (:nicknames #:bt) (:use #:cl #:alexandria) #+abcl (:import-from :java #:jnew #:jcall #:jmethod) (:export #:thread #:make-thread #:current-thread #:threadp #:thread-name #:start-multiprocessing #:*default-special-bindings* #:*standard-io-bindings* #:*supports-threads-p* #:lock #:make-lock #:lock-p #:acquire-lock #:release-lock #:with-lock-held #:recursive-lock #:make-recursive-lock #:recursive-lock-p #:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held #:make-condition-variable #:condition-wait #:condition-notify #:make-semaphore #:signal-semaphore #:wait-on-semaphore #:semaphore #:semaphore-p #:with-timeout #:timeout #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p #:join-thread #:thread-yield) (:documentation "BORDEAUX-THREADS 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-THREADS package. Implementations and/or users may also make them visible or exported in other more traditionally named packages.")) bordeaux-threads-0.9.4/apiv2/000077500000000000000000000000001463556250700160235ustar00rootroot00000000000000bordeaux-threads-0.9.4/apiv2/api-condition-variables.lisp000066400000000000000000000075671463556250700234360ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) ;;; 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. (defun condition-variable-p (object) "Returns TRUE if OBJECT is a condition variable, and NIL otherwise." (typep object 'condition-variable)) (defun make-condition-variable (&key name) "Returns a new condition-variable object for use with CONDITION-WAIT and CONDITION-NOTIFY." (check-type name (or null string)) (%make-condition-variable name)) (defun condition-wait (condition-variable lock &key timeout) "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. It is an error to call this function unless from the thread that holds LOCK. If TIMEOUT is nil or not provided, the call blocks until a notification is received. If TIMEOUT is non-nil, the call will return after at most TIMEOUT seconds (approximately), whether or not a notification has occurred. Either NIL or T will be returned. A return of NIL indicates that the timeout has expired without receiving a notification. A return of T indicates that a notification was received." (check-type timeout (or null (real 0))) (%condition-wait condition-variable (lock-native-lock lock) timeout)) (defun condition-notify (condition-variable) "Notify one of the threads waiting for CONDITION-VARIABLE. It is unspecified which thread gets a wakeup and does not necessarily relate to the order that the threads went to sleep in. CONDITION-NOTIFY returns always NIL." (%condition-notify condition-variable) nil) (defun condition-broadcast (condition-variable) "Notify all threads waiting for CONDITION-VARIABLE. The order of wakeup is unspecified and does not necessarily relate to the order that the threads went to sleep in. CONDITION-BROADCAST returns always NIL." (%condition-broadcast condition-variable) nil) bordeaux-threads-0.9.4/apiv2/api-locks.lisp000066400000000000000000000134221463556250700206000ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) (defun native-lock-p (object) (typep object 'native-lock)) (defclass lock () ((name :initarg :name :reader lock-name) (native-lock :initarg :native-lock :reader lock-native-lock)) (:documentation "Wrapper for a native non-recursive lock.")) (defmethod print-object ((lock lock) stream) (print-unreadable-object (lock stream :type t :identity t) (format stream "~S" (lock-name lock)))) (defun lockp (object) "Returns T if OBJECT is a non-recursive lock; returns NIL otherwise." (typep object 'lock)) (defun make-lock (&key name) "Creates a lock (a mutex) whose name is NAME." (check-type name (or null string)) (make-instance 'lock :name name :native-lock (%make-lock name))) (defun acquire-lock (lock &key (wait t) timeout) "Acquire the lock LOCK for the calling thread. WAIT governs what happens if the lock is not available: if WAIT is true, the calling thread will wait until the lock is available and then acquire it; if WAIT is NIL, ACQUIRE-LOCK will return immediately. If WAIT is true, TIMEOUT may specify a maximum amount of seconds to wait for the lock to become available. ACQUIRE-LOCK returns T 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." (check-type timeout (or null (real 0))) (%acquire-lock (lock-native-lock lock) (bool wait) timeout)) (defun release-lock (lock) "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. Returns the lock." (%release-lock (lock-native-lock lock)) lock) (defmacro with-lock-held ((place &key timeout) &body body &environment env) "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." (declare (ignorable place timeout)) (if (fboundp '%with-lock) (macroexpand-1 `(%with-lock ((lock-native-lock ,place) ,timeout) ,@body) env) `(when (acquire-lock ,place :wait t :timeout ,timeout) (unwind-protect (locally ,@body) (release-lock ,place))))) (defun native-recursive-lock-p (object) (typep object 'native-recursive-lock)) (defclass recursive-lock () ((name :initarg :name :reader lock-name) (native-lock :initarg :native-lock :reader lock-native-lock)) (:documentation "Wrapper for a native recursive lock.")) (defmethod print-object ((lock recursive-lock) stream) (print-unreadable-object (lock stream :type t :identity t) (format stream "~S" (lock-name lock)))) (defun recursive-lock-p (object) "Returns T if OBJECT is a recursive lock; returns NIL otherwise." (typep object 'recursive-lock)) (defun make-recursive-lock (&key name) "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 (acquire and release operations must be balanced)." (check-type name (or null string)) (make-instance 'recursive-lock :name name :native-lock (%make-recursive-lock name))) (defun acquire-recursive-lock (lock &key (wait t) timeout) "Acquire the lock LOCK for the calling thread. WAIT governs what happens if the lock is not available: if WAIT is true, the calling thread will wait until the lock is available and then acquire it; if WAIT is NIL, ACQUIRE-RECURSIVE-LOCK will return immediately. If WAIT is true, TIMEOUT may specify a maximum amount of seconds to wait for the lock to become available. ACQUIRE-LOCK returns true if the lock was acquired and NIL otherwise. This operation will return immediately if the lock is already owned by the current thread. Acquire and release operations must be balanced." (check-type lock recursive-lock) (check-type timeout (or null (real 0))) (%acquire-recursive-lock (lock-native-lock lock) (bool wait) timeout)) (defun release-recursive-lock (lock) "Release LOCK. It is an error to call this unless the lock has previously been acquired (and not released) by the same thread. Returns the lock." (%release-recursive-lock (lock-native-lock lock)) lock) (defmacro with-recursive-lock-held ((place &key timeout) &body body &environment env) "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." (declare (ignorable place timeout)) (if (fboundp '%with-recursive-lock) (macroexpand-1 `(%with-recursive-lock ((lock-native-lock ,place) ,timeout) ,@body) env) `(when (acquire-recursive-lock ,place :wait t :timeout ,timeout) (unwind-protect (locally ,@body) (release-recursive-lock ,place))))) bordeaux-threads-0.9.4/apiv2/api-semaphores.lisp000066400000000000000000000060021463556250700216270ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) #-(or abcl allegro ccl ecl lispworks mezzano sbcl) (defstruct (%semaphore (:constructor %make-semaphore (name counter))) name counter (lock (make-lock)) (condition-variable (%make-condition-variable nil))) #-(or abcl allegro ccl ecl lispworks mezzano sbcl) (deftype semaphore () '%semaphore) (defun make-semaphore (&key name (count 0)) "Create a semaphore with the supplied NAME and initial counter value COUNT." (check-type name (or null string)) (%make-semaphore name count)) #-(or abcl allegro ccl ecl lispworks mezzano sbcl) (defun %signal-semaphore (semaphore count) (with-lock-held ((%semaphore-lock semaphore)) (incf (%semaphore-counter semaphore) count) (dotimes (v count) (%condition-notify (%semaphore-condition-variable semaphore))))) (defun signal-semaphore (semaphore &key (count 1)) "Increment SEMAPHORE by COUNT. If there are threads waiting on this semaphore, then COUNT of them are woken up." (%signal-semaphore semaphore count) t) #-(or abcl allegro ccl ecl lispworks mezzano sbcl) (defun %wait-on-semaphore (semaphore timeout) (with-lock-held ((%semaphore-lock semaphore)) (if (plusp (%semaphore-counter semaphore)) (decf (%semaphore-counter semaphore)) (let ((deadline (when timeout (+ (get-internal-real-time) (* timeout internal-time-units-per-second))))) ;; we need this loop because of a spurious wakeup possibility (loop until (plusp (%semaphore-counter semaphore)) do (cond ((null (%condition-wait (%semaphore-condition-variable semaphore) (lock-native-lock (%semaphore-lock semaphore)) timeout)) (return-from %wait-on-semaphore)) ;; unfortunately cv-wait may return T on timeout too ((and deadline (>= (get-internal-real-time) deadline)) (return-from %wait-on-semaphore)) (timeout (setf timeout (/ (- deadline (get-internal-real-time)) internal-time-units-per-second))))) (decf (%semaphore-counter semaphore)))) ;; Semaphore acquired. t)) (defun wait-on-semaphore (semaphore &key timeout) "Decrement the count of SEMAPHORE by 1 if the count is larger than zero. If count is zero, blocks until the semaphore can be decremented. Returns generalized boolean T on success. If TIMEOUT is given, it is the maximum number of seconds to wait. If the count cannot be decremented in that time, returns NIL without decrementing the count." (%wait-on-semaphore semaphore timeout)) (defun semaphorep (object) "Returns T if OBJECT is a semaphore, otherwise NIL." (typep object 'semaphore)) bordeaux-threads-0.9.4/apiv2/api-threads.lisp000066400000000000000000000301501463556250700211140ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) (defclass thread () ((name :initarg :name :reader thread-name) (native-thread :initarg :native-thread :reader thread-native-thread) (%lock :initform (make-lock)) ;; Used for implementing condition variables in ;; impl-condition-variables-semaphores.lisp. #+ccl (%semaphore :initform (%make-semaphore nil 0) :reader %thread-semaphore) (%return-values :initform nil :reader thread-return-values) (%exit-condition :initform nil :reader thread-exit-condition))) (defmethod print-object ((thread thread) stream) (print-unreadable-object (thread stream :type t :identity t) (format stream "~S" (thread-name thread)))) (define-global-var* .known-threads-lock. (make-lock :name "known-threads-lock")) (define-global-var* .known-threads. (trivial-garbage:make-weak-hash-table #-genera :weakness #-genera :key)) (define-global-var* .thread-counter. -1) (defun make-unknown-thread-name () (format nil "Unknown thread ~S" (with-lock-held (.known-threads-lock.) (incf .thread-counter.)))) (defun ensure-thread-wrapper (native-thread) (with-lock-held (.known-threads-lock.) (multiple-value-bind (thread presentp) (gethash native-thread .known-threads.) (if presentp thread (setf (gethash native-thread .known-threads.) (make-instance 'thread :name (%thread-name native-thread) :native-thread native-thread)))))) (defun %get-thread-wrapper (native-thread) (multiple-value-bind (thread presentp) (with-lock-held (.known-threads-lock.) (gethash native-thread .known-threads.)) (if presentp thread (bt-error "Thread wrapper is supposed to exist for ~S" native-thread)))) (defun (setf thread-wrapper) (thread native-thread) (with-lock-held (.known-threads-lock.) (setf (gethash native-thread .known-threads.) thread))) (defun remove-thread-wrapper (native-thread) (with-lock-held (.known-threads-lock.) (remhash native-thread .known-threads.))) ;; Forms are evaluated in the new thread or in the calling thread? (defvar *default-special-bindings* nil "This variable holds an alist associating special variable symbols to forms to evaluate. 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.") (macrolet ((defbindings (name docstring &body initforms) (check-type docstring string) `(alexandria:define-constant ,name (list ,@(loop for (special form) in initforms collect `(cons ',special ',form))) :test #'equal :documentation ,docstring))) (defbindings +standard-io-bindings+ "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX. Forms are evaluated in the calling thread." (*package* (find-package :common-lisp-user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) ;; Genera doesn't yet implement COPY-PPRINT-DISPATCH ;; (Calling it signals an error) #-genera (*print-pprint-dispatch* (copy-pprint-dispatch nil)) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) (*print-right-margin* nil) (*random-state* (make-random-state t)) (*read-base* 10) (*read-default-float-format* 'double-float) (*read-eval* nil) (*read-suppress* nil) (*readtable* (copy-readtable nil)))) (defvar *current-thread*) (defun compute-special-bindings (bindings) (remove-duplicates (append bindings +standard-io-bindings+) :from-end t :key #'car)) (defun establish-dynamic-env (thread function special-bindings trap-conditions) "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls FUNCTION." (let* ((bindings (compute-special-bindings special-bindings)) (specials (mapcar #'car bindings)) (values (mapcar (lambda (f) (eval (cdr f))) bindings))) (named-lambda %establish-dynamic-env-wrapper () (progv specials values (with-slots (%lock %return-values %exit-condition #+genera native-thread) thread (flet ((record-condition (c) (with-lock-held (%lock) (setf %exit-condition c))) (run-function () (let ((*current-thread* nil)) ;; Wait until the thread creator has finished creating ;; the wrapper. (with-lock-held (%lock) (setf *current-thread* (%get-thread-wrapper (%current-thread)))) (let ((retval (multiple-value-list (funcall function)))) (with-lock-held (%lock) (setf %return-values retval)) retval)))) (unwind-protect (if trap-conditions (handler-case (values-list (run-function)) (condition (c) (record-condition c))) (handler-bind ((condition #'record-condition)) (values-list (run-function)))) ;; Genera doesn't support weak key hash tables. If we don't remove ;; the native-thread object's entry from the hash table here, we'll ;; never be able to GC the native-thread after it terminates #+genera (remove-thread-wrapper native-thread)))))))) ;;; ;;; Thread Creation ;;; (defun start-multiprocessing () "If the host implementation uses user-level threads, start the scheduler and multiprocessing, otherwise do nothing. It is safe to call repeatedly." (when (fboundp '%start-multiprocessing) (funcall '%start-multiprocessing)) (values)) (defun make-thread (function &key name (initial-bindings *default-special-bindings*) trap-conditions) "Creates and returns a thread named NAME, which will call the function FUNCTION with no arguments: when FUNCTION returns, the thread terminates. 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, such as the ones introduced by INITIAL-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." (check-type function (and (not null) (or symbol function))) (check-type name (or null string)) (let* ((name (or name (make-unknown-thread-name))) (thread (make-instance 'thread :name name))) (with-slots (native-thread %lock) thread (with-lock-held (%lock) (let ((%thread (%make-thread (establish-dynamic-env thread function initial-bindings trap-conditions) name))) (setf native-thread %thread) (setf (thread-wrapper %thread) thread)))) thread)) (defun current-thread () "Returns the thread object for the calling thread. This is the same kind of object as would be returned by MAKE-THREAD." (cond ((boundp '*current-thread*) (assert (threadp *current-thread*)) *current-thread*) (t (ensure-thread-wrapper (%current-thread))))) (defun threadp (object) "Returns T if object is a thread, otherwise NIL." (typep object 'thread)) (defmethod join-thread ((thread thread)) "Wait until THREAD terminates. If THREAD has already terminated, return immediately. The return values of the thread function are returned." (with-slots (native-thread %lock %return-values %exit-condition) thread (when (eql native-thread (%current-thread)) (bt-error "Cannot join with the current thread")) (%join-thread native-thread) (multiple-value-bind (exit-condition retval) (with-lock-held (%lock) (values %exit-condition %return-values)) (if exit-condition (error 'abnormal-exit :condition exit-condition) (values-list retval))))) (defun thread-yield () "Allows other threads to run. It may be necessary or desirable to call this periodically in some implementations; others may schedule threads automatically." (%thread-yield) (values)) ;;; ;;; Introspection/debugging ;;; (defun all-threads () "Returns a sequence of all of the threads." (mapcar #'ensure-thread-wrapper (%all-threads))) (defmethod interrupt-thread ((thread thread) function &rest args) "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." (flet ((apply-function () (if args (named-lambda %interrupt-thread-wrapper () (apply function args)) function))) (declare (dynamic-extent #'apply-function)) (%interrupt-thread (thread-native-thread thread) (apply-function)) thread)) (defmethod signal-in-thread ((thread thread) datum &rest args) "Interrupt THREAD and call SIGNAL passing DATUM and ARGS." (apply #'interrupt-thread thread #'signal (cons datum args))) (defmethod warn-in-thread ((thread thread) datum &rest args) "Interrupt THREAD and call WARN passing DATUM and ARGS." (apply #'interrupt-thread thread #'warn (cons datum args))) (defmethod error-in-thread ((thread thread) datum &rest args) "Interrupt THREAD and call ERROR passing DATUM and ARGS." (apply #'interrupt-thread thread #'error (cons datum args))) (defmethod destroy-thread ((thread thread)) "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." (with-slots (native-thread %lock %exit-condition) thread (when (eql native-thread (%current-thread)) (bt-error "Cannot destroy the current thread")) (unless (thread-alive-p thread) (bt-error "Cannot destroy thread because it already exited: ~S." thread)) (%destroy-thread native-thread) (with-lock-held (%lock) (setf %exit-condition :terminated))) thread) (defmethod thread-alive-p ((thread thread)) "Returns true if THREAD is alive, that is, if it has not finished or DESTROY-THREAD has not been called on it." (%thread-alive-p (thread-native-thread thread))) bordeaux-threads-0.9.4/apiv2/atomics-java.lisp000066400000000000000000000047371463556250700213050ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) (defstruct (atomic-integer (:constructor %make-atomic-integer (cell))) "Wrapper for java.util.concurrent.AtomicLong." cell) (defmethod print-object ((aint atomic-integer) stream) (print-unreadable-object (aint stream :type t :identity t) (format stream "~S" (atomic-integer-value aint)))) (deftype %atomic-integer-value () '(unsigned-byte 63)) (defun make-atomic-integer (&key (value 0)) (check-type value %atomic-integer-value) (%make-atomic-integer (jnew "java.util.concurrent.atomic.AtomicLong" value))) (defconstant +atomic-long-cas+ (jmethod "java.util.concurrent.atomic.AtomicLong" "compareAndSet" (jclass "long") (jclass "long"))) (defun atomic-integer-compare-and-swap (atomic-integer old new) (declare (type atomic-integer atomic-integer) (type %atomic-integer-value old new) (optimize (safety 0) (speed 3))) (jcall +atomic-long-cas+ (atomic-integer-cell atomic-integer) old new)) (defconstant +atomic-long-incf+ (jmethod "java.util.concurrent.atomic.AtomicLong" "getAndAdd" (jclass "long"))) (defun atomic-integer-decf (atomic-integer &optional (delta 1)) (declare (type atomic-integer atomic-integer) (type %atomic-integer-value delta) (optimize (safety 0) (speed 3))) (let ((increment (- delta))) (+ (jcall +atomic-long-incf+ (atomic-integer-cell atomic-integer) increment) increment))) (defun atomic-integer-incf (atomic-integer &optional (delta 1)) (declare (type atomic-integer atomic-integer) (type %atomic-integer-value delta) (optimize (safety 0) (speed 3))) (+ (jcall +atomic-long-incf+ (atomic-integer-cell atomic-integer) delta) delta)) (defconstant +atomic-long-get+ (jmethod "java.util.concurrent.atomic.AtomicLong" "get")) (defun atomic-integer-value (atomic-integer) (declare (type atomic-integer atomic-integer) (optimize (safety 0) (speed 3))) (jcall +atomic-long-get+ (atomic-integer-cell atomic-integer))) (defconstant +atomic-long-set+ (jmethod "java.util.concurrent.atomic.AtomicLong" "set" (jclass "long"))) (defun (setf atomic-integer-value) (newval atomic-integer) (declare (type atomic-integer atomic-integer) (type %atomic-integer-value newval) (optimize (safety 0) (speed 3))) (jcall +atomic-long-set+ (atomic-integer-cell atomic-integer) newval) newval) bordeaux-threads-0.9.4/apiv2/atomics.lisp000066400000000000000000000135041463556250700203560ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) (defmacro atomic-cas (place old new) (declare (ignorable place old new)) #+allegro `(excl:atomic-conditional-setf ,place ,new ,old) #+ccl `(ccl::conditional-store ,place ,old ,new) #+clasp `(mp:cas ,place ,old ,new) #+ecl (with-gensyms (tmp) `(let ((,tmp ,old)) (eql ,tmp (mp:compare-and-swap ,place ,tmp ,new)))) #+genera `(sys:store-conditional (scl:locf ,place) ,old ,new) #+lispworks `(system:compare-and-swap ,place ,old ,new) #+sbcl (with-gensyms (tmp) `(let ((,tmp ,old)) (eql ,tmp (sb-ext:compare-and-swap ,place ,old ,new)))) #-(or allegro ccl clasp ecl genera lispworks sbcl) (signal-not-implemented 'atomic-cas)) (defmacro atomic-decf (place &optional (delta 1)) (declare (ignorable place delta)) #+allegro `(excl:decf-atomic ,place ,delta) #+ccl `(ccl::atomic-incf-decf ,place (- ,delta)) #+clasp `(mp:atomic-decf ,place ,delta) #+ecl `(- (mp:atomic-decf ,place ,delta) ,delta) #+genera `(process:atomic-decf ,place ,delta) #+lispworks `(system:atomic-decf ,place ,delta) #+sbcl `(- (sb-ext:atomic-decf ,place ,delta) ,delta) #-(or allegro ccl clasp ecl genera lispworks sbcl) (signal-not-implemented 'atomic-decf)) (defmacro atomic-incf (place &optional (delta 1)) (declare (ignorable place delta)) #+allegro `(excl:incf-atomic ,place ,delta) #+ccl `(ccl::atomic-incf-decf ,place ,delta) #+clasp `(mp:atomic-incf ,place ,delta) #+ecl `(+ (mp:atomic-incf ,place ,delta) ,delta) #+genera `(process:atomic-incf ,place ,delta) #+lispworks `(system:atomic-incf ,place ,delta) #+sbcl `(+ (sb-ext:atomic-incf ,place ,delta) ,delta) #-(or allegro ccl clasp ecl genera lispworks sbcl) (signal-not-implemented 'atomic-incf)) (deftype %atomic-integer-value () #+32-bit '(unsigned-byte 32) #+64-bit '(unsigned-byte 64)) (defstruct (atomic-integer (:constructor %make-atomic-integer ()) #+ecl (:atomic-accessors t)) "Wrapper for an UNSIGNED-BYTE that allows atomic increment, decrement and swap. The counter is a machine word: 32/64 bits depending on CPU." #+(or allegro ccl clasp ecl genera lispworks) (cell (make-array 1 :element-type t)) #+(or clisp sbcl) (cell 0 :type %atomic-integer-value) #+clisp (%lock (%make-lock nil) :type native-lock)) (defmethod print-object ((aint atomic-integer) stream) (print-unreadable-object (aint stream :type t :identity t) (format stream "~S" (atomic-integer-value aint)))) #-(or allegro ccl clasp clisp ecl genera lispworks sbcl) (mark-not-implemented 'make-atomic-integer) (defun make-atomic-integer (&key (value 0)) "Create an `ATOMIC-INTEGER` with initial value `VALUE`" (check-type value %atomic-integer-value) #+(or allegro ccl clasp clisp ecl genera lispworks sbcl) (let ((aint (%make-atomic-integer))) (setf (atomic-integer-value aint) value) aint) #-(or allegro ccl clasp clisp ecl genera lispworks sbcl) (signal-not-implemented 'make-atomic-integer)) (defun atomic-integer-compare-and-swap (atomic-integer old new) "If the current value of `ATOMIC-INTEGER` is equal to `OLD`, replace it with `NEW`. Returns T if the replacement was successful, otherwise NIL." (declare (type atomic-integer atomic-integer) (type %atomic-integer-value old new) (optimize (safety 0) (speed 3))) #-clisp (atomic-cas #-sbcl (svref (atomic-integer-cell atomic-integer) 0) #+sbcl (atomic-integer-cell atomic-integer) old new) #+clisp (%with-lock ((atomic-integer-%lock atomic-integer) nil) (cond ((= old (slot-value atomic-integer 'cell)) (setf (slot-value atomic-integer 'cell) new) t) (t nil)))) (defun atomic-integer-decf (atomic-integer &optional (delta 1)) "Decrements the value of `ATOMIC-INTEGER` by `DELTA`. Returns the new value of `ATOMIC-INTEGER`." (declare (type atomic-integer atomic-integer) (type %atomic-integer-value delta) (optimize (safety 0) (speed 3))) #-clisp (atomic-decf #-sbcl (svref (atomic-integer-cell atomic-integer) 0) #+sbcl (atomic-integer-cell atomic-integer) delta) #+clisp (%with-lock ((atomic-integer-%lock atomic-integer) nil) (decf (atomic-integer-cell atomic-integer) delta))) (defun atomic-integer-incf (atomic-integer &optional (delta 1)) "Increments the value of `ATOMIC-INTEGER` by `DELTA`. Returns the new value of `ATOMIC-INTEGER`." (declare (type atomic-integer atomic-integer) (type %atomic-integer-value delta) (optimize (safety 0) (speed 3))) #-clisp (atomic-incf #-sbcl (svref (atomic-integer-cell atomic-integer) 0) #+sbcl (atomic-integer-cell atomic-integer) delta) #+clisp (%with-lock ((atomic-integer-%lock atomic-integer) nil) (incf (atomic-integer-cell atomic-integer) delta))) (defun atomic-integer-value (atomic-integer) "Returns the current value of `ATOMIC-INTEGER`." (declare (type atomic-integer atomic-integer) (optimize (safety 0) (speed 3))) #-clisp (progn #-sbcl (svref (atomic-integer-cell atomic-integer) 0) #+sbcl (atomic-integer-cell atomic-integer)) #+clisp (%with-lock ((atomic-integer-%lock atomic-integer) nil) (atomic-integer-cell atomic-integer))) (defun (setf atomic-integer-value) (newval atomic-integer) (declare (type atomic-integer atomic-integer) (type %atomic-integer-value newval) (optimize (safety 0) (speed 3))) #-clisp (setf #-sbcl (svref (atomic-integer-cell atomic-integer) 0) #+sbcl (atomic-integer-cell atomic-integer) newval) #+clisp (%with-lock ((atomic-integer-%lock atomic-integer) nil) (setf (atomic-integer-cell atomic-integer) newval))) bordeaux-threads-0.9.4/apiv2/bordeaux-threads.lisp000066400000000000000000000057411463556250700221640ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) (defconstant +supports-threads-p+ #+thread-support t #-thread-support nil "This should be set to T if the running instance has thread support.") #+thread-support (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :bordeaux-threads *features*)) (defun bool (thing) (if thing t nil)) (define-condition bordeaux-threads-error (error) ()) (define-condition abnormal-exit (bordeaux-threads-error) ((exit-condition :initarg :condition :reader abnormal-exit-condition)) (:report (lambda (condition stream) (format stream "Thread exited with condition: ~A" (abnormal-exit-condition condition))))) (define-condition bordeaux-threads-simple-error (simple-error bordeaux-threads-error) ()) (defun bt-error (msg &rest args) (error 'bordeaux-threads-simple-error :format-control msg :format-arguments args)) (define-condition not-implemented (bordeaux-threads-error) ()) (define-condition operation-not-implemented (not-implemented) ((operation :initarg :operation :reader operation-not-implemented-operation)) (:report (lambda (condition stream) (format stream "Operation not implemented: ~A" (operation-not-implemented-operation condition))))) (define-condition keyarg-not-implemented (not-implemented) ((operation :initarg :operation :reader keyarg-not-implemented-operation) (keyarg :initarg :keyarg :reader keyarg-not-implemented-keyarg)) (:report (lambda (condition stream) (format stream "~A does not implement argument ~S" (keyarg-not-implemented-operation condition) (keyarg-not-implemented-keyarg condition))))) (defun signal-not-implemented (op &optional keyarg) (if keyarg (error 'keyarg-not-implemented :operation op :keyarg keyarg) (error 'operation-not-implemented :operation op))) (defparameter *not-implemented* (make-hash-table :test #'equal)) (defun mark-not-implemented (op &rest features) (setf (gethash op *not-implemented*) features)) (defun implemented-p (op &optional feature) (multiple-value-bind (missing-features found) (gethash op *not-implemented*) (cond ((not found) t) (t (if (null feature) (not (null missing-features)) (find feature missing-features)))))) (defun implemented-p* (op &optional feature) (if (implemented-p op feature) '(:and) '(:or))) #-sbcl (define-condition timeout (serious-condition) ((length :initform nil :initarg :length :reader timeout-length)) (:report (lambda (c s) (if (timeout-length c) (format s "A timeout set to ~A seconds occurred." (timeout-length c)) (format s "A timeout occurred."))))) bordeaux-threads-0.9.4/apiv2/impl-abcl.lisp000066400000000000000000000137221463556250700205610ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'threads:thread) (defun %make-thread (function name) (threads:make-thread function :name name)) (defun %current-thread () (threads:current-thread)) (defun %thread-name (thread) (threads:thread-name thread)) (defun %join-thread (thread) (threads:thread-join thread)) (defun %thread-yield () (java:jstatic "yield" "java.lang.Thread")) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (let ((threads ())) (threads:mapcar-threads (lambda (thread) (push thread threads))) (nreverse threads))) (defun %interrupt-thread (thread function) (threads:interrupt-thread thread function)) (defun %destroy-thread (thread) (threads:destroy-thread thread)) (defun %thread-alive-p (thread) (threads:thread-alive-p thread)) ;;; ;;; Non-recursive locks. ;;; (defstruct mutex name lock) (deftype native-lock () 'mutex) (defun %make-lock (name) (make-mutex :name name :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) ;; Making methods constants in this manner avoids the runtime expense of ;; introspection involved in JCALL with string arguments. (defconstant +lock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "lock")) (defconstant +try-lock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock")) (defconstant +try-lock-timeout+ (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock" (jclass "long") (jclass "java.util.concurrent.TimeUnit"))) (defconstant +is-held-by-current-thread+ (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread")) (defconstant +unlock+ (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock")) (defconstant +get-hold-count+ (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount")) (defconstant +microseconds+ (java:jfield "java.util.concurrent.TimeUnit" "MICROSECONDS")) (defun timeout-to-microseconds (timeout) (truncate (* timeout 1000000))) (defun %acquire-lock (lock waitp timeout) (check-type lock mutex) (when (jcall +is-held-by-current-thread+ (mutex-lock lock)) (bt-error "Non-recursive lock being reacquired by owner.")) (cond (waitp (if timeout (jcall +try-lock-timeout+ (mutex-lock lock) (timeout-to-microseconds timeout) +microseconds+) (progn (jcall +lock+ (mutex-lock lock)) t))) (t (jcall +try-lock+ (mutex-lock lock))))) (defun %release-lock (lock) (check-type lock mutex) (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) (bt-error "Attempt to release lock not held by calling thread.")) (jcall +unlock+ (mutex-lock lock))) ;;; ;;; Recursive locks ;;; (defstruct (mutex-recursive (:include mutex))) (deftype native-recursive-lock () 'mutex-recursive) (defun %make-recursive-lock (name) (make-mutex-recursive :name name :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) (defun %acquire-recursive-lock (lock waitp timeout) (check-type lock mutex-recursive) (cond (waitp (if timeout (jcall +try-lock-timeout+ (mutex-recursive-lock lock) (timeout-to-microseconds timeout) +microseconds+) (progn (jcall +lock+ (mutex-recursive-lock lock)) t))) (t (jcall +try-lock+ (mutex-recursive-lock lock))))) (defun %release-recursive-lock (lock) (check-type lock mutex-recursive) (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) (error 'bordeaux-threads-error :message "Attempt to release lock not held by calling thread.")) (jcall +unlock+ (mutex-lock lock))) ;;; ;;; Semaphores ;;; (defstruct (semaphore (:constructor %%make-semaphore (name cell))) "Wrapper for java.util.concurrent.Semaphore." name cell) (defconstant +semaphore-count+ (jmethod "java.util.concurrent.Semaphore" "availablePermits")) (defun %semaphore-count (semaphore) (jcall +semaphore-count+ (semaphore-cell semaphore))) (defmethod print-object ((sem semaphore) stream) (print-unreadable-object (sem stream :type t :identity t) (format stream "~S count: ~S" (semaphore-name sem) (%semaphore-count sem)))) (defun %make-semaphore (name count) (check-type count unsigned-byte) (%%make-semaphore name (jnew "java.util.concurrent.Semaphore" count t))) (defconstant +semaphore-release+ (jmethod "java.util.concurrent.Semaphore" "release" (jclass "int"))) (defun %signal-semaphore (semaphore count) (jcall +semaphore-release+ (semaphore-cell semaphore) count)) (defconstant +semaphore-acquire+ (jmethod "java.util.concurrent.Semaphore" "acquire")) (defconstant +semaphore-try-acquire+ (jmethod "java.util.concurrent.Semaphore" "tryAcquire" (jclass "long") (jclass "java.util.concurrent.TimeUnit"))) (defun %wait-on-semaphore (semaphore timeout) ;; TODO: handle thread interruption. (cond ((null timeout) (jcall +semaphore-acquire+ (semaphore-cell semaphore)) t) (t (jcall +semaphore-try-acquire+ (semaphore-cell semaphore) (timeout-to-microseconds timeout) +microseconds+)))) ;;; ;;; Condition variables ;;; (defstruct (condition-variable (:constructor %make-condition-variable (name))) name) (defun %condition-wait (cv lock timeout) (threads:synchronized-on cv (%release-lock lock) (if timeout ;; Since giving a zero time value to threads:object-wait means ;; an indefinite wait, use some arbitrary small number. (threads:object-wait cv (if (zerop timeout) least-positive-single-float timeout)) (threads:object-wait cv))) (%acquire-lock lock t nil) t) (defun %condition-notify (cv) (threads:synchronized-on cv (threads:object-notify cv))) (defun %condition-broadcast (cv) (threads:synchronized-on cv (threads:object-notify-all cv))) bordeaux-threads-0.9.4/apiv2/impl-allegro.lisp000066400000000000000000000072551463556250700213110ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) #-(version>= 9) (error 'bordeaux-threads-error :message "Threading not supported") ;;; ;;; Threads ;;; (deftype native-thread () 'mp:process) (defun %start-multiprocessing () (mp:start-scheduler)) (defun %make-thread (function name) (mp:process-run-function name function)) (defun %current-thread () mp:*current-process*) (defun %thread-name (thread) (mp:process-name thread)) (defun %join-thread (thread) #+smp (mp:process-join thread) #-smp (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread)) (defun %thread-yield () (mp:process-allow-schedule)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () mp:*all-processes*) (defun %interrupt-thread (thread function) (mp:process-interrupt thread function)) (defun %destroy-thread (thread) (mp:process-kill thread)) (defun %thread-alive-p (thread) (mp:process-alive-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp:process-lock) (defun %make-lock (name) (mp:make-process-lock :name name)) (defun %acquire-lock (lock waitp timeout) (mp:process-lock lock mp:*current-process* "Lock" (if waitp timeout 0))) (defun %release-lock (lock) (mp:process-unlock lock)) (defmacro %with-lock ((place timeout) &body body) `(mp:with-process-lock (,place :timeout ,timeout :norecursive t) ,@body)) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () 'mp:process-lock) (defun %make-recursive-lock (name) (mp:make-process-lock :name name)) (mark-not-implemented 'acquire-recursive-lock) (defun %acquire-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'acquire-recursive-lock)) (mark-not-implemented 'release-recursive-lock) (defun %release-recursive-lock (lock) (declare (ignore lock)) (signal-not-implemented 'release-recursive-lock)) (defmacro %with-recursive-lock ((place timeout) &body body) `(mp:with-process-lock (,place :timeout ,timeout) ,@body)) ;;; ;;; Timeouts ;;; (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) ;;; ;;; Semaphores ;;; (defstruct (semaphore (:constructor %%make-semaphore (name))) "Bordeaux-threads implementation of semaphores." name (gate (mp:make-gate nil))) (defmethod print-object ((sem semaphore) stream) (print-unreadable-object (sem stream :type t :identity t) (format stream "~S" (semaphore-name sem)))) (defun %make-semaphore (name count) (let ((sem (%%make-semaphore name))) (%signal-semaphore sem count) sem)) (defun %signal-semaphore (semaphore count) (dotimes (i count) (mp:put-semaphore (semaphore-gate semaphore)))) (defun %wait-on-semaphore (semaphore timeout) (cond (timeout ;; Timeouts that are too small expire immediately. ;; 100ms should suffice. (when (< timeout 0.1) (setf timeout 0.1)) (handler-case (with-timeout (timeout) (mp:get-semaphore (semaphore-gate semaphore)) t) (timeout () nil))) (t (mp:get-semaphore (semaphore-gate semaphore)) t))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mp:condition-variable) (defun %make-condition-variable (name) (mp:make-condition-variable :name name)) (defun %condition-wait (cv lock timeout) (mp:condition-variable-wait cv lock :timeout timeout)) (defun %condition-notify (cv) (mp:condition-variable-signal cv)) (defun %condition-broadcast (cv) (mp:condition-variable-broadcast cv)) bordeaux-threads-0.9.4/apiv2/impl-clasp.lisp000066400000000000000000000046741463556250700207700ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'mp:process) (defun %make-thread (function name) (mp:process-run-function name function)) (defun %current-thread () mp:*current-process*) (defun %thread-name (thread) (mp:process-name thread)) (defun %join-thread (thread) (mp:process-join thread)) (defun %thread-yield () (mp:process-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mp:all-processes)) (defun %interrupt-thread (thread function) (mp:interrupt-process thread function)) (defun %destroy-thread (thread) (mp:process-kill thread)) (defun %thread-alive-p (thread) (mp:process-active-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp:mutex) (defun %make-lock (name) (mp:make-lock :name name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (mp:get-lock lock waitp)) (defun %release-lock (lock) (mp:giveup-lock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(mp:with-lock (,place) ,@body))) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () '(and mp:mutex (satisfies mp:recursive-lock-p))) (defun %make-recursive-lock (name) (mp:make-recursive-mutex name)) (mark-not-implemented 'acquire-recursive-lock :timeout) (defun %acquire-recursive-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-recursive-lock :timeout)) (mp:get-lock lock waitp)) (defun %release-recursive-lock (lock) (mp:giveup-lock lock)) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(mp:with-lock (,place) ,@body))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mp:condition-variable) (defun %make-condition-variable (name) (declare (ignore name)) (mp:make-condition-variable)) (defun %condition-wait (cv lock timeout) (if timeout (mp:condition-variable-timedwait cv lock timeout) (mp:condition-variable-wait cv lock))) (defun %condition-notify (cv) (mp:condition-variable-signal cv)) (defun %condition-broadcast (cv) (mp:condition-variable-broadcast cv)) bordeaux-threads-0.9.4/apiv2/impl-clisp.lisp000066400000000000000000000052601463556250700207700ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'mt:thread) (defun %make-thread (function name) (mt:make-thread function :name name)) (defun %current-thread () (mt:current-thread)) (defun %thread-name (thread) (mt:thread-name thread)) (defun %join-thread (thread) (mt:thread-join thread)) (defun %thread-yield () (mt:thread-yield)) ;;; ;;; Introspection/debugging ;;; ;;; VTZ: mt:list-threads returns all threads that are not garbage collected. (defun %all-threads () (delete-if-not #'mt:thread-active-p (mt:list-threads))) (defun %interrupt-thread (thread function) (mt:thread-interrupt thread :function function)) (defun %destroy-thread (thread) (mt:thread-interrupt thread :function t)) (defun %thread-alive-p (thread) (mt:thread-active-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mt:mutex) (defun %make-lock (name) (mt:make-mutex :name name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (mt:mutex-lock lock :timeout (if waitp nil 0))) (defun %release-lock (lock) (mt:mutex-unlock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(mt:with-mutex-lock (,place) ,@body))) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () '(and mt:mutex (satisfies mt:mutex-recursive-p))) (defun %make-recursive-lock (name) (mt:make-mutex :name name :recursive-p t)) (mark-not-implemented 'acquire-recursive-lock :timeout) (defun %acquire-recursive-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-recursive-lock :timeout)) (%acquire-lock lock waitp nil)) (defun %release-recursive-lock (lock) (%release-lock lock)) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(mt:with-mutex-lock (,place) ,@body))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mt:exemption) (defun %make-condition-variable (name) (mt:make-exemption :name name)) (defun %condition-wait (cv lock timeout) (mt:exemption-wait cv lock :timeout timeout)) (defun %condition-notify (cv) (mt:exemption-signal cv)) (defun %condition-broadcast (cv) (mt:exemption-broadcast cv)) ;;; ;;; Timeouts ;;; (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) bordeaux-threads-0.9.4/apiv2/impl-clozure.lisp000066400000000000000000000056071463556250700213460ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'ccl:process) (defun %make-thread (function name) (ccl:process-run-function name function)) (defun %current-thread () ccl:*current-process*) (defun %thread-name (thread) (ccl:process-name thread)) (defun %join-thread (thread) (ccl:join-process thread)) (defun %thread-yield () (ccl:process-allow-schedule)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (ccl:all-processes)) (defun %interrupt-thread (thread function) (ccl:process-interrupt thread function)) (defun %destroy-thread (thread) (ccl:process-kill thread)) (defun %thread-alive-p (thread) (not (ccl:process-exhausted-p thread))) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'ccl:lock) (defun %make-lock (name) (ccl:make-lock name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) ;; This is not guaranteed to work all the times, but that's OK. (when (eql (ccl::%%lock-owner lock) (%current-thread)) (bt-error "Attempted recursive acquisition of lock: ~A" lock)) (if waitp (ccl:grab-lock lock) (ccl:try-lock lock))) (defun %release-lock (lock) (ccl:release-lock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (declare (ignorable place timeout)) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(ccl:with-lock-grabbed (,place) ,@body))) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () 'ccl:lock) (defun %make-recursive-lock (name) (ccl:make-lock name)) (mark-not-implemented 'acquire-recursive-lock :timeout) (defun %acquire-recursive-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-recursive-lock :timeout)) (if waitp (ccl:grab-lock lock) (ccl:try-lock lock))) (defun %release-recursive-lock (lock) (ccl:release-lock lock)) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (declare (ignorable place timeout)) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(ccl:with-lock-grabbed (,place) ,@body))) ;;; ;;; Semaphores ;;; (deftype semaphore () 'ccl:semaphore) (defun %make-semaphore (name count) (declare (ignore name)) (ccl:make-semaphore :count count)) (defun %signal-semaphore (semaphore count) (dotimes (c count) (ccl:signal-semaphore semaphore))) (defun %wait-on-semaphore (semaphore timeout) (if timeout (ccl:timed-wait-on-semaphore semaphore timeout) (ccl:wait-on-semaphore semaphore))) ;;; ;;; Condition variables ;;; ;;; Clozure doesn't have native condition variables. ;;; We'll use the implementation in ;;; impl-condition-variables-semaphores.lisp bordeaux-threads-0.9.4/apiv2/impl-cmucl.lisp000066400000000000000000000070451463556250700207640ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'mp::process) (defun %start-multiprocessing () (mp::startup-idle-and-top-level-loops)) (defun %make-thread (function name) ;; CMUCL doesn't like NIL names. (mp:make-process function :name (or name ""))) (defun %current-thread () mp:*current-process*) (defun %thread-name (thread) (mp:process-name thread)) (defun %join-thread (thread) (mp:process-join thread)) (defun %thread-yield () (mp:process-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mp:all-processes)) (defun %interrupt-thread (thread function) (mp:process-interrupt thread function)) (defun %destroy-thread (thread) (mp:destroy-process thread)) (defun %thread-alive-p (thread) (mp:process-active-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp::error-check-lock) (defun %make-lock (name) (mp:make-lock name :kind :error-check)) (defun %acquire-lock (lock waitp timeout) (if (and waitp (null timeout)) (mp::lock-wait lock "Lock wait") (mp::lock-wait-with-timeout lock "Lock wait" (if waitp timeout 0)))) (defun %release-lock (lock) (setf (mp::lock-process lock) nil)) (defmacro %with-lock ((place timeout) &body body) `(mp:with-lock-held (,place "Lock wait" :timeout ,timeout) ,@body)) ;;; ;;; Recursive locks ;;; ;;; 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 sort of works, in that ;;; it will wait for recursive locks by the same process as well. (deftype native-recursive-lock () 'mp::recursive-lock) (defun %make-recursive-lock (name) (mp:make-lock name :kind :recursive)) (defun %acquire-recursive-lock (lock waitp timeout) (%acquire-lock lock waitp timeout)) (defun %release-recursive-lock (lock) (%release-lock lock)) (defmacro %with-recursive-lock ((place timeout) &body body) `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) ;;; ;;; 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. (defstruct (condition-variable (:constructor %make-condition-variable (name))) "Bordeaux-threads implementation of condition variables." name (lock (%make-lock nil)) active) (defmethod print-object ((cv condition-variable) stream) (print-unreadable-object (cv stream :type t :identity t) (format stream "~S" (condition-variable-name cv)))) (mark-not-implemented 'condition-wait :timeout) (defun %condition-wait (cv lock timeout) (check-type cv condition-variable) (when timeout (signal-not-implemented 'condition-wait :timeout)) (%with-lock ((condition-variable-lock cv) nil) (setf (condition-variable-active cv) nil)) (%release-lock lock) (mp:process-wait "Condition Wait" #'(lambda () (condition-variable-active cv))) (%acquire-lock lock t nil) t) (defun %condition-notify (cv) (check-type cv condition-variable) (%with-lock ((condition-variable-lock cv) nil) (setf (condition-variable-active cv) t)) (thread-yield)) (mark-not-implemented 'condition-broadcast) (defun %condition-broadcast (cv) (declare (ignore cv)) (signal-not-implemented 'condition-broadcast)) ;;; ;;; Timeouts ;;; (defmacro with-timeout ((timeout) &body body) (once-only (timeout) `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) ,@body))) bordeaux-threads-0.9.4/apiv2/impl-condition-variables-semaphores.lisp000066400000000000000000000037001463556250700257530ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Portable condition variables using semaphores. ;;; ;;; The implementation is meant to be correct and readable, ;;; without trying too hard to be very fast. ;;; (defstruct queue (vector (make-array 7 :adjustable t :fill-pointer 0) :type vector) (lock (%make-lock nil) :type native-lock)) (defun queue-drain (queue) (%with-lock ((queue-lock queue) nil) (shiftf (queue-vector queue) (make-array 7 :adjustable t :fill-pointer 0)))) (defun queue-dequeue (queue) (%with-lock ((queue-lock queue) nil) (let ((vector (queue-vector queue))) (if (zerop (length vector)) nil (vector-pop vector))))) (defun queue-enqueue (queue value) (%with-lock ((queue-lock queue) nil) (vector-push-extend value (queue-vector queue)))) (defstruct (condition-variable (:constructor %make-condition-variable (name)) ;; CONDITION-VARIABLE-P is defined in API-CONDITION-VARIABLES.LISP (:predicate nil)) name (queue (make-queue))) (defmethod print-object ((cv condition-variable) stream) (print-unreadable-object (cv stream :type t :identity t) (format stream "~S" (condition-variable-name cv)))) (defun %condition-wait (cv lock timeout) (with-slots (queue) cv (let* ((thread (current-thread)) (semaphore (%thread-semaphore thread))) (queue-enqueue queue thread) (%release-lock lock) (unwind-protect (%wait-on-semaphore semaphore timeout) (%acquire-lock lock t nil))))) (defun %condition-notify (cv) (with-slots (queue) cv (when-let ((next-thread (queue-dequeue queue))) (%signal-semaphore (%thread-semaphore next-thread) 1)))) (defun %condition-broadcast (cv) (with-slots (queue) cv (let ((queued-threads (queue-drain queue))) (map nil (lambda (thr) (%signal-semaphore (%thread-semaphore thr) 1)) queued-threads)))) bordeaux-threads-0.9.4/apiv2/impl-corman.lisp000066400000000000000000000032701463556250700211340ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'threads:thread) (defun %make-thread (function name) (declare (ignore name)) (threads:create-thread function)) (defun %current-thread () threads:*current-thread*) (defun %thread-name (thread) (declare (ignore thread)) nil) (mark-not-implemented 'join-thread) (defun %join-thread (thread) (declare (ignore thread)) (signal-not-implemented 'join-thread)) (mark-not-implemented 'thread-yield) (defun %thread-yield () (declare (ignore thread)) (signal-not-implemented 'thread-yield)) ;;; ;;; Introspection/debugging ;;; (mark-not-implemented 'all-threads) (defun %all-threads () (declare (ignore thread)) (signal-not-implemented 'all-threads)) (mark-not-implemented 'interrupt-thread) (defun %interrupt-thread (thread function) (declare (ignore thread)) (signal-not-implemented 'interrupt-thread)) (defun %destroy-thread (thread) (threads:terminate-thread thread)) (mark-not-implemented 'thread-alive-p) (defun %thread-alive-p (thread) (declare (ignore thread)) (signal-not-implemented 'thread-alive-p)) ;;; ;;; Locks ;;; (mark-not-implemented 'make-lock) (defun %make-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'make-lock)) (mark-not-implemented 'make-recursive-lock) (defun %make-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'make-recursive-lock)) ;;; ;;; Condition variables ;;; (mark-not-implemented 'make-condition-variable) (defun %make-condition-variable (name) (declare (ignore name)) (signal-not-implemented 'make-condition-variable)) bordeaux-threads-0.9.4/apiv2/impl-ecl.lisp000066400000000000000000000105231463556250700204170ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) (eval-when (:compile-toplevel :execute) (when (>= ext:+ecl-version-number+ 230909) (pushnew :has-timeouts *features*))) ;;; ;;; Threads ;;; (deftype native-thread () 'mp:process) (defun %make-thread (function name) (mp:process-run-function name function)) (defun %current-thread () mp:*current-process*) (defun %thread-name (thread) ;; Some system threads have symbols for a name. (string (mp:process-name thread))) (defun %join-thread (thread) (mp:process-join thread)) (defun %thread-yield () (mp:process-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mp:all-processes)) (defun %interrupt-thread (thread function) (mp:interrupt-process thread function)) (defun %destroy-thread (thread) (mp:process-kill thread)) (defun %thread-alive-p (thread) (mp:process-active-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp:lock) (defun %make-lock (name) (mp:make-lock :name name)) #-has-timeouts (progn (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (mp:get-lock lock waitp))) #+has-timeouts (defun %acquire-lock (lock waitp timeout) (mp:get-lock lock (cond ((not waitp) nil) (timeout timeout) (t t)))) (defun %release-lock (lock) (mp:giveup-lock lock)) #-has-timeouts (progn (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(mp:with-lock (,place) ,@body)))) #+has-timeouts (defmacro %with-lock ((place timeout) &body body) `(mp:with-lock (,place :wait-form (or ,timeout t)) ,@body)) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () '(and mp:lock (satisfies mp:recursive-lock-p))) (defun %make-recursive-lock (name) (mp:make-lock :name name :recursive t)) #-has-timeouts (progn (mark-not-implemented 'acquire-recursive-lock :timeout) (defun %acquire-recursive-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-recursive-lock :timeout)) (mp:get-lock lock waitp))) #+has-timeouts (defun %acquire-recursive-lock (lock waitp timeout) (mp:get-lock lock (cond ((not waitp) nil) (timeout timeout) (t t)))) (defun %release-recursive-lock (lock) (mp:giveup-lock lock)) #-has-timeouts (progn (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(mp:with-lock (,place) ,@body)))) #+has-timeouts (defmacro %with-recursive-lock ((place timeout) &body body) `(mp:with-lock (,place :wait-form (or ,timeout t)) ,@body)) ;;; ;;; Semaphores ;;; (deftype semaphore () 'mp:semaphore) (defun %make-semaphore (name count) (mp:make-semaphore :name name :count count)) (defun %signal-semaphore (semaphore count) (mp:signal-semaphore semaphore count)) (defun %wait-on-semaphore (semaphore timeout) (cond ((null timeout) (mp:wait-on-semaphore semaphore) t) ((plusp timeout) #-has-timeouts (handler-case (with-timeout (timeout) (mp:wait-on-semaphore semaphore) t) (timeout () nil)) #+has-timeouts (mp:semaphore-wait semaphore 1 timeout)) (t (if (mp:try-get-semaphore semaphore) t nil)))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mp:condition-variable) (defun %make-condition-variable ( name) (declare (ignore name)) (mp:make-condition-variable)) (defun %condition-wait (cv lock timeout) (if timeout #-has-timeouts (handler-case (with-timeout (timeout) (mp:condition-variable-wait cv lock)) (timeout () (%acquire-lock lock t nil) nil)) #+has-timeouts (mp:condition-variable-timedwait cv lock timeout) (mp:condition-variable-wait cv lock))) (defun %condition-notify (cv) (mp:condition-variable-signal cv)) (defun %condition-broadcast (cv) (mp:condition-variable-broadcast cv)) (eval-when (:compile-toplevel :execute) (setf *features* (remove :has-timeouts *features*))) bordeaux-threads-0.9.4/apiv2/impl-genera.lisp000066400000000000000000000166241463556250700211250ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS-2; Base: 10; -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'process:process) (defvar *thread-recursive-lock-key* 0) (defun %make-thread (function name) (flet ((top-level () (let ((*thread-recursive-lock-key* 0)) (funcall function)))) (declare (dynamic-extent #'top-level)) (process:process-run-function name #'top-level))) (defun %current-thread () scl:*current-process*) (defun %thread-name (thread) (process:process-name thread)) (defun %join-thread (thread) (process:process-wait (format nil "Join ~S" thread) #'(lambda (thread) (not (process:process-active-p thread))) thread)) (defun %thread-yield () (scl:process-allow-schedule)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () process:*all-processes*) (defun %interrupt-thread (thread function) (process:process-interrupt thread function)) (defun %destroy-thread (thread) (process:process-kill thread :force)) (defun %thread-alive-p (thread) (process:process-active-p thread)) ;;; ;;; Non-recursive locks ;;; (defstruct (%lock (:constructor make-%lock-internal)) lock lock-argument) (deftype native-lock () '%lock) (defun %make-lock (name) (let ((lock (process:make-lock name))) (make-%lock-internal :lock lock :lock-argument nil))) (defun %acquire-lock (lock waitp timeout) (check-type lock %lock) (let ((lock-argument (process:make-lock-argument (%lock-lock lock)))) (cond (waitp (if timeout (process:with-timeout (timeout) (process:with-no-other-processes (process:lock (%lock-lock lock) lock-argument) (setf (%lock-lock-argument lock) lock-argument) t)) (process:with-no-other-processes (process:lock (%lock-lock lock) lock-argument) (setf (%lock-lock-argument lock) lock-argument) t))) (t (process:with-no-other-processes (when (process:lock-lockable-p (%lock-lock lock)) (process:lock (%lock-lock lock) lock-argument) (setf (%lock-lock-argument lock) lock-argument) t)))))) (defun %release-lock (lock) (check-type lock %lock) (process:with-no-other-processes (process:unlock (%lock-lock lock) (scl:shiftf (%lock-lock-argument lock) nil)))) ;;; ;;; Recursive locks ;;; (defstruct (%recursive-lock (:constructor make-%recursive-lock-internal)) lock lock-arguments) (deftype native-recursive-lock () '%recursive-lock) (defun %make-recursive-lock (name) (make-%recursive-lock-internal :lock (process:make-lock name :recursive t) :lock-arguments (make-hash-table :test #'equal))) (defun %acquire-recursive-lock (lock waitp timeout) (check-type lock %recursive-lock) (let ((key (cons (incf *thread-recursive-lock-key*) scl:*current-process*)) (lock-argument (process:make-lock-argument (%recursive-lock-lock lock)))) (cond (waitp (if timeout (process:with-timeout (timeout) (process:with-no-other-processes (process:lock (%recursive-lock-lock lock) lock-argument) (setf (gethash key (%recursive-lock-lock-arguments lock)) lock-argument) t)) (process:with-no-other-processes (process:lock (%recursive-lock-lock lock) lock-argument) (setf (gethash key (%recursive-lock-lock-arguments lock)) lock-argument) t))) (t (process:with-no-other-processes (when (process:lock-lockable-p (%recursive-lock-lock lock)) (process:lock (%recursive-lock-lock lock) lock-argument) (setf (gethash key (%recursive-lock-lock-arguments lock)) lock-argument) t)))))) (defun %release-recursive-lock (lock) (check-type lock %recursive-lock) (let* ((key (cons *thread-recursive-lock-key* scl:*current-process*)) (lock-argument (gethash key (%recursive-lock-lock-arguments lock)))) (process:with-no-other-processes (prog1 (process:unlock (%recursive-lock-lock lock) lock-argument) (decf *thread-recursive-lock-key*) (remhash key (%recursive-lock-lock-arguments lock)))))) ;;; ;;; Condition variables ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (condition-variable (:constructor %make-condition-variable (name)) ;; CONDITION-VARIABLE-P is defined in API-CONDITION-VARIABLES.LISP (:predicate nil)) "Bordeaux-threads implementation of condition variables." name (waiters nil))) (defmethod print-object ((cv condition-variable) stream) (print-unreadable-object (cv stream :type t :identity t) (format stream "~S" (condition-variable-name cv)))) (defun %condition-wait (cv lock timeout) (check-type cv condition-variable) (check-type lock %lock) (process:with-no-other-processes (let ((waiter (cons scl:*current-process* nil))) (process:atomic-updatef (condition-variable-waiters cv) #'(lambda (waiters) (append waiters (scl:ncons waiter)))) (let ((expired? t)) (unwind-protect (progn (%release-lock lock) (process:block-with-timeout timeout (format nil "Waiting~@[ on ~A~]" (condition-variable-name cv)) #'(lambda (waiter expired?-loc) (when (not (null (cdr waiter))) (setf (sys:location-contents expired?-loc) nil) t)) waiter (sys:value-cell-location 'expired?)) expired?) (unless expired? (%acquire-lock lock t nil))))))) (defun %condition-notify (cv) (check-type cv condition-variable) (let ((waiter (process:atomic-pop (condition-variable-waiters cv)))) (when waiter (setf (cdr waiter) t) (process:wakeup (car waiter))))) (defun %condition-broadcast (cv) (check-type cv condition-variable) (loop for waiter in (process:atomic-replacef (condition-variable-waiters cv) nil) do (setf (cdr waiter) t) (process:wakeup (car waiter)))) ;;; ;;; Timeouts ;;; (defmacro with-timeout ((timeout) &body body) "Execute `BODY' and signal a condition of type TIMEOUT if the execution of BODY does not complete within `TIMEOUT' seconds." `(with-timeout-internal ,timeout #'(lambda () ,@body))) (defun with-timeout-internal (timeout function) ;; PROCESS:WITH-TIMEOUT either returns NIL on timeout or signals an error which, ;; unfortunately, does not have a distinguished type (i.e., it's a SYS:FATAL-ERROR). ;; So, rather than try to catch the error and signal our condition, we instead ;; ensure the return value from the PROCESS:WITH-TIMEOUT is never NIL if there is ;; no timeout. (Sigh) (let ((result (process:with-timeout (timeout) (cons 'success (multiple-value-list (funcall function)))))) (if result (values-list (cdr result)) (error 'timeout :length timeout)))) bordeaux-threads-0.9.4/apiv2/impl-lispworks.lisp000066400000000000000000000047711463556250700217210ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) #+(or lispworks4 lispworks5) (error 'bordeaux-threads-error :message "Threading not supported") ;;; ;;; Threads ;;; (deftype native-thread () 'mp:process) (defun %start-multiprocessing () (mp:initialize-multiprocessing)) (defun %make-thread (function name) (mp:process-run-function name nil function)) (defun %current-thread () (mp:get-current-process)) (defun %thread-name (thread) (mp:process-name thread)) (defun %join-thread (thread) (mp:process-join thread)) (defun %thread-yield () (mp:process-allow-scheduling)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mp:list-all-processes)) (defun %interrupt-thread (thread function) (mp:process-interrupt thread function)) (defun %destroy-thread (thread) (mp:process-kill thread)) (defun %thread-alive-p (thread) (mp:process-alive-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp:lock) (defun %make-lock (name) (mp:make-lock :name name :recursivep nil)) (defun %acquire-lock (lock waitp timeout) (mp:process-lock lock "Lock" (if waitp timeout 0))) (defun %release-lock (lock) (mp:process-unlock lock)) (defmacro %with-lock ((place timeout) &body body) `(mp:with-lock (,place nil ,timeout) ,@body)) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () '(and mp:lock (satisfies mp:lock-recursive-p))) (defun %make-recursive-lock (name) (mp:make-lock :name name :recursivep t)) (defun %acquire-recursive-lock (lock waitp timeout) (%acquire-lock lock waitp timeout)) (defun %release-recursive-lock (lock) (%release-lock lock)) (defmacro %with-recursive-lock ((place timeout) &body body) `(mp:with-lock (,place nil ,timeout) ,@body)) ;;; ;;; Semaphores ;;; (deftype semaphore () 'mp:semaphore) (defun %make-semaphore (name count) (mp:make-semaphore :name name :count count)) (defun %signal-semaphore (semaphore count) (mp:semaphore-release semaphore :count count)) (defun %wait-on-semaphore (semaphore timeout) (if (mp:semaphore-acquire semaphore :timeout timeout :count 1) t nil)) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mp:condition-variable) (defun %make-condition-variable (name) (mp:make-condition-variable :name name)) (defun %condition-wait (cv lock timeout) (mp:condition-variable-wait cv lock :timeout timeout)) (defun %condition-notify (cv) (mp:condition-variable-signal cv)) (defun %condition-broadcast (cv) (mp:condition-variable-broadcast cv)) bordeaux-threads-0.9.4/apiv2/impl-mcl.lisp000066400000000000000000000041141463556250700204260ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'ccl::process) (defun %make-thread (function name) (ccl:process-run-function name function)) (defun %current-thread () ccl:*current-process*) (defun %thread-name (thread) (ccl:process-name thread)) (mark-not-implemented 'join-thread) (defun %thread-join (thread) (declare (ignore thread)) (signal-not-implemented 'join-thread)) (defun %thread-yield () (ccl:process-allow-schedule)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () ccl:*all-processes*) (defun %interrupt-thread (thread function) (ccl:process-interrupt thread function)) (defun %destroy-thread (thread) (ccl:process-kill thread)) (mark-not-implemented 'thread-alive-p) (defun %thread-alive-p (thread) (declare (ignore thread)) (signal-not-implemented 'thread-alive-p)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'ccl:lock) (defun %make-lock (name) (ccl:make-lock name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (if waitp (ccl:process-lock lock ccl:*current-process*) ;; this is broken, but it's better than a no-op (ccl:without-interrupts (when (null (ccl::lock.value lock)) (ccl:process-lock lock ccl:*current-process*))))) (defun %release-lock (lock) (ccl:process-unlock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(ccl:with-lock-grabbed (,place) ,@body))) ;;; ;;; Recursive locks ;;; (mark-not-implemented 'acquire-recursive-lock) (defun %acquire-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'acquire-recursive-lock)) ;;; ;;; Condition variables ;;; (mark-not-implemented make-condition-variable) (defun %make-condition-variable (name) (declare (ignore name)) (signal-not-implemented make-condition-variable)) bordeaux-threads-0.9.4/apiv2/impl-mezzano.lisp000066400000000000000000000100171463556250700213350ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'mezzano.supervisor:thread) (defun %make-thread (function name) (mezzano.supervisor:make-thread function :name name)) (defun %current-thread () (mezzano.supervisor:current-thread)) (defun %thread-name (thread) (mezzano.supervisor:thread-name thread)) (defun %join-thread (thread) ;; THREAD-JOIN can return non-lists if the thread was destroyed. (let ((values (mezzano.supervisor:thread-join thread))) (if (listp values) (values-list values) nil))) (defun %thread-yield () (mezzano.supervisor:thread-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mezzano.supervisor:all-threads)) (defun %interrupt-thread (thread function) (mezzano.supervisor:establish-thread-foothold thread function)) (defun %destroy-thread (thread) (mezzano.supervisor:terminate-thread thread)) (defun %thread-alive-p (thread) (not (eql (mezzano.supervisor:thread-state thread) :dead))) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mezzano.supervisor:mutex) (defun %make-lock (name) (mezzano.supervisor:make-mutex name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (mezzano.supervisor:acquire-mutex lock waitp)) (defun %release-lock (lock) (mezzano.supervisor:release-mutex lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(mezzano.supervisor:with-mutex (,place) ,@body))) ;;; ;;; Recursive locks ;;; (defstruct (%recursive-lock (:constructor %make-recursive-lock-internal (mutex))) mutex (depth 0)) (deftype native-recursive-lock () '%recursive-lock) (defun %make-recursive-lock (name) (%make-recursive-lock-internal (%make-lock name))) (mark-not-implemented 'acquire-recursive-lock) (defun %acquire-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'acquire-recursive-lock)) (release-not-implemented 'release-recursive-lock) (defun %release-recursive-lock (lock) (declare (ignore lock)) (signal-not-implemented 'release-recursive-lock)) (defun call-with-recursive-lock-held (lock function) (cond ((mezzano.supervisor:mutex-held-p (%recursive-lock-mutex lock)) (unwind-protect (progn (incf (%recursive-lock-depth lock)) (funcall function)) (decf (%recursive-lock-depth lock)))) (t (mezzano.supervisor:with-mutex ((%recursive-lock-mutex lock)) (multiple-value-prog1 (funcall function) (assert (zerop (%recursive-lock-depth lock)))))))) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(call-with-recursive-lock-held ,place (lambda () ,@body)))) ;;; ;;; Semaphores ;;; (deftype semaphore () 'mezzano.sync:semaphore) (defun %make-semaphore (name count) (mezzano.sync:make-semaphore :name name :value count)) (defun %signal-semaphore (semaphore count) (dotimes (c count) (mezzano.sync:semaphore-up semaphore))) (defun %wait-on-semaphore (semaphore timeout) (mezzano.supervisor:event-wait-for (semaphore :timeout timeout) (mezzano.sync:semaphore-down semaphore :wait-p nil))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mezzano.supervisor:condition-variable) (defun %make-condition-variable (name) (mezzano.supervisor:make-condition-variable name)) (defun %condition-wait (cv lock timeout) (mezzano.supervisor:condition-wait cv lock timeout)) (defun %condition-notify (cv) (mezzano.supervisor:condition-notify cv)) (mark-not-implemented 'condition-broadcast) (defun %condition-broadcast (cv) (declare (ignore cv)) (signal-not-implemented 'condition-broadcast)) bordeaux-threads-0.9.4/apiv2/impl-mkcl.lisp000066400000000000000000000047051463556250700206070ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'mt:thread) (defun %make-thread (function name) (mt:thread-run-function name function)) (defun %current-thread () mt::*thread*) (defun %thread-name (thread) (mt:thread-name thread)) (defun %join-thread (thread) (mt:thread-join thread)) (defun %thread-yield () (mt:thread-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mt:all-threads)) (defun %interrupt-thread (thread function) (mt:interrupt-thread thread function)) (defun %destroy-thread (thread) (mt:thread-kill thread)) (defun %thread-alive-p (thread) (mt:thread-active-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'mp:lock) (defun %make-lock (name) (mp:make-lock :name name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (mp:get-lock lock waitp)) (defun %release-lock (lock) (mp:giveup-lock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(mp:with-lock (,place) ,@body))) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () '(and mp:lock (satisfies mp:recursive-lock-p))) (defun %make-recursive-lock (name) (mp:make-lock :name name :recursive t)) (mark-not-implemented 'acquire-recursive-lock :timeout) (defun %acquire-recursive-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-recursive-lock :timeout)) (mp:get-lock lock waitp)) (defun %release-recursive-lock (lock) (mp:giveup-lock lock)) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(mp:with-lock (,place) ,@body))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'mt:condition-variable) (defun %make-condition-variable (name) (declare (ignore name)) (mt:make-condition-variable)) (mark-not-implemented 'condition-wait :timeout) (defun %condition-wait (cv lock timeout) (when timeout (signal-not-implemented 'condition-wait :timeout)) (mt:condition-wait cv lock) t) (defun %condition-notify (cv) (mt:condition-signal cv)) (defun %condition-broadcast (cv) (mt:condition-broadcast cv)) bordeaux-threads-0.9.4/apiv2/impl-sbcl.lisp000066400000000000000000000076151463556250700206070ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'sb-thread:thread) (defun %make-thread (function name) (sb-thread:make-thread function :name name)) (defun %current-thread () sb-thread:*current-thread*) (defun %thread-name (thread) (sb-thread:thread-name thread)) (defun %join-thread (thread) (ignore-some-conditions (sb-thread:join-thread-error) (sb-thread:join-thread thread))) (defun %thread-yield () (sb-thread:thread-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (sb-thread:list-all-threads)) (defun %interrupt-thread (thread function) (sb-thread:interrupt-thread thread function)) (defun %destroy-thread (thread) (sb-thread:terminate-thread thread)) (defun %thread-alive-p (thread) (sb-thread:thread-alive-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'sb-thread:mutex) (defun %make-lock (name) (sb-thread:make-mutex :name name)) (defun %try-lock (lock) (sb-sys:without-interrupts (sb-thread:grab-mutex lock :waitp nil))) (defun %lock (lock) (sb-sys:without-interrupts (sb-sys:allow-with-interrupts (loop :while (not (sb-thread:grab-mutex lock :waitp t))) t))) (defun %timedlock (lock timeout) (let ((deadline (+ (get-internal-real-time) (* internal-time-units-per-second timeout)))) (sb-sys:without-interrupts (sb-sys:allow-with-interrupts (loop :while (not (sb-thread:grab-mutex lock :waitp t :timeout timeout)) :for now := (get-internal-real-time) :do (if (>= now deadline) (return-from %timedlock nil) (setf timeout (/ (- deadline now) internal-time-units-per-second)))) t)))) (defun %acquire-lock (lock waitp timeout) (cond ((not waitp) (%try-lock lock)) ((null timeout) (%lock lock)) (t (%timedlock lock timeout)))) (defun %release-lock (lock) (sb-sys:without-interrupts (sb-thread:release-mutex lock))) (defmacro %with-lock ((place timeout) &body body) `(sb-thread:with-mutex (,place :timeout ,timeout) ,@body)) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () 'sb-thread:mutex) (defun %make-recursive-lock (name) (sb-thread:make-mutex :name name)) (mark-not-implemented 'acquire-recursive-lock) (defun %acquire-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'acquire-recursive-lock)) (mark-not-implemented 'release-recursive-lock) (defun %release-recursive-lock (lock) (declare (ignore lock)) (signal-not-implemented 'release-recursive-lock)) (defmacro %with-recursive-lock ((place timeout) &body body) `(sb-thread:with-recursive-lock (,place :timeout ,timeout) ,@body)) ;;; ;;; Semaphores ;;; (deftype semaphore () 'sb-thread:semaphore) (defun %make-semaphore (name count) (sb-thread:make-semaphore :name name :count count)) (defun %signal-semaphore (semaphore count) (sb-thread:signal-semaphore semaphore count)) (defun %wait-on-semaphore (semaphore timeout) (cond ((and timeout (zerop timeout)) (sb-thread:try-semaphore semaphore)) (t (if (sb-thread:wait-on-semaphore semaphore :timeout timeout) t nil)))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'sb-thread:waitqueue) (defun %make-condition-variable (name) (sb-thread:make-waitqueue :name name)) (defun %condition-wait (cv lock timeout) (let ((success (sb-thread:condition-wait cv lock :timeout timeout))) (when (not success) (%acquire-lock lock t nil)) success)) (defun %condition-notify (cv) (sb-thread:condition-notify cv)) (defun %condition-broadcast (cv) (sb-thread:condition-broadcast cv)) ;;; ;;; Timeouts ;;; (defmacro with-timeout ((timeout) &body body) `(sb-ext:with-timeout ,timeout ,@body)) bordeaux-threads-0.9.4/apiv2/impl-scl.lisp000066400000000000000000000052331463556250700204370ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- (in-package :bordeaux-threads-2) ;;; ;;; Threads ;;; (deftype native-thread () 'thread:thread) (defun %make-thread (function name) (thread:thread-create function :name name)) (defun %current-thread () thread:*thread*) (defun %thread-name (thread) (thread:thread-name thread)) (defun %join-thread (thread) (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (named-lambda %thread-completed-p () (not (mp:process-alive-p thread))))) (defun %thread-yield () (mp:process-yield)) ;;; ;;; Introspection/debugging ;;; (defun %all-threads () (mp:all-processes)) (defun %interrupt-thread (thread function) (thread:thread-interrupt thread function)) (defun %destroy-thread (thread) (thread:destroy-thread thread)) (defun %thread-alive-p (thread) (mp:process-alive-p thread)) ;;; ;;; Non-recursive locks ;;; (deftype native-lock () 'thread:lock) (defun %make-lock (name) (thread:make-lock name)) (mark-not-implemented 'acquire-lock :timeout) (defun %acquire-lock (lock waitp timeout) (when timeout (signal-not-implemented 'acquire-lock :timeout)) (thread::acquire-lock lock nil wait-p)) (defun %release-lock (lock) (thread::release-lock lock)) (mark-not-implemented 'with-lock-held :timeout) (defmacro %with-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-lock-held :timeout) `(thread:with-lock-held (,place) ,@body))) ;;; ;;; Recursive locks ;;; (deftype native-recursive-lock () 'thread:recursive-lock) (defun %make-recursive-lock (name) (thread:make-lock name :type :recursive)) (mark-not-implemented 'acquire-recursive-lock) (defun %acquire-recursive-lock (lock waitp timeout) (declare (ignore lock waitp timeout)) (signal-not-implemented 'acquire-recursive-lock)) (mark-not-implemented 'release-recursive-lock) (defun %release-recursive-lock (lock) (declare (ignore lock)) (signal-not-implemented 'release-recursive-lock)) (mark-not-implemented 'with-recursive-lock-held :timeout) (defmacro %with-recursive-lock ((place timeout) &body body) (if timeout `(signal-not-implemented 'with-recursive-lock-held :timeout) `(thread:with-lock-held (,place) ,@body))) ;;; ;;; Condition variables ;;; (deftype condition-variable () 'thread:cond-var) (defun %make-condition-variable (name) (thread:make-cond-var name)) (defun %condition-wait (cv lock timeout) (if timeout (thread:cond-var-timedwait cv lock timeout) (thread:cond-var-wait cv lock))) (defun %condition-notify (cv) (thread:cond-var-signal cv)) (defun %condition-broadcast (cv) (thread:cond-var-broadcast v)) bordeaux-threads-0.9.4/apiv2/pkgdcl.lisp000066400000000000000000000066321463556250700201670ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- ;;;; The above modeline is required for Genera. Do not change. (defpackage :bt2 (:nicknames :bordeaux-threads-2) (:use :common-lisp :alexandria :global-vars) #+abcl (:import-from :java #:jnew #:jcall #:jclass #:jmethod) #+sbcl (:import-from :sb-ext #:timeout) (:export #:+supports-threads-p+ #:bordeaux-threads-error #:not-implemented) ;; Threads (:export #:thread #:thread-name #:thread-native-thread #:threadp #:make-thread #:*default-special-bindings* #:*standard-io-bindings* #:current-thread #:all-threads #:start-multiprocessing #:interrupt-thread #:signal-in-thread #:warn-in-thread #:error-in-thread #:destroy-thread #:thread-alive-p #:join-thread #:abnormal-exit #:abnormal-exit-condition #:thread-yield) ;; Locks (:export #:lock #:lockp #:recursive-lock #:recursive-lock-p #:lock-name #:lock-native-lock #:native-lock #:native-lock-p #:native-recursive-lock #:native-recursive-lock-p #:make-lock #:acquire-lock #:release-lock #:with-lock-held #:make-recursive-lock #:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held) ;; Condition variables (:export #:condition-variable #:condition-variable-p #:make-condition-variable #:condition-wait #:condition-notify #:condition-broadcast) ;; Semaphores (:export #:semaphore #:semaphorep #:make-semaphore #:signal-semaphore #:wait-on-semaphore) ;; Atomic operations (:export #:atomic-integer #:make-atomic-integer #:atomic-integer-compare-and-swap #:atomic-integer-decf #:atomic-integer-incf #:atomic-integer-value) ;; Timeouts (:export #:timeout #:with-timeout) (:documentation "BORDEAUX-THREADS 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. To avoid conflict with existing MP/threading interfaces in implementations, these symbols live in the BORDEAUX-THREADS-2 package. Implementations and/or users may also make them visible or exported in other more traditionally named packages.")) bordeaux-threads-0.9.4/apiv2/timeout-interrupt.lisp000066400000000000000000000042401463556250700224340ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2) #-(or allegro clisp cmu genera sbcl) (define-condition interrupt () ((tag :initarg :tag :reader interrupt-tag))) #-(or allegro clisp cmu genera sbcl) (defmacro with-timeout ((timeout) &body body) "Execute `BODY' and signal a condition of type TIMEOUT if the execution of BODY does not complete within `TIMEOUT' seconds. On implementations which do not support WITH-TIMEOUT natively and don't support threads either it signals a condition of type `NOT-IMPLEMENTED`." (declare (ignorable timeout body)) #+thread-support (once-only (timeout) (with-gensyms (ok-tag interrupt-tag caller interrupt-thread c) `(let (,interrupt-thread) (unwind-protect-case () (catch ',ok-tag (let* ((,interrupt-tag (gensym "INTERRUPT-TAG-")) (,caller (current-thread))) (setf ,interrupt-thread (make-thread #'(lambda () (sleep ,timeout) (interrupt-thread ,caller #'(lambda () (signal 'interrupt :tag ,interrupt-tag)))) :name (format nil "WITH-TIMEOUT thread serving: ~S." (thread-name ,caller)))) (handler-bind ((interrupt #'(lambda (,c) (when (eql ,interrupt-tag (interrupt-tag ,c)) (error 'timeout :length ,timeout))))) (throw ',ok-tag (progn ,@body))))) (:normal (when (and ,interrupt-thread (thread-alive-p ,interrupt-thread)) ;; There's a potential race condition between THREAD-ALIVE-P ;; and DESTROY-THREAD but calling the latter when a thread already ;; terminated should not be a grave matter. (ignore-errors (destroy-thread ,interrupt-thread)))))))) #-thread-support `(signal-not-implemented 'with-timeout)) bordeaux-threads-0.9.4/bordeaux-threads.asd000066400000000000000000000122141463556250700207340ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: ASDF -*- ;;;; The above modeline is required for Genera. Do not change. #.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) (error "You need ASDF >= 3.1 to load this system correctly.")) (eval-when (:compile-toplevel :load-toplevel :execute) #+(or armedbear (and allegro multiprocessing) (and clasp threads) (and clisp mt) (and openmcl openmcl-native-threads) (and cmu mp) corman (and ecl threads) genera mezzano mkcl lispworks (and digitool ccl-5.1) (and sbcl sb-thread) scl) (pushnew :thread-support *features*)) #-thread-support (error "This implementation is unsupported.") (defsystem :bordeaux-threads :author "Stelian Ionescu " :licence "MIT" :description "Bordeaux Threads makes writing portable multi-threaded apps simple." :version (:read-file-form "version.sexp") :depends-on (:alexandria :global-vars :trivial-features :trivial-garbage #+(and allegro (version>= 9)) (:require "smputil") #+(and allegro (not (version>= 9))) (:require "process") (:feature :corman (:require "threads"))) :components ((:static-file "version.sexp") (:module "api-v1" :pathname "apiv1/" :serial t :components ((:file "pkgdcl") (:file "bordeaux-threads") (:file "impl-abcl" :if-feature :armedbear) (:file "impl-allegro" :if-feature :allegro) (:file "impl-clasp" :if-feature :clasp) (:file "impl-clisp" :if-feature :clisp) (:file "impl-clozure" :if-feature :openmcl) (:file "impl-cmucl" :if-feature :cmu) (:file "impl-corman" :if-feature :corman) (:file "impl-ecl" :if-feature :ecl) (:file "impl-genera" :if-feature :genera) (:file "impl-mezzano" :if-feature :mezzano) (:file "impl-mkcl" :if-feature :mkcl) (:file "impl-lispworks" :if-feature :lispworks) (:file "impl-mcl" :if-feature :digitool) (:file "impl-sbcl" :if-feature :sbcl) (:file "impl-scl" :if-feature :scl) (:file "impl-lispworks-condition-variables" :if-feature (:and :lispworks (:or :lispworks4 :lispworks5))) (:file "condition-variables" :if-feature :digitool) (:file "default-implementations"))) (:module "api-v2" :pathname "apiv2/" :depends-on ("api-v1") :serial t :components ((:file "pkgdcl") (:file "bordeaux-threads") (:file "timeout-interrupt") (:file "impl-abcl" :if-feature :abcl) (:file "impl-allegro" :if-feature :allegro) (:file "impl-clasp" :if-feature :clasp) (:file "impl-clisp" :if-feature :clisp) (:file "impl-clozure" :if-feature :clozure) (:file "impl-cmucl" :if-feature :cmu) (:file "impl-corman" :if-feature :corman) (:file "impl-ecl" :if-feature :ecl) (:file "impl-genera" :if-feature :genera) (:file "impl-mezzano" :if-feature :mezzano) (:file "impl-mkcl" :if-feature :mkcl) (:file "impl-lispworks" :if-feature :lispworks) (:file "impl-mcl" :if-feature :digitool) (:file "impl-sbcl" :if-feature :sbcl) (:file "impl-scl" :if-feature :scl) (:file "atomics" :if-feature (:not :abcl)) (:file "atomics-java" :if-feature :abcl) (:file "api-locks") (:file "api-threads") (:file "api-semaphores") (:file "impl-condition-variables-semaphores" :if-feature :ccl) (:file "api-condition-variables")))) :in-order-to ((test-op (test-op :bordeaux-threads/test)))) (defsystem :bordeaux-threads/test :author "Stelian Ionescu " :description "Bordeaux Threads test suite." :licence "MIT" :version (:read-file-form "version.sexp") :depends-on (:bordeaux-threads :fiveam) :pathname "test/" :serial t :components ((:file "tests-v1") (:file "pkgdcl") (:file "not-implemented") (:file "tests-v2")) :perform (test-op (o c) (symbol-call :5am :run! :bordeaux-threads) (symbol-call :5am :run! :bordeaux-threads-2))) bordeaux-threads-0.9.4/docs/000077500000000000000000000000001463556250700157325ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/archetypes/000077500000000000000000000000001463556250700201015ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/archetypes/default.md000066400000000000000000000001241463556250700220440ustar00rootroot00000000000000--- title: "{{ replace .Name "-" " " | title }}" date: {{ .Date }} draft: true --- bordeaux-threads-0.9.4/docs/config.toml000066400000000000000000000033471463556250700201030ustar00rootroot00000000000000baseURL = "https://sionescu.github.io/bordeaux-threads/" languageCode = "en-us" title = "Bordeaux-Threads" theme = "techdoc" publishDir = "public" defaultContentLanguage = "en" defaultContentLanguageInSubdir= false enableMissingTranslationPlaceholders = false [params] # Source Code repository section description = "Common Lisp threading library" github_repository = "https://github.com/sionescu/bordeaux-threads" version = "0.8.8" # Documentation repository section # documentation repository (set edit link to documentation repository) github_doc_repository = "https://github.com/sionescu/bordeaux-threads" # Theme settings section # Theme color # See color value reference https://developer.mozilla.org/en-US/docs/Web/CSS/color custom_font_color = "" custom_background_color = "" # Documentation Menu section # Menu style settings menu_style = "slide-menu" # "open-menu" or "slide-menu" # Date format dateformat = "2006-01-02" # default "2 Jan 2006" # See the format reference https://gohugo.io/functions/format/#hugo-date-and-time-templating-reference # path name excluded from documentation menu menu_exclusion = [ "archives", "archive", "blog", "entry", "post", "posts", ] # Global menu section # See https://gohugo.io/content-management/menus/ [menu] [[menu.main]] name = "Home" url = "/" weight = 1 # Markup configure section # See https://gohugo.io/getting-started/configuration-markup/ [markup] defaultMarkdownHandler = "goldmark" [markup.goldmark.renderer] unsafe = true [markup.tableOfContents] startLevel = 2 endLevel = 6 ordered = false bordeaux-threads-0.9.4/docs/content/000077500000000000000000000000001463556250700174045ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/_index.md000066400000000000000000000036701463556250700212020ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Documentation --- ## Raison d'être Bordeaux-Threads is a minimal library that aims to provide the basic concepts required for multi-threading programming, such as threads, mutexes, semaphores and condition variables. Higher-level data structures such as queues, mailboxes, thread pools, execution graphs, etc... tend to be more specialized and are better left to other libraries. This document describes the second version of the API (APIv2), which differs from the first version in a few key points and aims to provide a more uniformous interface across all Common Lisp implementations. ## Migration from APIv1 to APIv2 APIv2 is mostly compatible with v1, and in most cases it should suffice to replace all references to package `bordeaux-threads` (or `bt`) with `bordeaux-threads-2` (or `bt2`). For more details, there's a [blog post](https://blog.cddr.org/posts/2023-05-27-bordeaux-threads-apiv2/). ## Host support When Bordeaux-Threads was created, most Common Lisp implementations were either single-threaded or provided user-space scheduling akin to green threads, and therefore Bordeaux-Threads tried to support all such implementations as well as possible. Bordeaux-Threads APIV2 no longer supports single-threaded implementations and was conceived to work best with hosts that provide SMP threads. In most cases Bordeaux-Threads simply wraps the primitives provided by the host implementation. Whenever the primitives are absent from the host, we try to provide an ersatz implementation that is optimized for correctness and readability rather than performance. The two absolutely necessary primitives are **threads** and **locks**. **Semaphores** and **condition variables** can be implemented in terms of one another, and that's the case on a few implementations. **Atomic operations** vary greatly in what kind of forms they operate on so we do not expose them, instead providing slightly higher-level constructs. bordeaux-threads-0.9.4/docs/content/atomics/000077500000000000000000000000001463556250700210435ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/atomics/_index.md000066400000000000000000000007221463556250700226340ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Atomics dictionary weight: 6 --- ##### [Class ATOMIC-INTEGER](atomic-integer) ##### [Function ATOMIC-INTEGER-P](atomic-integer-p) ##### [Function MAKE-ATOMIC-INTEGER](make-atomic-integer) ##### [Function ATOMIC-INTEGER-CAS](atomic-integer-cas) ##### [Function ATOMIC-INTEGER-DECF](atomic-integer-decf) ##### [Function ATOMIC-INTEGER-INCF](atomic-integer-incf) ##### [Function ATOMIC-INTEGER-VALUE](atomic-integer-value) bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer-compare-and-swap.md000066400000000000000000000030441463556250700274310ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ATOMIC-INTEGER-COMPARE-AND-SWAP weight: 4 --- #### Syntax: **atomic-integer-compare-and-swap** atomic-integer old new => generalized-boolean #### Arguments and values: *atomic-integer* -> an [**atomic-integer**](../atomic-integer) object.\ *old*, *new* -> non-negative integers.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description If the current value of `atomic-integer` is equal to `old`, replace it with `new`. Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if the replacement was successful, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `old` is not a non-negative integer.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `new` is not a non-negative integer. #### See also: [**atomic-integer**](../atomic-integer), [**atomic-integer-incf**](../atomic-integer-incf), [**atomic-integer-decf**](../atomic-integer-decf), [**make-atomic-integer**](../make-atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer-decf.md000066400000000000000000000017631463556250700252020ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ATOMIC-INTEGER-DECF weight: 5 --- #### Syntax: **atomic-integer-decf** atomic-integer *&optional* (delta 1) => new-value #### Arguments and values: *atomic-integer* -> an [**atomic-integer**](../atomic-integer) object.\ *delta* -> an integer.\ *new-value* -> a non-negative integer. #### Description Decrements the value of `atomic-integer` by `delta`. Returns the new value of `atomic-integer`. #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `delta` is not an integer. #### See also: [**atomic-integer**](../atomic-integer), [**atomic-integer-incf**](../atomic-integer-incf), [**make-atomic-integer**](../make-atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer-incf.md000066400000000000000000000017631463556250700252200ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ATOMIC-INTEGER-INCF weight: 6 --- #### Syntax: **atomic-integer-incf** atomic-integer *&optional* (delta 1) => new-value #### Arguments and values: *atomic-integer* -> an [**atomic-integer**](../atomic-integer) object.\ *delta* -> an integer.\ *new-value* -> a non-negative integer. #### Description Increments the value of `atomic-integer` by `delta`. Returns the new value of `atomic-integer`. #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `delta` is not an integer. #### See also: [**atomic-integer**](../atomic-integer), [**atomic-integer-decf**](../atomic-integer-decf), [**make-atomic-integer**](../make-atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer-p.md000066400000000000000000000013741463556250700245360ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ATOMIC-INTEGER-P weight: 2 --- #### Syntax: **atomic-integer-p** datum => generalized-boolean #### Arguments and values: *datum* -> an object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is an [**atomic-integer**](../atomic-integer] object, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**atomic-integer**](../atomic-integer), [**make-atomic-integer**](../make-atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer-value.md000066400000000000000000000013021463556250700254020ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ATOMIC-INTEGER-VALUE weight: 7 --- #### Syntax: **atomic-integer-value** atomic-integer => value #### Arguments and values: *atomic-integer* -> an [**atomic-integer**](../atomic-integer) object.\ *value* -> a non-negative integer. #### Description Returns the current value of `atomic-integer`. #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) object. #### See also: [**atomic-integer**](../atomic-integer), [**make-atomic-integer**](../make-atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/atomics/atomic-integer.md000066400000000000000000000010571463556250700242770ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class ATOMIC-INTEGER weight: 1 --- #### Class precedence list: atomic-integer, t. #### Description: This class represents an unsigned machine word that allows atomic increment, decrement and swap. #### See also: [**make-atomic-integer**](../make-atomic-integer) #### Notes: Depending on the host implementation, the size of the integer is either 32 or 64 bits. This class is unavailble on Lisp implementations that lack underlying atomic primitives. On some hosts, **atomic-integer** is implemented using locks. bordeaux-threads-0.9.4/docs/content/atomics/make-atomic-integer.md000066400000000000000000000012041463556250700252040ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function MAKE-ATOMIC-INTEGER weight: 3 --- #### Syntax: **make-atomic-integer** *&key* value => atomic-integer #### Arguments and values: *value* -> a non-negative integer.\ *semaphore* -> a [**semaphore**](../semaphore) object. #### Description: Creates an atomic integer `name` and initial value `value`. #### Exceptional situations: Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `value` is not a non-negative integer (an unsigned-byte). #### See also: [**atomic-integer**](../atomic-integer) #### Notes: None. bordeaux-threads-0.9.4/docs/content/condition-variables/000077500000000000000000000000001463556250700233405ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/condition-variables/_index.md000066400000000000000000000006521463556250700251330ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Condition Variables dictionary weight: 4 --- ##### [Class CONDITION-VARIABLE](condition-variable) ##### [Function CONDITION-VARIABLE-P](condition-variable-p) ##### [Function MAKE-CONDITION-VARIABLE](make-condition-variable) ##### [Function CONDITION-WAIT](condition-wait) ##### [Function CONDITION-NOTIFY](condition-notify) ##### [Function CONDITION-BROADCAST](condition-broadcast) bordeaux-threads-0.9.4/docs/content/condition-variables/condition-broadcast.md000066400000000000000000000024041463556250700276100ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function CONDITION-BROADCAST weight: 6 --- #### Syntax: **condition-broadcast** condition-variable -> generalized-boolean #### Arguments and values: *condition-variable* -> a [**condition-variable**](../condition-variable) object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Notify all the threads waiting for `condition-variable`. Returns always [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `condition-variable` is not a [**condition-variable**](../condition-variable) object. #### See also: [**condition-wait**](./condition-wait), [**condition-notify**](./condition-notify) #### Notes: The order of wakeup is unspecified and does not necessarily relate to the order in which the threads went to sleep. **condition-broadcast** always returns [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) because not all implementations' primitives can tell whether or not some threads were indeed woken up. bordeaux-threads-0.9.4/docs/content/condition-variables/condition-notify.md000066400000000000000000000024161463556250700271610ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function CONDITION-NOTIFY weight: 5 --- #### Syntax: **condition-notify** condition-variable -> generalized-boolean #### Arguments and values: *condition-variable* -> a [**condition-variable**](../condition-variable) object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Notify one of the threads waiting for `condition-variable`. Returns always [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `condition-variable` is not a [**condition-variable**](../condition-variable) object. #### See also: [**condition-wait**](./condition-wait), [**condition-broadcast**](./condition-broadcast) #### Notes: It is unspecified which thread gets a wakeup and does not necessarily relate to the order in which the threads went to sleep. **condition-notify** always returns [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) because not all implementations' primitives can tell whether or not some threads were indeed woken up. bordeaux-threads-0.9.4/docs/content/condition-variables/condition-variable-p.md000066400000000000000000000014331463556250700276710ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function CONDITION-VARIABLE-P weight: 2 --- #### Syntax: **condition-variable-p** datum => generalized-boolean #### Arguments and values: *datum* -> an object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a [**condition-variable**](../condition-variable) object, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**condition-variable**](../condition-variable), [**make-condition-variable**](../make-condition-variable) #### Notes: None. bordeaux-threads-0.9.4/docs/content/condition-variables/condition-variable.md000066400000000000000000000006571463556250700274430ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class CONDITION-VARIABLE weight: 1 --- #### Class precedence list: Implementation-defined. #### Description: This class represents condition variables. #### See also: [**make-condition-variable**](../make-condition-variable) #### Notes: On some implementations the library exposes the native type directly, while on others there is a custom implementations using semaphores and locks. bordeaux-threads-0.9.4/docs/content/condition-variables/condition-wait.md000066400000000000000000000046451463556250700266230ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function CONDITION-WAIT weight: 4 --- #### Syntax: **condition-wait** condition-variable lock *&key* timeout => generalized-boolean #### Arguments and values: *condition-variable* -> a [**condition-variable**](../condition-variable) object.\ *lock* -> a [**lock**](../lock) object.\ *timeout* -> a non-negative real number.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: 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**](./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.\ It is an error to call this function unless from the thread that holds `lock`. If `timeout` is nil or not provided, the call blocks until a notification is received.\ If `timeout` is non-nil, the call will return after at most `timeout` seconds (approximately), whether or not a notification has occurred. Either **true** or **false** will be returned. **false** indicates that the timeout has expired without receiving a notification. **true** indicates that a notification was received. #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `condition-variable` is not a [**condition-variable**](../condition-variable) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `lock` is not a [**lock**](../lock) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**condition-notify**](./condition-notify), [**condition-broadcast**](./condition-broadcast) #### Notes: Due to implementation limitations, there is the possibility of spurious wakeups, i.e. for **condition-wait** to return **true** without the underlying condition being satisfied. Correct code must always check whether the condition is satisfied, and otherwise call **condition-wait** again, typically in a loop. bordeaux-threads-0.9.4/docs/content/condition-variables/make-condition-variable.md000066400000000000000000000014211463556250700303440ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function MAKE-CONDITION-VARIABLE weight: 3 --- #### Syntax: **make-condition-variable** *&key* name => condition-variable #### Arguments and values: *name* -> a string or nil.\ *condition-variable* -> a [**condition-variable**](../condition-variable) object. #### Description: Creates a condition variable named `name`. #### Exceptional situations: Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `name` is neither a string nor nil. #### See also: [**condition-variable**](../condition-variable) #### Notes: On some implementations the library exposes the native type directly, while on others there is a custom implementations using semaphores and locks. bordeaux-threads-0.9.4/docs/content/locks/000077500000000000000000000000001463556250700205175ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/locks/_index.md000066400000000000000000000015611463556250700223120ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Locks dictionary weight: 3 --- ##### [Class LOCK](lock) ##### [Function LOCKP](lockp) ##### [Class RECURSIVE-LOCK](recursive-lock) ##### [Function RECURSIVE-LOCK-P](recursive-lock-p) ##### [Function LOCK-NAME, LOCK-NATIVE-LOCK](lock-readers) ##### [Host type NATIVE-LOCK](native-lock) ##### [Function NATIVE-LOCK-P](native-lock-p) ##### [Host type NATIVE-RECURSIVE-LOCK](native-recursive-lock) ##### [Function NATIVE-RECURSIVE-LOCK-P](native-recursive-lock-p) ##### [Function MAKE-LOCK](make-lock) ##### [Function ACQUIRE-LOCK, RELEASE-LOCK](acquire-release-lock) ##### [Macro WITH-LOCK-HELD](with-lock-held) ##### [Function MAKE-RECURSIVE-LOCK](make-recursive-lock) ##### [Function ACQUIRE-RECURSIVE-LOCK, RELEASE-RECURSIVE-LOCK](acquire-release-recursive-lock) ##### [Macro WITH-RECURSIVE-LOCK-HELD](with-recursive-lock-held) bordeaux-threads-0.9.4/docs/content/locks/acquire-release-lock.md000066400000000000000000000032671463556250700250460ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ACQUIRE-LOCK, RELEASE-LOCK weight: 11 --- #### Syntax: **acquire-lock** lock &key (wait t) timeout => generalized-boolean\ **release-lock** lock => lock #### Arguments and values: *lock* -> a [**lock**](../lock) object.\ *wait* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean).\ *timeout* -> a non-negative real number.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Acquire `lock` for the calling thread. `wait` governs what happens if the lock is not available: if `wait` is true, the calling thread will wait until the lock is available and then acquire it; if `wait` is nil, `acquire-lock` will return immediately. If `wait` is true, `timeout` may specify a maximum amount of seconds to wait for the lock to become available. `acquire-lock` returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if the lock was acquired, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `lock` is not a [**lock**](../lock) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**lock**](../lock) #### Notes: It is implementation-defined what happens if a thread attempts to acquire a lock that it already holds. bordeaux-threads-0.9.4/docs/content/locks/acquire-release-recursive-lock.md000066400000000000000000000033151463556250700270450ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function ACQUIRE-RECURSIVE-LOCK, RELEASE-RECURSIVE-LOCK weight: 14 --- #### Syntax: **acquire-recursive-lock** lock &key (wait t) timeout => generalized-boolean\ **release-recursive-lock** lock => lock #### Arguments and values: *lock* -> a [**recursive-lock**](../recursive-lock) object.\ *wait* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean).\ *timeout* -> a non-negative real number.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Acquire `lock` for the calling thread. `wait` governs what happens if the lock is not available: if `wait` is true, the calling thread will wait until the lock is available and then acquire it; if `wait` is nil, `acquire-recursive-lock` will return immediately. If `wait` is true, `timeout` may specify a maximum amount of seconds to wait for the lock to become available. `acquire-recursive-lock` returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if the lock was acquired, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `lock` is not a [**recursive-lock**](../recursive-lock) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**recursive-lock**](../recursive-lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/lock-readers.md000066400000000000000000000011221463556250700234100ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function LOCK-NAME, LOCK-NATIVE-LOCK weight: 5 --- #### Syntax: **lock-name** lock => name\ **lock-native-lock** lock => native-lock #### Arguments and values: *lock* -> a [lock](../lock) object.\ *name* -> a string or nil.\ *native-lock* -> a native lock object. #### Description: **lock-name** returns the lock name, or **nil** of the lock was not given a name on creation.\ **lock-native-lock** returns the native lock object that is wrapped by `lock`. #### Exceptional situations: None. #### See also: [**lock**](../lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/lock.md000066400000000000000000000003521463556250700217710ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class LOCK weight: 1 --- #### Class precedence list: [lock](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) #### Description: Wrapper for a native non-recursive lock. bordeaux-threads-0.9.4/docs/content/locks/lockp.md000066400000000000000000000012021463556250700221440ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function LOCKP weight: 2 --- #### Syntax: **lockp** datum => generalized-boolean #### Arguments and values: *datum* -> an object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a non-recursive lock, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**lock**](../lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/make-lock.md000066400000000000000000000011761463556250700227110ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function MAKE-LOCK weight: 10 --- #### Syntax: **make-lock** *&key* name => lock #### Arguments and values: *name* -> a string or nil.\ *lock* -> a [**lock**](../lock) object. #### Description: Creates a non-recursive lock named `name`. #### Exceptional situations: Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `name` is neither a string nor nil. #### See also: [**lock**](../lock) #### Notes: A lock is also commonly known as a **mutex**. On some implementations, the host lock type is always recursive. bordeaux-threads-0.9.4/docs/content/locks/make-recursive-lock.md000066400000000000000000000011641463556250700247130ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function MAKE-RECURSIVE-LOCK weight: 13 --- #### Syntax: **make-recursive-lock** *&key* name => lock #### Arguments and values: *name* -> a string or nil.\ *lock* -> a [**recursive-lock**](../recursive-lock) object. #### Description: Creates a recursive lock named `name`. #### Exceptional situations: Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `name` is neither a string nor nil. #### See also: [**recursive-lock**](../recursive-lock) #### Notes: A lock is also commonly known as a **mutex**. bordeaux-threads-0.9.4/docs/content/locks/native-lock-p.md000066400000000000000000000013111463556250700235060ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function NATIVE-LOCK-P weight: 7 --- #### Syntax: **native-lock-p** lock => generalized-boolean #### Arguments and values: *lock* -> a [lock](../lock) object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a native non-recursive lock, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**lock**](../lock), [**native-lock**](../native-lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/native-lock.md000066400000000000000000000005361463556250700232610ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Host type NATIVE-LOCK weight: 6 --- #### Class precedence list: Implementation-defined. #### Description: A `native-lock` represents the non-recursive lock type exported by the host implementation. #### See also: [**lock**](../lock) #### Notes: The exact type of `native-lock` is implementation-defined. bordeaux-threads-0.9.4/docs/content/locks/native-recursive-lock-p.md000066400000000000000000000014251463556250700255210ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function NATIVE-RECURSIVE-LOCK-P weight: 9 --- #### Syntax: **native-recursive-lock-p** lock => generalized-boolean #### Arguments and values: *lock* -> a [recursive-lock](../recursive-lock) object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a native recursive lock, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**recursive-lock**](../recursive-lock), [**native-recursive-lock**](../native-recursive-lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/native-recursive-lock.md000066400000000000000000000006141463556250700252630ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Host type NATIVE-RECURSIVE-LOCK weight: 8 --- #### Class precedence list: Implementation-defined. #### Description: A `native-recursive-lock` represents the recursive lock type exported by the host implementation. #### See also: [**recursive-lock**](../recursive-lock) #### Notes: The exact type of `native-recursive-lock` is implementation-defined. bordeaux-threads-0.9.4/docs/content/locks/recursive-lock-p.md000066400000000000000000000012501463556250700242310ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function RECURSIVE-LOCK-P weight: 4 --- #### Syntax: **recursive-lock-p** datum => generalized-boolean #### Arguments and values: *datum* -> an object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a recursive lock, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**recursive-lock**](../recursive-lock) #### Notes: None. bordeaux-threads-0.9.4/docs/content/locks/recursive-lock.md000066400000000000000000000003721463556250700240000ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class RECURSIVE-LOCK weight: 3 --- #### Class precedence list: [recursive-lock](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) #### Description: Wrapper for a native recursive lock. bordeaux-threads-0.9.4/docs/content/locks/with-lock-held.md000066400000000000000000000025521463556250700236600ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Macro WITH-LOCK-HELD weight: 12 --- #### Syntax: **with-lock-held** (lock *&key* timeout) declaration\* forms\* => results #### Arguments and values: *lock* -> a [**lock**](../lock) object.\ *timeout* -> a non-negative real number.\ *declaration* -> a declare expression; not evaluated.\ *forms* -> an implicit progn.\ *results* -> the values returned by the forms. #### Description: Evaluates `forms`. Before the forms in BODY are evaluated, `lock` is acquired as if by using [**acquire-lock**](../acquire-lock). After the forms 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**](../release-lock). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) is `lock` is not a [**lock**](../lock) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**lock**](../lock), [**acquire-lock**](../acquire-lock), [**release-lock**](../release-lock) #### Notes: If the debugger is entered, it is unspecified whether the lock is released at debugger entry or at debugger exit when execution is restarted. bordeaux-threads-0.9.4/docs/content/locks/with-recursive-lock-held.md000066400000000000000000000030121463556250700256550ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Macro WITH-RECURSIVE-LOCK-HELD weight: 15 --- #### Syntax: **with-recursive-lock-held** (lock *&key* timeout) declaration\* forms\* => results #### Arguments and values: *lock* -> a [**recursive-lock**](../recursive-lock) object.\ *timeout* -> a non-negative real number.\ *declaration* -> a declare expression; not evaluated.\ *forms* -> an implicit progn.\ *results* -> the values returned by the forms. #### Description: Evaluates `forms`. Before the forms in BODY are evaluated, `lock` is acquired as if by using [**acquire-recursive-lock**](../acquire-recursive-lock). After the forms 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-recursive-lock**](../release-recursive-lock). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) is `lock` is not a [**recursive-lock**](../recursive-lock) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**recursive-lock**](../recursive-lock), [**acquire-recursive-lock**](../acquire-recursive-lock), [**release-recursive-lock**](../release-recursive-lock) #### Notes: If the debugger is entered, it is unspecified whether the lock is released at debugger entry or at debugger exit when execution is restarted. bordeaux-threads-0.9.4/docs/content/semaphores/000077500000000000000000000000001463556250700215525ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/semaphores/_index.md000066400000000000000000000004641463556250700233460ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Semaphores dictionary weight: 5 --- ##### [Class SEMAPHORE](semaphore) ##### [Function SEMAPHOREP](semaphorep) ##### [Function MAKE-SEMAPHORE](make-semaphore) ##### [Function SIGNAL-SEMAPHORE](signal-semaphore) ##### [Function WAIT-ON-SEMAPHORE](wait-on-semaphore) bordeaux-threads-0.9.4/docs/content/semaphores/make-semaphore.md000066400000000000000000000017121463556250700247730ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function MAKE-SEMAPHORE weight: 3 --- #### Syntax: **make-semaphore** *&key* name count => semaphore #### Arguments and values: *name* -> a string or nil.\ *count* -> non-negative integer.\ *semaphore* -> a [**semaphore**](../semaphore) object. #### Description: Creates a semaphore named `name` and with initial value `count`. #### Exceptional situations: Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `name` is neither a string nor nil.\ Signals a condition of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `count` is not a non-negative integer (an unsigned-byte). #### See also: [**semaphore**](../semaphore) #### Notes: On some implementations the library exposes the native type directly, while on others there is a custom implementations using condition variables and locks. bordeaux-threads-0.9.4/docs/content/semaphores/semaphore.md000066400000000000000000000006241463556250700240610ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class SEMAPHORE weight: 1 --- #### Class precedence list: Implementation-defined. #### Description: This class represents semaphores. #### See also: [**make-semaphore**](../make-semaphore) #### Notes: On some implementations the library exposes the native type directly, while on others there is a custom implementations using condition variables and locks. bordeaux-threads-0.9.4/docs/content/semaphores/semaphorep.md000066400000000000000000000013211463556250700242340ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function SEMAPHOREP weight: 2 --- #### Syntax: **semaphorep** datum => generalized-boolean #### Arguments and values: *datum* -> an object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `datum` is a [**semaphore**](../semaphore) object, otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### See also: [**semaphore**](../semaphore), [**make-semaphore**](../make-semaphore) #### Notes: None. bordeaux-threads-0.9.4/docs/content/semaphores/signal-semaphore.md000066400000000000000000000016071463556250700253360ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function SIGNAL-SEMAPHORE weight: 4 --- #### Syntax: **signal-semaphore** semaphore -> t #### Arguments and values: *semaphore* -> a [**semaphore**](../semaphore) object. #### Description: Increment `semaphore` by `count`. If there are threads waiting on this semaphore, then `count` of them are woken up. Returns always [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true). #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `semaphore` is not a [**semaphore**](../semaphore) object. #### See also: [**make-semaphore**](./make-semaphore), [**wait-on-semaphore**](./wait-on-semaphore) #### Notes: It is unspecified which thread gets a wakeup and does not necessarily relate to the order in which the threads went to sleep. bordeaux-threads-0.9.4/docs/content/semaphores/wait-on-semaphore.md000066400000000000000000000033661463556250700254430ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Function WAIT-ON-SEMAPHORE weight: 5 --- #### Syntax: **wait-on-semaphore** semaphore *&key* timeout -> generalized-boolean #### Arguments and values: *semaphore* -> a [**semaphore**](../semaphore) object.\ *timeout* -> a non-negative real number.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Decrement the count of `semaphore` by 1 if the count is larger than zero.\ If the count is zero, blocks until `semaphore` can be decremented. Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) on success. If `timeout` is given, it is the maximum number of seconds to wait. If the count cannot be decremented in that time, returns [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) without decrementing the count. #### Exceptional situations: Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `semaphore` is not a [**semaphore**](../semaphore) object.\ Signals an error of type [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) if `timeout` is neither nil nor a non-negative real number. #### See also: [**make-semaphore**](./make-semaphore), [**wait-on-semaphore**](./wait-on-semaphore) #### Notes: It is unspecified which thread gets a wakeup and does not necessarily relate to the order in which the threads went to sleep. On Allegro, a non-null `timeout` is forced to a minimum of 100ms, because Allegro does not provide a primitive for waiting with a timeout, which is emulated using [**with-timeout**](../../timeouts/with-timeout). bordeaux-threads-0.9.4/docs/content/threads/000077500000000000000000000000001463556250700210365ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/threads/_index.md000066400000000000000000000017021463556250700226260ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Threads dictionary weight: 2 --- ##### [Class THREAD](class-thread) ##### [Function THREAD-NAME, THREAD-NATIVE-THREAD](thread-readers) ##### [Function THREADP](threadp) ##### [Function MAKE-THREAD](make-thread) ##### [Variable \*DEFAULT-SPECIAL-BINDINGS\*](default-special-bindings) ##### [Function CURRENT-THREAD, ALL-THREADS](current-all-threads) ##### [Function JOIN-THREAD](join-thread) ##### [Function THREAD-YIELD](thread-yield) ##### [Function START-MULTIPROCESSING](start-multiprocessing) ##### [Function INTERRUPT-THREAD](interrupt-thread) ##### [Function SIGNAL-IN-THREAD, WARN-IN-THREAD, ERROR-IN-THREAD](signal-in-thread) ##### [Function DESTROY-THREAD](destroy-thread) ##### [Function THREAD-ALIVE-P](thread-alive-p) ##### [Condition BORDEAUX-THREADS-ERROR](bordeaux-threads-error) ##### [Condition ABNORMAL-EXIT](abnormal-exit) ##### [Function ABNORMAL-EXIT-CONDITION](abnormal-exit-condition) bordeaux-threads-0.9.4/docs/content/threads/abnormal-exit-condition.md000066400000000000000000000016021463556250700261050ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function ABNORMAL-EXIT-CONDITION' weight: 16 --- #### Syntax: **abnormal-exit-condition** => condition #### Arguments and values: *condition* -> a condition object or `:terminated`. #### Description Returns the terminating condition of an [**abnormal-exit**](../abnormal-exit) condition object. If the thread was terminated by [**destroy-thread**](../destroy-thread) or other kinds of non-local exits, the keyword `:terminated` is returned. #### Examples: ``` (let ((thread (bt2:make-thread (lambda () (error "This will terminate the thread"))))) (handler-case (bt2:join-thread thread) (abnormal-exit (e) (abnormal-exit-condition e)))) ``` => `#` #### See also: [**abnormal-exit-condition**](../abnormal-exit-condition), [**join-thread**](../join-thread) bordeaux-threads-0.9.4/docs/content/threads/abnormal-exit.md000066400000000000000000000006471463556250700241310ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Condition type ABNORMAL-EXIT' weight: 16 --- #### Class Precedence List: abnormal-exit, bordeaux-threads-error, error, serious-condition, condition, t #### Description: The error **abnormal-exit** represents the condition of a thread not having terminated successfully. #### See also: [**abnormal-exit-condition**](../abnormal-exit-condition), [**join-thread**](../join-thread) bordeaux-threads-0.9.4/docs/content/threads/bordeaux-thread-error.md000066400000000000000000000005671463556250700255750ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Condition type BORDEAUX-THREADS-ERROR' weight: 15 --- #### Class Precedence List: bordeaux-threads-error, error, serious-condition, condition, t #### Description: The type **bordeaux-threads-error** consists of error conditions that are related to thread operations. #### See also: [**abnormal-exit**](../abnormal-exit-condition) bordeaux-threads-0.9.4/docs/content/threads/class-thread.md000066400000000000000000000003521463556250700237320ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class THREAD weight: 1 --- #### Class precedence list: [thread](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) #### Description: A wrapper for host thread instances. bordeaux-threads-0.9.4/docs/content/threads/current-all-threads.md000066400000000000000000000012031463556250700252340ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function CURRENT-THREAD, ALL-THREADS' weight: 6 --- #### Syntax: **current-thread** => thread\ **all-threads** => threads #### Arguments and values: *thread* -> a [thread](../class-thread) object.\ *threads* -> a list of [thread](../class-thread) objects. #### Description: **current-thread** returns the thread object representing the calling thread. **all-threads** returns a [fresh list](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh) of all running threads. #### Exceptional situations: None. #### See also: [**make-thread**](../make-thread) #### Notes: None. bordeaux-threads-0.9.4/docs/content/threads/default-special-bindings.md000066400000000000000000000047431463556250700262250ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Variable *DEFAULT-SPECIAL-BINDINGS*' weight: 5 --- #### Value type: an [alist](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist) mapping symbol names to forms to evaluate. #### Initial value: [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil). #### Description: Variables named in this list are locally bound in the new thread, before it begins executing user code, by calling [eval](http://www.lispworks.com/documentation/HyperSpec/Body/f_eval.htm#eval) on its associated form. This variable may be rebound around calls to [make-thread](../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. The bindings in `*default-special-bindings*` are used to determine the initial bindings of a new thread, and take precedence over a default list of I/O bindings. The list of initial I/O bindings is not modifiable by the user and it was chosen to avoid potential implementation-defined differences in [with-standard-io-syntax](http://www.lispworks.com/documentation/HyperSpec/Body/m_w_std_.htm#with-standard-io-syntax). ``` *package* (find-package :common-lisp-user) *print-array* t *print-base* 10 *print-case* :upcase *print-circle* nil *print-escape* t *print-gensym* t *print-length* nil *print-level* nil *print-lines* nil *print-miser-width* nil *print-pprint-dispatch* (copy-pprint-dispatch nil) *print-pretty* nil *print-radix* nil *print-readably* t *print-right-margin* nil *random-state* (make-random-state t) *read-base* 10 *read-default-float-format* 'double-float *read-eval* nil *read-suppress* nil *readtable* (copy-readtable nil) ``` #### Examples: ``` ;;; Make a thread read integers in base 7. (let* ((bt2:*default-special-bindings* (acons '*read-base* 7 bt2:*default-special-bindings*)) (thread (bt2:make-thread (lambda () (read-from-string "10"))))) (bt2:join-thread thread)) ``` => 7, 2 #### See also: [**make-thread**](../make-thread) #### Notes: The binding code does not check whether a symbol is indeed declared special or not. bordeaux-threads-0.9.4/docs/content/threads/destroy-thread.md000066400000000000000000000011631463556250700243170ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function DESTROY-THREAD' weight: 13 --- #### Syntax: **destroy-thread** thread => thread #### Arguments and values: *thread* -> a [thread](../class-thread) object. #### Description: Terminates the thread `thread`. #### Exceptional situations: Signals [bordeaux-threads-error](../bordeaux-threads-error) if attempting to destroy the calling thread, or a thread that already terminated. #### See also: [**join-thread**](../join-thread) #### Notes: This should be used with caution: it is implementation-defined whether the thread runs cleanup forms or releases its locks first. bordeaux-threads-0.9.4/docs/content/threads/interrupt-thread.md000066400000000000000000000024421463556250700246630ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function INTERRUPT-THREAD' weight: 11 --- #### Syntax: **interrupt-thread** thread function *&rest* arguments => thread #### Arguments and values: *thread* -> a [thread](../class-thread) object.\ *function* -> a function object.\ *arguments* -> values. #### Description: Interrupt `thread` and apply `function` to `arguments` within its dynamic context, then continue with the interrupted path of execution. Returns the thread object it acted on. #### Exceptional situations: An error of [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) will be signaled if `thread` is not a [**thread**](../class-thread) object.\ An error of [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) will be signaled if `function` is not a [function designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator). #### See also: [**make-thread**](../make-thread), [**join-thread**](../join-thread) #### Notes: This may not be a good idea if `thread` is holding locks or doing anything important. bordeaux-threads-0.9.4/docs/content/threads/join-thread.md000066400000000000000000000027241463556250700235710ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function JOIN-THREAD' weight: 7 --- #### Syntax: **join-thread** thread => multiple values #### Arguments and values: *thread* -> a [thread](../class-thread) object. #### Description Wait until `thread` terminates, or if it has already terminated, return immediately. The return values of the thread function are returned. #### Examples ``` (let ((thread (bt2:make-thread (lambda () (values 1 2 3))))) (bt2:join-thread thread)) ``` => 1, 2, 3 #### Exceptional situations: If a thread is terminated by an unhandled condition, or by [**destroy-thread**](../destroy-thread), then the condition [**abnormal-exit**](../abnormal-exit) is signaled. #### See also: [**make-thread**](./make-thread), [**abnormal-exit**](../abnormal-exit) #### Notes: Due to how **join-thread** interacts with the dynamic environment established by **make-thread**, it is not safe to join with a thread that was created outside Bordeaux-Threads. For example, the following code has undefined behaviour and might very well corrupt the image: ``` (mapcar #'bt2:join-thread (bt2:all-threads)) ``` Bordeaux-Threads can only record instances of thread termination due to unhandled conditions or the use of [**destroy-thread**](../destroy-thread). In case of other ways to terminate a thread, such as throwing to an implementation-specific tag defined in the dynamic environment of the thread function, the behaviour of **join-thread** is undefined. bordeaux-threads-0.9.4/docs/content/threads/make-thread.md000066400000000000000000000063141463556250700235460ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function: MAKE-THREAD' weight: 4 --- #### Syntax: **make-thread** function *&key* name initial-bindings trap-conditions => thread #### Arguments and values: *function* -> a [function designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator).\ *name* -> a [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string) or [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil).\ *initial-bindings* -> an alist mapping special variable names to values. Defaults to [\*default-special-bindings\*](default-special-bindings).\ *trap-conditions* -> if [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true), wrap the thread function in a handler-case. #### Description: Creates and returns a thread named `name`, which will call the function `function` with no arguments: when `function` returns, the thread terminates. 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](http://www.lispworks.com/documentation/HyperSpec/Body/m_defpar.htm)/[defparameter](http://www.lispworks.com/documentation/HyperSpec/Body/m_defpar.htm)/top-level [setq](http://www.lispworks.com/documentation/HyperSpec/Body/s_setq.htm)) or has been bound locally (e.g. with [let](http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm) or [let*](http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm)) 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, such as the ones introduced by `initial-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. #### Exceptional situations: An error of [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) will be signaled if `function` is not a [function designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator).\ An error of [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) will be signaled if `name` is anything other than [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil) or a [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string). #### Affected by: [**\*default-special-bindings\***](../default-special-bindings). #### See also: [**join-thread**](../join-thread) #### Notes: The threading model is implementation-dependent. bordeaux-threads-0.9.4/docs/content/threads/signal-in-thread.md000066400000000000000000000017431463556250700245130ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function SIGNAL-IN-THREAD, WARN-IN-THREAD, ERROR-IN-THREAD' weight: 12 --- #### Syntax: **signal-in-thread** thread datum *&rest* arguments => thread\ **warn-in-thread** thread datum *&rest* arguments => thread\ **error-in-thread** thread datum *&rest* arguments => thread #### Arguments and values: *thread* -> a [thread](../class-thread) object.\ *datum, arguments* -> designators for a condition. #### Description: Interrupt `thread` and apply `signal/warn/error` passing `datum` and `arguments`. #### Exceptional situations: None. #### See also: [**interrupt-thread**](../interrupt-thread), [**error**](http://www.lispworks.com/documentation/HyperSpec/Body/f_error.htm), [**signal**](http://www.lispworks.com/documentation/HyperSpec/Body/f_signal.htm), [**warn**](http://www.lispworks.com/documentation/HyperSpec/Body/f_warn.htm) #### Notes: These functions are currently implemented on top of [**interrupt-thread**](../interrupt-thread). bordeaux-threads-0.9.4/docs/content/threads/start-multiprocessing.md000066400000000000000000000007121463556250700257420ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function START-MULTIPROCESSING' weight: 10 --- #### Syntax: **start-multiprocessing** => No values. #### Arguments and values: Returns no values. #### Description: If the host implementation uses user-level threads, start the scheduler and multiprocessing, otherwise do nothing. It is safe to call repeatedly. #### Exceptional situations: None. #### Notes: Only has an effect on Allegro, CMUCL and Lispworks. bordeaux-threads-0.9.4/docs/content/threads/thread-alive-p.md000066400000000000000000000012011463556250700241540ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function THREAD-ALIVE-P' weight: 14 --- #### Syntax: **thread-alive-p** thread => generalized-boolean #### Arguments and values: *thread* -> a [thread](../class-thread) object.\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns true if `thread` has not finished or [**destroy-thread**](../destroy-thread) has not been called on it. #### Exceptional situations: Signals a type error if `thread` is not a [thread](../class-thread) object. #### See also: None. #### Notes: None. bordeaux-threads-0.9.4/docs/content/threads/thread-readers.md000066400000000000000000000012021463556250700242450ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function THREAD-NAME, THREAD-NATIVE-THREAD' weight: 2 --- #### Syntax: **thread-name** thread => name\ **thread-native-thread** thread => native-thread #### Arguments and values: *thread* -> an instance of class [**thread**](../class-thread).\ *name* -> a [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string) or [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil)\ *native-thread* -> a host thread instance. #### Description: These accessors return the public slots of class [**thread**](../class-thread). #### Exceptional situations: None. bordeaux-threads-0.9.4/docs/content/threads/thread-yield.md000066400000000000000000000010401463556250700237260ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function THREAD-YIELD' weight: 9 --- #### Syntax: **thread-yield** => No values. #### Arguments and values: Returns no values. #### Description Causes the calling thread to relinquish the CPU to allow other threads to run. #### Exceptional situations: None. #### Notes: On modern implementations that use native OS (SMP) threads, this function is of little use. On some older implementations where threads are scheduled in user space, it may be necessary or desirable to call this periodically. bordeaux-threads-0.9.4/docs/content/threads/threadp.md000066400000000000000000000014671463556250700230170ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: 'Function: THREADP' weight: 3 --- #### Syntax: **threadp** object => generalized-boolean #### Arguments and values: *object* -> an [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object).\ *generalized-boolean* -> a [generalized boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). #### Description: Returns [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) if `object` is of [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) [**thread**](../class-thread), otherwise [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). #### Exceptional situations: None. #### Notes: `(threadp object) == (typep object 'thread)` bordeaux-threads-0.9.4/docs/content/timeouts/000077500000000000000000000000001463556250700212555ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/content/timeouts/_index.md000066400000000000000000000002221463556250700230410ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Timeouts dictionary weight: 7 --- ##### [Class TIMEOUT](timeout) ##### [Macro WITH-TIMEOUT](with-timeout) bordeaux-threads-0.9.4/docs/content/timeouts/timeout.md000066400000000000000000000004711463556250700232670ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Class TIMEOUT weight: 1 --- #### Class precedence list: timeout, t. #### Description: This class represents the condition of a body of code not completing execution within a certain amount of time. #### See also: [**with-timeout**](../with-timeout) #### Notes: None. bordeaux-threads-0.9.4/docs/content/timeouts/with-timeout.md000066400000000000000000000014411463556250700242360ustar00rootroot00000000000000--- date: 2022-01-07T08:00:00Z title: Macro WITH-TIMEOUT weight: 2 --- #### Syntax: **with-timeout** (timeout) declaration\* forms\* => results #### Arguments and values: *timeout* -> a non-negative real number.\ *declaration* -> a declare expression; not evaluated.\ *forms* -> an implicit progn.\ *results* -> the values returned by the forms. #### Description: Execute `forms` and signal a condition of type [**timeout**](../timeout) if the execution of `forms` does not complete within `timeout` seconds. #### Exceptional situations: [**timeout**](../timeout), **not-implemented** #### See also: [**timeout**](../timeout) #### Notes: On implementations which do not support **with-timeout** natively and don't support threads either it signals a condition of type **not-implemented**. bordeaux-threads-0.9.4/docs/themes/000077500000000000000000000000001463556250700172175ustar00rootroot00000000000000bordeaux-threads-0.9.4/docs/themes/techdoc/000077500000000000000000000000001463556250700206305ustar00rootroot00000000000000bordeaux-threads-0.9.4/site/000077500000000000000000000000001463556250700157465ustar00rootroot00000000000000bordeaux-threads-0.9.4/site/index.html000066400000000000000000000037121463556250700177460ustar00rootroot00000000000000 Bordeaux Threads project

Bordeaux Threads

Portable shared-state concurrency for Common Lisp

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.

Supports all major Common Lisp implementations: SBCL, CCL, Lispworks, Allegro, ABCL, ECL, Clisp.
The MKCL, Corman, MCL and Scieneer backends are not tested frequently(if ever) and might not work.

For discussion, use the mailing list bordeaux-threads-devel or the #lisp IRC channel on Freenode.

Source repository

Bordeaux-threads is developed at Github. The repository is also mirrored to Gitlab and Bitbucket.

Stelian Ionescu. Last modified:
Valid XHTML 1.0 Strict
bordeaux-threads-0.9.4/site/style.css000066400000000000000000000026631463556250700176270ustar00rootroot00000000000000/* 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.9.4/test/000077500000000000000000000000001463556250700157615ustar00rootroot00000000000000bordeaux-threads-0.9.4/test/not-implemented.lisp000066400000000000000000000074671463556250700217710ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2/TEST -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2/test) (in-suite :bordeaux-threads-2) (test not-implemented.whole-function (let ((*not-implemented* (make-hash-table :test #'equal)) (op 'acquire-lock) (feature :some-feature)) (is-true (implemented-p op)) (is-true (implemented-p op feature)) (mark-not-implemented op) (is-false (implemented-p op)) (is-false (implemented-p op feature)))) (test not-implemented.one-feature (let ((*not-implemented* (make-hash-table :test #'equal)) (op 'acquire-lock) (feature :timeout)) (is-true (implemented-p op)) (is-true (implemented-p op feature)) (mark-not-implemented op feature) (is-true (implemented-p op)) (is-false (implemented-p op :feature)))) ;;; ;;; Threads ;;; (test make-thread.not-implemented (if (implemented-p 'bt2:make-thread) (pass) (signals not-implemented (make-thread (lambda ()))))) (test join-thread.not-implemented (if (implemented-p 'bt2:join-thread) (pass) (signals not-implemented (join-thread (make-thread (lambda ())))))) (test current-thread.not-implemented (if (implemented-p 'bt2:current-thread) (pass) (signals not-implemented (current-thread)))) (test thread-yield.not-implemented (if (implemented-p 'bt2:thread-yield) (pass) (signals not-implemented (thread-yield)))) (test all-threads.not-implemented (if (implemented-p 'bt2:all-threads) (pass) (signals not-implemented (all-threads)))) (test interrupt-thread.not-implemented (if (implemented-p 'bt2:interrupt-thread) (pass) (signals not-implemented (let ((thread (make-thread (lambda () (sleep 5))))) (interrupt-thread thread (lambda ())))))) (test destroy-thread.not-implemented (if (implemented-p 'bt2:destroy-thread) (pass) (signals not-implemented (destroy-thread (make-thread (lambda ())))))) (test thread-alive-p.not-implemented (if (implemented-p 'bt2:thread-alive-p) (pass) (signals not-implemented (thread-alive-p (make-thread (lambda ())))))) ;;; ;;; Locks ;;; (test make-lock.not-implemented (if (implemented-p 'bt2:make-lock) (pass) (signals not-implemented (make-lock)))) (test acquire-lock.not-implemented (if (implemented-p 'bt2:acquire-lock) (pass) (signals not-implemented (acquire-lock (make-lock))))) (test release-lock.not-implemented (if (implemented-p 'bt2:release-lock) (pass) (signals not-implemented (let ((lock (make-lock))) (acquire-lock lock) (release-lock lock))))) (test with-lock-held.not-implemented (if (implemented-p 'bt2:with-lock-held) (pass) (signals not-implemented (let ((lock (make-lock))) (with-lock-held (lock)))))) (test make-recursive-lock.not-implemented (if (implemented-p 'bt2:make-recursive-lock) (pass) (signals not-implemented (make-recursive-lock)))) (test acquire-recursive-lock.not-implemented (if (implemented-p 'bt2:acquire-recursive-lock) (pass) (signals not-implemented (acquire-recursive-lock (make-recursive-lock))))) (test release-recursive-lock.not-implemented (if (implemented-p 'bt2:release-recursive-lock) (pass) (signals not-implemented (let ((lock (make-recursive-lock))) (acquire-recursive-lock lock) (release-recursive-lock lock))))) (test with-recursive-lock-held.not-implemented (if (implemented-p 'bt2:with-recursive-lock-held) (pass) (signals not-implemented (let ((lock (make-recursive-lock))) (with-recursive-lock-held (lock)))))) ;;; ;;; Condition variables ;;; ;;; ;;; Semaphores ;;; bordeaux-threads-0.9.4/test/pkgdcl.lisp000066400000000000000000000014141463556250700201160ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- ;;;; The above modeline is required for Genera. Do not change. (defpackage :bordeaux-threads-2/test (:use :common-lisp :alexandria :bordeaux-threads-2 :fiveam) (:import-from :bordeaux-threads-2 #:mark-not-implemented #:*not-implemented* #:implemented-p #:implemented-p*) (:shadow #:is)) (in-package :bordeaux-threads-2/test) (def-suite :bordeaux-threads-2) (defmacro is (test &rest reason-args) (with-gensyms (c) `(handler-case (5am:is ,test ,@reason-args) ((or bt2::operation-not-implemented bt2::keyarg-not-implemented) (,c) (declare (ignore ,c)) (5am:skip "Skipping operations that are not implemented"))))) bordeaux-threads-0.9.4/test/tests-v1.lisp000066400000000000000000000227501463556250700203460ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- ;;;; The above modeline is required for Genera. Do not change. #| Copyright 2006,2007 Greg Pfeil Distributed under the MIT license (see LICENSE file) |# (defpackage bordeaux-threads/test (:use #:cl #:bordeaux-threads #:fiveam) (:shadow #:with-timeout)) (in-package #:bordeaux-threads/test) (def-suite :bordeaux-threads) (def-fixture using-lock () (let ((lock (make-lock))) (&body))) (in-suite :bordeaux-threads) (test should-have-current-thread (is (current-thread))) (test current-thread-identity (let* ((box (list nil)) (thread (make-thread (lambda () (setf (car box) (current-thread)))))) (join-thread thread) (is (eql (car box) thread)))) (test current-thread-eql (is (eql (current-thread) (current-thread)))) (test join-thread-return-value (is (eql 0 (join-thread (make-thread (lambda () 0)))))) (test should-identify-threads-correctly (is (threadp (current-thread))) (is (threadp (make-thread (lambda () t) :name "foo"))) (is (not (threadp (make-lock))))) (test should-retrieve-thread-name (is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo"))))) (test interrupt-thread (let* ((box (list nil)) (thread (make-thread (lambda () (setf (car box) (catch 'new-thread (sleep 60) 'not-interrupted)))))) (sleep 1) (interrupt-thread thread (lambda () (throw 'new-thread 'interrupted))) (join-thread thread) (is (eql 'interrupted (car box))))) (test should-lock-without-contention (with-fixture using-lock () (is (acquire-lock lock t)) (release-lock lock) (is (acquire-lock lock nil)) (release-lock lock))) #-(or allegro sbcl) (def-test acquire-recursive-lock () (let ((test-lock (make-recursive-lock)) (results (make-array 4 :adjustable t :fill-pointer 0)) (results-lock (make-lock)) (threads ())) (flet ((add-result (r) (with-lock-held (results-lock) (vector-push-extend r results)))) (dotimes (i 2) (push (make-thread #'(lambda () (when (acquire-recursive-lock test-lock) (unwind-protect (progn (add-result :enter) (sleep 1) (add-result :leave)) (release-recursive-lock test-lock))))) threads))) (map 'nil #'join-thread threads) (is (equalp results #(:enter :leave :enter :leave))))) (defun set-equal (set-a set-b) (and (null (set-difference set-a set-b)) (null (set-difference set-b set-a)))) (test default-special-bindings (locally (declare (special *a* *c*)) (let* ((the-as 50) (the-bs 150) (*b* 42) some-a some-b some-other-a some-other-b (*default-special-bindings* `((*a* . (funcall ,(lambda () (incf the-as)))) (*b* . (funcall ,(lambda () (incf the-bs)))) ,@*default-special-bindings*)) (threads (list (make-thread (lambda () (setf some-a *a* some-b *b*))) (make-thread (lambda () (setf some-other-a *a* some-other-b *b*)))))) (declare (special *b*)) (thread-yield) (is (not (boundp '*a*))) (loop while (some #'thread-alive-p threads) do (thread-yield)) (is (set-equal (list some-a some-other-a) '(51 52))) (is (set-equal (list some-b some-other-b) '(151 152))) (is (not (boundp '*a*)))))) (defparameter *shared* 0) (defparameter *lock* (make-lock)) (test 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) (flet ((worker (i) (loop do (with-lock-held (*lock*) (when (= i *shared*) (incf *shared*) (return))) (thread-yield) (sleep 0.001)))) (let* ((procs (loop for i from 1 upto 2 ;; create a new binding to protect against implementations that ;; mutate instead of binding the loop variable collect (let ((i i)) (make-thread (lambda () (funcall #'worker i)) :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*) (is (>= (1+ (length procs)) *shared*))) (thread-yield) (sleep 0.001)))))) ;; Generally safe sanity check for the locks and single-notify #+(and lispworks (or lispworks4 lispworks5)) (test condition-variable-lw (let ((condition-variable (make-condition-variable :name "Test")) (test-lock (make-lock)) (completed nil)) (dotimes (id 6) (let ((id id)) (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed) (condition-notify condition-variable)))))) (sleep 2) (if completed (print "Failed: Premature passage through condition-wait") (print "Successfully waited on condition")) (condition-notify condition-variable) (sleep 2) (if (and completed (eql (length completed) 6) (equal (sort completed #'<) (loop for id from 0 to 5 collect id))) (print "Success: All elements notified") (print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed))) (bt::with-cv-access condition-variable (if (and (not (or (car wait-tlist) (cdr wait-tlist))) (zerop (hash-table-count wait-hash)) (zerop (hash-table-count unconsumed-notifications))) (print "Success: condition variable restored to initial state") (print "Error: condition variable retains residue from completed waiters"))) (setq completed nil) (dotimes (id 6) (let ((id id)) (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed)))))) (sleep 2) (condition-notify condition-variable) (sleep 2) (if (= (length completed) 1) (print "Success: Notify-single only notified a single waiter to restart") (format t "Failure: Notify-single restarted ~A items" (length completed))) (condition-notify condition-variable) (sleep 2) (if (= (length completed) 2) (print "Success: second Notify-single only notified a single waiter to restart") (format t "Failure: Two Notify-singles restarted ~A items" (length completed))) (loop for i from 0 to 5 do (condition-notify condition-variable)) (print "Note: In the case of any failures, assume there are outstanding waiting threads") (values))) #+(or abcl allegro clisp clozure ecl genera lispworks6 mezzano sbcl scl) (test condition-wait-timeout (let ((lock (make-lock)) (cvar (make-condition-variable)) (flag nil)) (make-thread (lambda () (sleep 0.4) (setf flag t))) (with-lock-held (lock) (condition-wait cvar lock :timeout 0.2) (is (null flag)) (sleep 0.4) (is (eq t flag))))) (test semaphore-signal (let ((sem (make-semaphore))) (make-thread (lambda () (sleep 0.4) (signal-semaphore sem))) (is (not (null (wait-on-semaphore sem)))))) (test semaphore-signal-n-of-m (let* ((sem (make-semaphore :count 1)) (lock (make-lock)) (count 0) (waiter (lambda () (wait-on-semaphore sem) (with-lock-held (lock) (incf count))))) (make-thread (lambda () (sleep 0.2) (signal-semaphore sem :count 3))) (dotimes (v 5) (make-thread waiter)) (sleep 0.3) (is (= count 4)) ;; release other waiters (signal-semaphore sem :count 10) (sleep 0.1) (is (= count 5)))) (test semaphore-wait-timeout (let ((sem (make-semaphore)) (flag nil)) (make-thread (lambda () (sleep 3) (setf flag t))) (is (null (wait-on-semaphore sem :timeout 0.2))) (is (eql nil flag)) (sleep 5) (is (eql t flag)))) (test semaphore-typed (is (typep (bt:make-semaphore) 'bt:semaphore)) (is (bt:semaphore-p (bt:make-semaphore))) (is (null (bt:semaphore-p (bt:make-lock))))) (test with-timeout-return-value (is (eql :foo (bt:with-timeout (5) :foo)))) (test with-timeout-signals (signals timeout (bt:with-timeout (1) (sleep 5)))) (test with-timeout-non-interference (flet ((sleep-with-timeout (s) (bt:with-timeout (4) (sleep s)))) (finishes (progn (sleep-with-timeout 3) (sleep-with-timeout 3))))) bordeaux-threads-0.9.4/test/tests-v2.lisp000066400000000000000000000431241463556250700203450ustar00rootroot00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2/TEST -*- ;;;; The above modeline is required for Genera. Do not change. (in-package :bordeaux-threads-2/test) (in-suite :bordeaux-threads-2) ;;; ;;; Threads ;;; (test join-thread.return-value (is (eql 0 (join-thread (make-thread (lambda () 0)))))) (test current-thread.not-null (is (current-thread))) (test current-thread.eql (is (eql (current-thread) (current-thread)))) #+#.(bt2::implemented-p* 'bt2:join-thread) (test current-thread.identity (let ((thread (make-thread #'current-thread))) (is (eql thread (join-thread thread))))) #+#.(bt2::implemented-p* 'bt2:join-thread) (test current-thread.special (let ((thread (make-thread (lambda () bt2::*current-thread*)))) (is (eql thread (join-thread thread))))) #+#.(bt2::implemented-p* 'bt2:join-thread) (test current-thread.error (let ((thread (make-thread (lambda () (error "FOOBAR")) :trap-conditions t))) (signals abnormal-exit (join-thread thread)))) (test threadp.should-identify-threads (is (threadp (current-thread))) (is (threadp (make-thread (lambda () t)))) (is (not (threadp (make-lock))))) (test thread-name.should-retrieve-thread-name (is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo"))))) (test thread-name.all-strings (is (every #'(lambda (thread) (stringp (thread-name thread))) (all-threads)))) (defparameter *some-special* :global-value) (test default-special-bindings.sees-global-bindings (let* ((*some-special* :local-value) (*default-special-bindings* `((*some-special* . (list :more *some-special*)) ,@*default-special-bindings*)) (thread (make-thread (lambda () *some-special*)))) (is (equal '(:more :local-value) (join-thread thread))))) (defparameter *shared* 0) (defparameter *lock* (make-lock)) #+#.(bt2::implemented-p* 'bt2:thread-yield) (test threads.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) (flet ((worker (i) (loop do (with-lock-held (*lock*) (when (= i *shared*) (incf *shared*) (return))) (thread-yield) (sleep 0.001)))) (let* ((procs (loop for i from 1 upto 2 ;; create a new binding to protect against implementations that ;; mutate instead of binding the loop variable collect (let ((i i)) (make-thread (lambda () (funcall #'worker i)) :name (format nil "threads.interaction 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*) (is (>= (1+ (length procs)) *shared*))) (thread-yield) (sleep 0.001)))))) (test all-threads.contains-threads (is (every #'threadp (all-threads)))) (test all-threads.contains-new-thread (let ((thread (make-thread (lambda () (sleep 60)) :name "all-threads.contains-new-thread"))) (is (find thread (all-threads))))) #+#.(bt2::implemented-p* 'bt2:interrupt-thread) (test interrupt-thread.throw (let ((thread (make-thread (lambda () (catch 'new-thread (sleep 60) 'not-interrupted)) :name "interrupt-thread.throw"))) (sleep 1) (is (threadp (interrupt-thread thread (lambda () (throw 'new-thread 'interrupted))))) (is (eql 'interrupted (join-thread thread))))) (test thread-alive-p.new-thread (is (thread-alive-p (make-thread (lambda () (sleep 60)) :name "thread-alive-p.new-thread")))) #+#.(bt2::implemented-p* 'bt2:join-thread) (test thread-termination.unwind-protect (setf *some-special* nil) #+abcl (skip "DESTROY-THREAD does not execute UNWIND-PROTECT cleanup forms. Filed https://github.com/armedbear/abcl/issues/430.") #-abcl (flet ((thread-fn () (setf *some-special* :entered) (unwind-protect (progn (sleep 5) (setf *some-special* :failed)) (when (eq *some-special* :entered) (setf *some-special* :success))))) (let ((thread (make-thread #'thread-fn))) (sleep 1) (destroy-thread thread) (signals abnormal-exit (join-thread thread)) (is (eq :success *some-special*))))) (define-condition test-error (error) ()) #+#.(bt2::implemented-p* 'bt2:join-thread) (test thread-termination.handle-condition (flet ((thread-fn () (error 'test-error))) (let ((thread (make-thread #'thread-fn :trap-conditions t))) (handler-case (join-thread thread) (abnormal-exit (e) (is (typep (abnormal-exit-condition e) 'test-error))))))) #+#.(bt2::implemented-p* 'bt2:destroy-thread) (test destroy-thread.terminates (let ((thread (make-thread (lambda () (sleep 3)) :name "destroy-thread.terminates"))) (is (threadp (destroy-thread thread))) (sleep 5) (is-false (thread-alive-p thread)))) #+#.(bt2::implemented-p* 'bt2:destroy-thread) (test join-thread.error-if-destroyed (let ((thread (make-thread (lambda () (sleep 3)) :name "join-thread.error-if-destroyed"))) (destroy-thread thread) (signals abnormal-exit (join-thread thread)))) #+#.(bt2::implemented-p* 'bt2:destroy-thread) (test destroy-thread.error-if-exited (let ((thread (make-thread (lambda () (sleep 3)) :name "destroy-thread.error-if-exited"))) (join-thread thread) (signals bordeaux-threads-error (destroy-thread thread)))) ;;; ;;; Non-recursive Locks ;;; (test lock.constructor (let ((lock (make-lock :name "Name"))) (is (lockp lock)) (is (native-lock-p (lock-native-lock lock))) (is (equal "Name" (lock-name lock))))) (test acquire-lock.no-contention (let ((lock (make-lock))) (is (acquire-lock lock :wait t)) (is (lockp (release-lock lock))) (is (acquire-lock lock :wait nil)) (is (lockp (release-lock lock))))) (test acquire-lock.try-lock (let ((lock (make-lock))) (make-thread (lambda () (with-lock-held (lock) (sleep 5))) :name "acquire-lock.try-lock") (sleep 1) (is-false (acquire-lock lock :wait nil)))) (test acquire-lock.timeout-expires (let ((lock (make-lock))) (make-thread (lambda () (with-lock-held (lock) (sleep 5))) :name "acquire-lock.timeout-expires") (sleep 1) (is (null (acquire-lock lock :timeout .1))))) #+#.(bt2::implemented-p* 'bt2:with-lock-held) (test with-lock-held.timeout-no-contention-acquired (let ((lock (make-lock))) (is (eql :ok (with-lock-held (lock :timeout .1) :ok))))) #+#.(bt2::implemented-p* 'bt2:with-lock-held) (test with-lock-held.timeout-expires (let ((lock (make-lock))) (make-thread (lambda () (with-lock-held (lock) (sleep 5))) :name "with-lock-held.timeout-expires") (sleep 1) (is (eql :timeout (block ok (with-lock-held (lock :timeout .1) (return-from ok :ok)) :timeout))))) ;;; ;;; Recursive Locks ;;; #+#.(bt2::implemented-p* 'bt2:acquire-recursive-lock) (test acquire-recursive-lock (let ((test-lock (make-recursive-lock)) (results (make-array 4 :adjustable t :fill-pointer 0)) (results-lock (make-lock)) (threads ())) (flet ((add-result (r) (with-lock-held (results-lock) (vector-push-extend r results)))) (dotimes (i 2) (push (make-thread #'(lambda () (when (acquire-recursive-lock test-lock) (unwind-protect (progn (add-result :enter) (sleep 1) (add-result :leave)) (release-recursive-lock test-lock)))) :name (format nil "acquire-recursive-lock Proc #~D" i)) threads))) (map 'nil #'join-thread threads) (is (equalp #(:enter :leave :enter :leave) results)))) #+#.(bt2::implemented-p* 'bt2:acquire-recursive-lock) (test acquire-recursive-lock.no-contention (let ((lock (make-recursive-lock))) (is (acquire-recursive-lock lock :wait t)) (is (recursive-lock-p (release-recursive-lock lock))) (is (acquire-recursive-lock lock :wait nil)) (is (recursive-lock-p (release-recursive-lock lock))))) #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held) (test acquire-recursive-lock.try-lock (let ((lock (make-recursive-lock))) (make-thread (lambda () (with-recursive-lock-held (lock) (sleep 5))) :name "acquire-recursive-lock.try-lock") (sleep 1) (is (null (acquire-recursive-lock lock :wait nil))))) #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held) (test acquire-recursive-lock.timeout-expires (let ((lock (make-recursive-lock))) (make-thread (lambda () (with-recursive-lock-held (lock) (sleep 5))) :name "acquire-recursive-lock.timeout-expires") (sleep 1) (is (null (acquire-recursive-lock lock :timeout .1))))) #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held) (test with-recursive-lock-held.timeout-no-contention-acquired (let ((lock (make-recursive-lock))) (is (eql :ok (with-recursive-lock-held (lock :timeout .1) :ok))))) #+#.(bt2::implemented-p* 'bt2:with-recursive-lock-held) (test with-recursive-lock-held.timeout-expires (let ((lock (make-recursive-lock))) (make-thread (lambda () (with-recursive-lock-held (lock) (sleep 5))) :name "with-recursive-lock-held.timeout-expires") (sleep 1) (is (eql :timeout (block ok (with-recursive-lock-held (lock :timeout .1) (return-from ok :ok)) :timeout))))) ;;; ;;; Semaphores ;;; #+#.(bt2::implemented-p* 'bt2:make-semaphore) (progn (test semaphore.typed (is (typep (make-semaphore) 'semaphore)) (is (semaphorep (make-semaphore))) (is (not (semaphorep (make-lock))))) (test semaphore.signal (let ((sem (make-semaphore))) (make-thread (lambda () (sleep 0.4) (signal-semaphore sem))) (is-true (wait-on-semaphore sem)) (is-true (signal-semaphore sem)))) (test semaphore.wait-on-nonzero-creation "Tests that `WAIT-ON-SEMAPHORE` correctly returns T on a smaphore that was initialized to a non-zero value. In other words, it tests that `SIGNAL-SEMAPHORE` is not the only cause that can wake a waiter." (let ((sem (make-semaphore :count 1))) (is-true (wait-on-semaphore sem :timeout 0)))) (test semaphore.wait.timeout (let* ((sem (make-semaphore))) (is-false (wait-on-semaphore sem :timeout 0)) (is-false (wait-on-semaphore sem :timeout 0.2)))) (test semaphore.signal-n-of-m (let* ((sem (make-semaphore :count 1)) (lock (make-lock)) (count 0) (waiter (lambda () (wait-on-semaphore sem) (with-lock-held (lock) (incf count))))) (make-thread (lambda () (sleep 0.2) (signal-semaphore sem :count 3))) (dotimes (v 5) (make-thread waiter)) (sleep 0.3) (is (= 4 count)) ;; release other waiters (is (eql t (signal-semaphore sem :count 2))) (sleep 0.1) (is (= 5 count))))) ;;; ;;; Condition variables ;;; #+#.(bt2::implemented-p* 'bt2:make-condition-variable) (test condition-variable.typed (is (typep (make-condition-variable) 'condition-variable)) (is (condition-variable-p (make-condition-variable))) (is (not (condition-variable-p (make-lock))))) #+#.(bt2::implemented-p* 'bt2:make-condition-variable) (test condition-variable.concurrency (setf *shared* 0) (let ((cv (make-condition-variable))) (flet ((worker (i) (with-lock-held (*lock*) (loop until (= i *shared*) do (condition-wait cv *lock*) (sleep (random .1))) (incf *shared*)) (condition-broadcast cv))) (let ((num-procs 30)) (dotimes (i num-procs) (let ((i (- num-procs i 1))) (make-thread (lambda () (sleep (random 1)) (funcall #'worker i)) :name (format nil "Proc #~D" i)))) (with-lock-held (*lock*) (loop until (= num-procs *shared*) do (condition-wait cv *lock*))) (is (equal num-procs *shared*)))))) #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout) (test condition-wait.timeout (let ((lock (make-lock)) (cv (make-condition-variable)) (flag nil)) (make-thread (lambda () (sleep 0.4) (setf flag t))) (with-lock-held (lock) (let ((success (condition-wait cv lock :timeout 0.2))) #+abcl (skip "ABCL's condition-wait always returns T") #-abcl (is-false success) (is (null flag)) (sleep 0.4) (is (eq t flag)))))) #+#.(bt2::implemented-p* 'bt2:condition-wait :timeout) (test condition-wait.lock-held-on-timeout "Tests that even when `CONDITION-WAIT` times out, it reacquires the lock." (let ((lock (make-lock :name "Test lock")) (cv (make-condition-variable :name "Test condition variable"))) (with-lock-held (lock) (let ((success (condition-wait cv lock :timeout 2))) #+abcl (skip "ABCL's condition-wait always returns T") #-abcl (is-false success) ;; We need to test if `lock` is locked, but it must be done in ;; another thread, otherwise it would be a recursive attempt. (let ((res-lock (make-lock :name "Result lock")) (res-cv (make-condition-variable :name "Result condition variable")) (lock-was-acquired-p nil)) (make-thread (lambda () (with-lock-held (res-lock) (setf lock-was-acquired-p (acquire-lock lock :wait nil))) (condition-notify res-cv))) (with-lock-held (res-lock) (condition-wait res-cv res-lock) (is-false lock-was-acquired-p))))))) #+#.(bt2::implemented-p* 'bt2:make-condition-variable) (test condition-notify.no-waiting-threads "Test that `CONDITION-NOTIFY` returns NIL whether or not there are threads waiting." (let ((lock (make-lock :name "Test lock")) (cv (make-condition-variable :name "Test condition variable"))) (is-false (condition-notify cv)) (make-thread (lambda () (with-lock-held (lock) (condition-wait cv lock)))) (is-false (condition-notify cv)))) #+#.(bt2::implemented-p* 'bt2:make-condition-variable) (test condition-broadcast.return-value "Test that `CONDITION-BROADCAST` returns NIL whether or not there are threads waiting." (let ((lock (make-lock :name "Test lock")) (cv (make-condition-variable :name "Test condition variable"))) (is-false (condition-notify cv)) (make-thread (lambda () (with-lock-held (lock) (condition-wait cv lock))) :name "Waiting thread 1") (make-thread (lambda () (with-lock-held (lock) (condition-wait cv lock))) :name "Waiting thread 2") (is-false (condition-broadcast cv)))) ;;; ;;; Timeouts ;;; (test with-timeout.return-value (is (eql :foo (with-timeout (5) :foo)))) (test with-timeout.signals (signals timeout (with-timeout (1) (sleep 5)))) (test with-timeout.non-interference (flet ((sleep-with-timeout (s) (with-timeout (4) (sleep s)))) (finishes (progn (sleep-with-timeout 3) (sleep-with-timeout 3))))) ;;; ;;; Atomics ;;; #+(or abcl allegro ccl clisp ecl lispworks sbcl) (test atomic-integer-incf-decf.return-value (let ((aint (make-atomic-integer :value 0))) (is (= 5 (atomic-integer-incf aint 5))) (is (= 4 (atomic-integer-decf aint 1))))) #+(or abcl allegro ccl clisp ecl lispworks sbcl) (test atomic-integer-compare-and-swap.return-value (let ((aint (make-atomic-integer :value 4))) (is (null (atomic-integer-compare-and-swap aint 0 100))) (is (eql t (atomic-integer-compare-and-swap aint 4 7))))) #+(or abcl allegro ccl clisp ecl lispworks sbcl) (test atomic-integer.concurrency (let* ((aint (make-atomic-integer :value 1000000)) (thread-inc (make-thread (lambda () (dotimes (i 1000000) (atomic-integer-incf aint))))) (thread-dec (make-thread (lambda () (dotimes (i 1000000) (atomic-integer-decf aint)))))) (join-thread thread-inc) (join-thread thread-dec) (is (= 1000000 (atomic-integer-value aint))))) bordeaux-threads-0.9.4/version.sexp000066400000000000000000000000301463556250700173610ustar00rootroot00000000000000;; -*- lisp -*- "0.9.4"