├── .gitignore ├── version.sexp ├── docs ├── archetypes │ └── default.md ├── content │ ├── timeouts │ │ ├── _index.md │ │ ├── timeout.md │ │ └── with-timeout.md │ ├── locks │ │ ├── lock.md │ │ ├── recursive-lock.md │ │ ├── native-lock.md │ │ ├── native-recursive-lock.md │ │ ├── lock-readers.md │ │ ├── make-recursive-lock.md │ │ ├── lockp.md │ │ ├── make-lock.md │ │ ├── recursive-lock-p.md │ │ ├── native-lock-p.md │ │ ├── native-recursive-lock-p.md │ │ ├── _index.md │ │ ├── with-lock-held.md │ │ ├── with-recursive-lock-held.md │ │ ├── acquire-release-lock.md │ │ └── acquire-release-recursive-lock.md │ ├── threads │ │ ├── class-thread.md │ │ ├── bordeaux-thread-error.md │ │ ├── abnormal-exit.md │ │ ├── start-multiprocessing.md │ │ ├── thread-yield.md │ │ ├── thread-readers.md │ │ ├── destroy-thread.md │ │ ├── thread-alive-p.md │ │ ├── current-all-threads.md │ │ ├── threadp.md │ │ ├── abnormal-exit-condition.md │ │ ├── _index.md │ │ ├── signal-in-thread.md │ │ ├── interrupt-thread.md │ │ ├── join-thread.md │ │ ├── default-special-bindings.md │ │ └── make-thread.md │ ├── semaphores │ │ ├── _index.md │ │ ├── semaphore.md │ │ ├── semaphorep.md │ │ ├── signal-semaphore.md │ │ ├── make-semaphore.md │ │ └── wait-on-semaphore.md │ ├── condition-variables │ │ ├── _index.md │ │ ├── condition-variable.md │ │ ├── make-condition-variable.md │ │ ├── condition-variable-p.md │ │ ├── condition-broadcast.md │ │ ├── condition-notify.md │ │ └── condition-wait.md │ ├── atomics │ │ ├── _index.md │ │ ├── atomic-integer.md │ │ ├── make-atomic-integer.md │ │ ├── atomic-integer-value.md │ │ ├── atomic-integer-p.md │ │ ├── atomic-integer-decf.md │ │ ├── atomic-integer-incf.md │ │ └── atomic-integer-compare-and-swap.md │ └── _index.md └── config.toml ├── .gitmodules ├── README.md ├── apiv1 ├── impl-corman.lisp ├── condition-variables.lisp ├── impl-mcl.lisp ├── impl-mkcl.lisp ├── impl-scl.lisp ├── impl-clasp.lisp ├── pkgdcl.lisp ├── impl-clisp.lisp ├── impl-clozure.lisp ├── impl-ecl.lisp ├── impl-mezzano.lisp ├── impl-sbcl.lisp ├── impl-allegro.lisp ├── impl-lispworks.lisp ├── impl-abcl.lisp └── impl-cmucl.lisp ├── CONTRIBUTORS ├── .github └── workflows │ └── gh-pages-deployment.yml ├── test ├── pkgdcl.lisp └── not-implemented.lisp ├── LICENSE ├── .travis.yml ├── site ├── style.css └── index.html ├── apiv2 ├── impl-corman.lisp ├── impl-condition-variables-semaphores.lisp ├── timeout-interrupt.lisp ├── impl-mcl.lisp ├── atomics-java.lisp ├── impl-clasp.lisp ├── impl-mkcl.lisp ├── impl-lispworks.lisp ├── impl-scl.lisp ├── impl-clisp.lisp ├── api-semaphores.lisp ├── bordeaux-threads.lisp ├── impl-clozure.lisp ├── pkgdcl.lisp ├── api-condition-variables.lisp ├── impl-cmucl.lisp ├── impl-allegro.lisp ├── impl-sbcl.lisp ├── impl-mezzano.lisp ├── impl-ecl.lisp └── api-locks.lisp └── bordeaux-threads.asd /.gitignore: -------------------------------------------------------------------------------- 1 | docs/.hugo_build.lock 2 | public 3 | -------------------------------------------------------------------------------- /version.sexp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | "0.9.4" 3 | -------------------------------------------------------------------------------- /docs/archetypes/default.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: "{{ replace .Name "-" " " | title }}" 3 | date: {{ .Date }} 4 | draft: true 5 | --- 6 | 7 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "docs/themes/techdoc"] 2 | path = docs/themes/techdoc 3 | url = https://github.com/thingsym/hugo-theme-techdoc.git 4 | -------------------------------------------------------------------------------- /docs/content/timeouts/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Timeouts dictionary 4 | weight: 7 5 | --- 6 | 7 | ##### [Class TIMEOUT](timeout) 8 | 9 | ##### [Macro WITH-TIMEOUT](with-timeout) 10 | -------------------------------------------------------------------------------- /docs/content/locks/lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class LOCK 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | [lock](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) 10 | 11 | #### Description: 12 | 13 | Wrapper for a native non-recursive lock. 14 | -------------------------------------------------------------------------------- /docs/content/threads/class-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class THREAD 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | [thread](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) 10 | 11 | #### Description: 12 | 13 | A wrapper for host thread instances. 14 | -------------------------------------------------------------------------------- /docs/content/locks/recursive-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class RECURSIVE-LOCK 4 | weight: 3 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | [recursive-lock](.), [t](http://www.lispworks.com/documentation/HyperSpec/Body/t_t.htm#t) 10 | 11 | #### Description: 12 | 13 | Wrapper for a native recursive lock. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Bordeaux-Threads is a Common Lisp threading library. 2 | 3 | It exposes generic primitives required for synchronization in 4 | multi-threading programming, such as threads, mutexes, semaphores and 5 | condition variables, as well as some atomic operations. 6 | 7 | You can read its manual 8 | [here](https://sionescu.github.io/bordeaux-threads/). 9 | -------------------------------------------------------------------------------- /docs/content/semaphores/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Semaphores dictionary 4 | weight: 5 5 | --- 6 | 7 | ##### [Class SEMAPHORE](semaphore) 8 | 9 | ##### [Function SEMAPHOREP](semaphorep) 10 | 11 | ##### [Function MAKE-SEMAPHORE](make-semaphore) 12 | 13 | ##### [Function SIGNAL-SEMAPHORE](signal-semaphore) 14 | 15 | ##### [Function WAIT-ON-SEMAPHORE](wait-on-semaphore) 16 | -------------------------------------------------------------------------------- /docs/content/timeouts/timeout.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class TIMEOUT 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | timeout, t. 10 | 11 | #### Description: 12 | 13 | This class represents the condition of a body of code not completing 14 | execution within a certain amount of time. 15 | 16 | #### See also: 17 | 18 | [**with-timeout**](../with-timeout) 19 | 20 | #### Notes: 21 | 22 | None. 23 | -------------------------------------------------------------------------------- /docs/content/locks/native-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Host type NATIVE-LOCK 4 | weight: 6 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | Implementation-defined. 10 | 11 | #### Description: 12 | 13 | A `native-lock` represents the non-recursive lock type exported by the 14 | host implementation. 15 | 16 | #### See also: 17 | 18 | [**lock**](../lock) 19 | 20 | #### Notes: 21 | 22 | The exact type of `native-lock` is implementation-defined. 23 | -------------------------------------------------------------------------------- /docs/content/threads/bordeaux-thread-error.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Condition type BORDEAUX-THREADS-ERROR' 4 | weight: 15 5 | --- 6 | 7 | #### Class Precedence List: 8 | 9 | bordeaux-threads-error, error, serious-condition, condition, t 10 | 11 | #### Description: 12 | 13 | The type **bordeaux-threads-error** consists of error conditions that 14 | are related to thread operations. 15 | 16 | #### See also: 17 | 18 | [**abnormal-exit**](../abnormal-exit-condition) 19 | -------------------------------------------------------------------------------- /docs/content/locks/native-recursive-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Host type NATIVE-RECURSIVE-LOCK 4 | weight: 8 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | Implementation-defined. 10 | 11 | #### Description: 12 | 13 | A `native-recursive-lock` represents the recursive lock type exported 14 | by the host implementation. 15 | 16 | #### See also: 17 | 18 | [**recursive-lock**](../recursive-lock) 19 | 20 | #### Notes: 21 | 22 | The exact type of `native-recursive-lock` is implementation-defined. 23 | -------------------------------------------------------------------------------- /docs/content/condition-variables/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Condition Variables dictionary 4 | weight: 4 5 | --- 6 | 7 | ##### [Class CONDITION-VARIABLE](condition-variable) 8 | 9 | ##### [Function CONDITION-VARIABLE-P](condition-variable-p) 10 | 11 | ##### [Function MAKE-CONDITION-VARIABLE](make-condition-variable) 12 | 13 | ##### [Function CONDITION-WAIT](condition-wait) 14 | 15 | ##### [Function CONDITION-NOTIFY](condition-notify) 16 | 17 | ##### [Function CONDITION-BROADCAST](condition-broadcast) 18 | -------------------------------------------------------------------------------- /docs/content/semaphores/semaphore.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class SEMAPHORE 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | Implementation-defined. 10 | 11 | #### Description: 12 | 13 | This class represents semaphores. 14 | 15 | #### See also: 16 | 17 | [**make-semaphore**](../make-semaphore) 18 | 19 | #### Notes: 20 | 21 | On some implementations the library exposes the native type directly, 22 | while on others there is a custom implementations using condition 23 | variables and locks. 24 | -------------------------------------------------------------------------------- /docs/content/threads/abnormal-exit.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Condition type ABNORMAL-EXIT' 4 | weight: 16 5 | --- 6 | 7 | #### Class Precedence List: 8 | 9 | abnormal-exit, bordeaux-threads-error, error, serious-condition, 10 | condition, t 11 | 12 | #### Description: 13 | 14 | The error **abnormal-exit** represents the condition of a thread not 15 | having terminated successfully. 16 | 17 | #### See also: 18 | 19 | [**abnormal-exit-condition**](../abnormal-exit-condition), 20 | [**join-thread**](../join-thread) 21 | -------------------------------------------------------------------------------- /docs/content/atomics/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Atomics dictionary 4 | weight: 6 5 | --- 6 | 7 | ##### [Class ATOMIC-INTEGER](atomic-integer) 8 | 9 | ##### [Function ATOMIC-INTEGER-P](atomic-integer-p) 10 | 11 | ##### [Function MAKE-ATOMIC-INTEGER](make-atomic-integer) 12 | 13 | ##### [Function ATOMIC-INTEGER-CAS](atomic-integer-cas) 14 | 15 | ##### [Function ATOMIC-INTEGER-DECF](atomic-integer-decf) 16 | 17 | ##### [Function ATOMIC-INTEGER-INCF](atomic-integer-incf) 18 | 19 | ##### [Function ATOMIC-INTEGER-VALUE](atomic-integer-value) 20 | 21 | -------------------------------------------------------------------------------- /docs/content/condition-variables/condition-variable.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class CONDITION-VARIABLE 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | Implementation-defined. 10 | 11 | #### Description: 12 | 13 | This class represents condition variables. 14 | 15 | #### See also: 16 | 17 | [**make-condition-variable**](../make-condition-variable) 18 | 19 | #### Notes: 20 | 21 | On some implementations the library exposes the native type directly, 22 | while on others there is a custom implementations using semaphores and 23 | locks. 24 | -------------------------------------------------------------------------------- /docs/content/threads/start-multiprocessing.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function START-MULTIPROCESSING' 4 | weight: 10 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **start-multiprocessing** => No values. 10 | 11 | #### Arguments and values: 12 | 13 | Returns no values. 14 | 15 | #### Description: 16 | 17 | If the host implementation uses user-level threads, start the 18 | scheduler and multiprocessing, otherwise do nothing. It is safe to 19 | call repeatedly. 20 | 21 | #### Exceptional situations: 22 | 23 | None. 24 | 25 | #### Notes: 26 | 27 | Only has an effect on Allegro, CMUCL and Lispworks. 28 | -------------------------------------------------------------------------------- /apiv1/impl-corman.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; Thread Creation 12 | 13 | (defun %make-thread (function name) 14 | (declare (ignore name)) 15 | (threads:create-thread function)) 16 | 17 | (defun current-thread () 18 | threads:*current-thread*) 19 | 20 | ;;; Introspection/debugging 21 | 22 | (defun destroy-thread (thread) 23 | (signal-error-if-current-thread thread) 24 | (threads:terminate-thread thread)) 25 | 26 | (mark-supported) 27 | -------------------------------------------------------------------------------- /docs/content/threads/thread-yield.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function THREAD-YIELD' 4 | weight: 9 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **thread-yield** => No values. 10 | 11 | #### Arguments and values: 12 | 13 | Returns no values. 14 | 15 | #### Description 16 | 17 | Causes the calling thread to relinquish the CPU to allow other threads 18 | to run. 19 | 20 | #### Exceptional situations: 21 | 22 | None. 23 | 24 | #### Notes: 25 | 26 | On modern implementations that use native OS (SMP) threads, this 27 | function is of little use. On some older implementations where threads 28 | are scheduled in user space, it may be necessary or desirable to call 29 | this periodically. 30 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | -*- outline -*- 2 | 3 | Based on original Bordeaux-MP spec by Dan Barlow 4 | 5 | Contributors: 6 | 7 | * Attila Lendvai 8 | - better handling of unsupported Lisps 9 | * Vladimir Sekissov 10 | - fixes for CMUCL implementation 11 | * Pierre Thierry 12 | - added license information 13 | * Stelian Ionescu 14 | - finished conversion from generic functions 15 | - enabled running thread-safe code in unthreaded lisps 16 | * Douglas Crosher 17 | - added Scieneer Common Lisp support 18 | * Daniel Kochmański 19 | - semaphores implementation 20 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Class ATOMIC-INTEGER 4 | weight: 1 5 | --- 6 | 7 | #### Class precedence list: 8 | 9 | atomic-integer, t. 10 | 11 | #### Description: 12 | 13 | This class represents an unsigned machine word that allows atomic 14 | increment, decrement and swap. 15 | 16 | #### See also: 17 | 18 | [**make-atomic-integer**](../make-atomic-integer) 19 | 20 | #### Notes: 21 | 22 | Depending on the host implementation, the size of the integer is 23 | either 32 or 64 bits. 24 | 25 | This class is unavailble on Lisp implementations that lack underlying 26 | atomic primitives. On some hosts, **atomic-integer** is implemented 27 | using locks. 28 | -------------------------------------------------------------------------------- /docs/content/locks/lock-readers.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function LOCK-NAME, LOCK-NATIVE-LOCK 4 | weight: 5 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **lock-name** lock => name\ 10 | **lock-native-lock** lock => native-lock 11 | 12 | #### Arguments and values: 13 | 14 | *lock* -> a [lock](../lock) object.\ 15 | *name* -> a string or nil.\ 16 | *native-lock* -> a native lock object. 17 | 18 | #### Description: 19 | 20 | **lock-name** returns the lock name, or **nil** of the lock was not given 21 | a name on creation.\ 22 | **lock-native-lock** returns the native lock object that is wrapped by `lock`. 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**lock**](../lock) 31 | 32 | #### Notes: 33 | 34 | None. 35 | -------------------------------------------------------------------------------- /docs/content/threads/thread-readers.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function THREAD-NAME, THREAD-NATIVE-THREAD' 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **thread-name** thread => name\ 10 | **thread-native-thread** thread => native-thread 11 | 12 | #### Arguments and values: 13 | 14 | *thread* -> an instance of class [**thread**](../class-thread).\ 15 | *name* -> a 16 | [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string) 17 | or 18 | [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil)\ 19 | *native-thread* -> a host thread instance. 20 | 21 | #### Description: 22 | 23 | These accessors return the public slots of class [**thread**](../class-thread). 24 | 25 | #### Exceptional situations: 26 | 27 | None. 28 | -------------------------------------------------------------------------------- /docs/content/threads/destroy-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function DESTROY-THREAD' 4 | weight: 13 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **destroy-thread** thread => thread 10 | 11 | #### Arguments and values: 12 | 13 | *thread* -> a [thread](../class-thread) object. 14 | 15 | #### Description: 16 | 17 | Terminates the thread `thread`. 18 | 19 | #### Exceptional situations: 20 | 21 | Signals [bordeaux-threads-error](../bordeaux-threads-error) if 22 | attempting to destroy the calling thread, or a thread that already 23 | terminated. 24 | 25 | #### See also: 26 | 27 | [**join-thread**](../join-thread) 28 | 29 | #### Notes: 30 | 31 | This should be used with caution: it is implementation-defined whether 32 | the thread runs cleanup forms or releases its locks first. 33 | -------------------------------------------------------------------------------- /docs/content/locks/make-recursive-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function MAKE-RECURSIVE-LOCK 4 | weight: 13 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-recursive-lock** *&key* name => lock 10 | 11 | #### Arguments and values: 12 | 13 | *name* -> a string or nil.\ 14 | *lock* -> a [**recursive-lock**](../recursive-lock) object. 15 | 16 | #### Description: 17 | 18 | Creates a recursive lock named `name`. 19 | 20 | #### Exceptional situations: 21 | 22 | Signals a condition of type 23 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 24 | if `name` is neither a string nor nil. 25 | 26 | #### See also: 27 | 28 | [**recursive-lock**](../recursive-lock) 29 | 30 | #### Notes: 31 | 32 | A lock is also commonly known as a **mutex**. 33 | -------------------------------------------------------------------------------- /docs/content/locks/lockp.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function LOCKP 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **lockp** datum => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *datum* -> an object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a non-recursive lock, otherwise 22 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**lock**](../lock) 31 | 32 | #### Notes: 33 | 34 | None. 35 | -------------------------------------------------------------------------------- /docs/content/locks/make-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function MAKE-LOCK 4 | weight: 10 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-lock** *&key* name => lock 10 | 11 | #### Arguments and values: 12 | 13 | *name* -> a string or nil.\ 14 | *lock* -> a [**lock**](../lock) object. 15 | 16 | #### Description: 17 | 18 | Creates a non-recursive lock named `name`. 19 | 20 | #### Exceptional situations: 21 | 22 | Signals a condition of type 23 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 24 | if `name` is neither a string nor nil. 25 | 26 | #### See also: 27 | 28 | [**lock**](../lock) 29 | 30 | #### Notes: 31 | 32 | A lock is also commonly known as a **mutex**. 33 | 34 | On some implementations, the host lock type is always recursive. 35 | -------------------------------------------------------------------------------- /docs/content/atomics/make-atomic-integer.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function MAKE-ATOMIC-INTEGER 4 | weight: 3 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-atomic-integer** *&key* value => atomic-integer 10 | 11 | #### Arguments and values: 12 | 13 | *value* -> a non-negative integer.\ 14 | *semaphore* -> a [**semaphore**](../semaphore) object. 15 | 16 | #### Description: 17 | 18 | Creates an atomic integer `name` and initial value `value`. 19 | 20 | #### Exceptional situations: 21 | 22 | Signals a condition of type 23 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 24 | if `value` is not a non-negative integer (an unsigned-byte). 25 | 26 | #### See also: 27 | 28 | [**atomic-integer**](../atomic-integer) 29 | 30 | #### Notes: 31 | 32 | None. 33 | -------------------------------------------------------------------------------- /docs/content/threads/thread-alive-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function THREAD-ALIVE-P' 4 | weight: 14 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **thread-alive-p** thread => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *thread* -> a [thread](../class-thread) object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns true if `thread` has not finished or 20 | [**destroy-thread**](../destroy-thread) has not been called on it. 21 | 22 | #### Exceptional situations: 23 | 24 | Signals a type error if `thread` is not a [thread](../class-thread) 25 | object. 26 | 27 | #### See also: 28 | 29 | None. 30 | 31 | #### Notes: 32 | 33 | None. 34 | -------------------------------------------------------------------------------- /docs/content/threads/current-all-threads.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function CURRENT-THREAD, ALL-THREADS' 4 | weight: 6 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **current-thread** => thread\ 10 | **all-threads** => threads 11 | 12 | #### Arguments and values: 13 | 14 | *thread* -> a [thread](../class-thread) object.\ 15 | *threads* -> a list of [thread](../class-thread) objects. 16 | 17 | #### Description: 18 | 19 | **current-thread** returns the thread object representing the calling 20 | thread. 21 | 22 | **all-threads** returns a [fresh 23 | list](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh) 24 | of all running threads. 25 | 26 | #### Exceptional situations: 27 | 28 | None. 29 | 30 | #### See also: 31 | 32 | [**make-thread**](../make-thread) 33 | 34 | #### Notes: 35 | 36 | None. 37 | -------------------------------------------------------------------------------- /docs/content/locks/recursive-lock-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function RECURSIVE-LOCK-P 4 | weight: 4 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **recursive-lock-p** datum => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *datum* -> an object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a recursive lock, otherwise 22 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**recursive-lock**](../recursive-lock) 31 | 32 | #### Notes: 33 | 34 | None. 35 | -------------------------------------------------------------------------------- /docs/content/locks/native-lock-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function NATIVE-LOCK-P 4 | weight: 7 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **native-lock-p** lock => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *lock* -> a [lock](../lock) object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a native non-recursive lock, otherwise 22 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**lock**](../lock), [**native-lock**](../native-lock) 31 | 32 | #### Notes: 33 | 34 | None. 35 | -------------------------------------------------------------------------------- /.github/workflows/gh-pages-deployment.yml: -------------------------------------------------------------------------------- 1 | name: GitHub Pages 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | paths: [ 'docs/**' ] 7 | workflow_dispatch: 8 | inputs: 9 | 10 | jobs: 11 | build-deploy: 12 | runs-on: ubuntu-22.04 13 | concurrency: 14 | group: ${{ github.workflow }}-${{ github.ref }} 15 | steps: 16 | - uses: actions/checkout@v4 17 | with: 18 | submodules: true 19 | fetch-depth: 0 20 | 21 | - name: Setup Hugo 22 | uses: peaceiris/actions-hugo@v3 23 | with: 24 | hugo-version: '0.124.1' 25 | extended: true 26 | 27 | - name: Build 28 | run: hugo -s docs --minify 29 | 30 | - name: Deploy 31 | uses: peaceiris/actions-gh-pages@v4 32 | with: 33 | deploy_key: ${{ secrets.ACTIONS_DEPLOY_KEY }} 34 | publish_dir: ./docs/public 35 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer-value.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ATOMIC-INTEGER-VALUE 4 | weight: 7 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **atomic-integer-value** atomic-integer => value 10 | 11 | #### Arguments and values: 12 | 13 | *atomic-integer* -> an [**atomic-integer**](../atomic-integer) 14 | object.\ 15 | *value* -> a non-negative integer. 16 | 17 | #### Description 18 | 19 | Returns the current value of `atomic-integer`. 20 | 21 | #### Exceptional situations: 22 | 23 | Signals an error of type 24 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 25 | if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) 26 | object. 27 | 28 | #### See also: 29 | 30 | [**atomic-integer**](../atomic-integer), 31 | [**make-atomic-integer**](../make-atomic-integer) 32 | 33 | #### Notes: 34 | 35 | None. 36 | -------------------------------------------------------------------------------- /docs/content/semaphores/semaphorep.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function SEMAPHOREP 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **semaphorep** datum => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *datum* -> an object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a [**semaphore**](../semaphore) object, otherwise 22 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**semaphore**](../semaphore), [**make-semaphore**](../make-semaphore) 31 | 32 | #### Notes: 33 | 34 | None. 35 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ATOMIC-INTEGER-P 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **atomic-integer-p** datum => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *datum* -> an object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is an [**atomic-integer**](../atomic-integer] object, 22 | otherwise 23 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 24 | 25 | #### Exceptional situations: 26 | 27 | None. 28 | 29 | #### See also: 30 | 31 | [**atomic-integer**](../atomic-integer), 32 | [**make-atomic-integer**](../make-atomic-integer) 33 | 34 | #### Notes: 35 | 36 | None. 37 | -------------------------------------------------------------------------------- /test/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (defpackage :bordeaux-threads-2/test 5 | (:use :common-lisp :alexandria :bordeaux-threads-2 :fiveam) 6 | (:import-from :bordeaux-threads-2 7 | #:mark-not-implemented 8 | #:*missing-functions* 9 | #:*missing-features* 10 | #:implemented-p 11 | #:implemented-p*) 12 | (:shadow #:is)) 13 | 14 | (in-package :bordeaux-threads-2/test) 15 | 16 | (def-suite :bordeaux-threads-2) 17 | 18 | (defmacro is (test &rest reason-args) 19 | (with-gensyms (c) 20 | `(handler-case 21 | (5am:is ,test ,@reason-args) 22 | ((or bt2::operation-not-implemented 23 | bt2::keyarg-not-implemented) (,c) 24 | (declare (ignore ,c)) 25 | (5am:skip "Skipping operations that are not implemented"))))) 26 | -------------------------------------------------------------------------------- /docs/content/locks/native-recursive-lock-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function NATIVE-RECURSIVE-LOCK-P 4 | weight: 9 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **native-recursive-lock-p** lock => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *lock* -> a [recursive-lock](../recursive-lock) object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a native recursive lock, otherwise 22 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 23 | 24 | #### Exceptional situations: 25 | 26 | None. 27 | 28 | #### See also: 29 | 30 | [**recursive-lock**](../recursive-lock), 31 | [**native-recursive-lock**](../native-recursive-lock) 32 | 33 | #### Notes: 34 | 35 | None. 36 | -------------------------------------------------------------------------------- /docs/content/condition-variables/make-condition-variable.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function MAKE-CONDITION-VARIABLE 4 | weight: 3 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-condition-variable** *&key* name => condition-variable 10 | 11 | #### Arguments and values: 12 | 13 | *name* -> a string or nil.\ 14 | *condition-variable* -> a [**condition-variable**](../condition-variable) object. 15 | 16 | #### Description: 17 | 18 | Creates a condition variable named `name`. 19 | 20 | #### Exceptional situations: 21 | 22 | Signals a condition of type 23 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 24 | if `name` is neither a string nor nil. 25 | 26 | #### See also: 27 | 28 | [**condition-variable**](../condition-variable) 29 | 30 | #### Notes: 31 | 32 | On some implementations the library exposes the native type directly, 33 | while on others there is a custom implementations using semaphores and 34 | locks. 35 | -------------------------------------------------------------------------------- /docs/content/threads/threadp.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function: THREADP' 4 | weight: 3 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **threadp** object => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *object* -> an 14 | [object](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_o.htm#object).\ 15 | *generalized-boolean* -> a [generalized 16 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 17 | 18 | #### Description: 19 | 20 | Returns 21 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 22 | if `object` is of 23 | [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) 24 | [**thread**](../class-thread), otherwise 25 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 26 | 27 | #### Exceptional situations: 28 | 29 | None. 30 | 31 | #### Notes: 32 | 33 | `(threadp object) == (typep object 'thread)` 34 | -------------------------------------------------------------------------------- /docs/content/timeouts/with-timeout.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Macro WITH-TIMEOUT 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **with-timeout** (timeout) declaration\* forms\* => results 10 | 11 | #### Arguments and values: 12 | 13 | *timeout* -> a non-negative real number.\ 14 | *declaration* -> a declare expression; not evaluated.\ 15 | *forms* -> an implicit progn.\ 16 | *results* -> the values returned by the forms. 17 | 18 | #### Description: 19 | 20 | Execute `forms` and signal a condition of type 21 | [**timeout**](../timeout) if the execution of `forms` does not 22 | complete within `timeout` seconds. 23 | 24 | #### Exceptional situations: 25 | 26 | [**timeout**](../timeout), **not-implemented** 27 | 28 | #### See also: 29 | 30 | [**timeout**](../timeout) 31 | 32 | #### Notes: 33 | 34 | On implementations which do not support **with-timeout** natively and 35 | don't support threads either it signals a condition of type 36 | **not-implemented**. 37 | -------------------------------------------------------------------------------- /docs/content/condition-variables/condition-variable-p.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function CONDITION-VARIABLE-P 4 | weight: 2 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **condition-variable-p** datum => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *datum* -> an object.\ 14 | *generalized-boolean* -> a [generalized 15 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 16 | 17 | #### Description: 18 | 19 | Returns 20 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 21 | if `datum` is a [**condition-variable**](../condition-variable) 22 | object, otherwise 23 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 24 | 25 | #### Exceptional situations: 26 | 27 | None. 28 | 29 | #### See also: 30 | 31 | [**condition-variable**](../condition-variable), 32 | [**make-condition-variable**](../make-condition-variable) 33 | 34 | #### Notes: 35 | 36 | None. 37 | -------------------------------------------------------------------------------- /docs/content/locks/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Locks dictionary 4 | weight: 3 5 | --- 6 | 7 | ##### [Class LOCK](lock) 8 | 9 | ##### [Function LOCKP](lockp) 10 | 11 | ##### [Class RECURSIVE-LOCK](recursive-lock) 12 | 13 | ##### [Function RECURSIVE-LOCK-P](recursive-lock-p) 14 | 15 | ##### [Function LOCK-NAME, LOCK-NATIVE-LOCK](lock-readers) 16 | 17 | ##### [Host type NATIVE-LOCK](native-lock) 18 | 19 | ##### [Function NATIVE-LOCK-P](native-lock-p) 20 | 21 | ##### [Host type NATIVE-RECURSIVE-LOCK](native-recursive-lock) 22 | 23 | ##### [Function NATIVE-RECURSIVE-LOCK-P](native-recursive-lock-p) 24 | 25 | ##### [Function MAKE-LOCK](make-lock) 26 | 27 | ##### [Function ACQUIRE-LOCK, RELEASE-LOCK](acquire-release-lock) 28 | 29 | ##### [Macro WITH-LOCK-HELD](with-lock-held) 30 | 31 | ##### [Function MAKE-RECURSIVE-LOCK](make-recursive-lock) 32 | 33 | ##### [Function ACQUIRE-RECURSIVE-LOCK, RELEASE-RECURSIVE-LOCK](acquire-release-recursive-lock) 34 | 35 | ##### [Macro WITH-RECURSIVE-LOCK-HELD](with-recursive-lock-held) 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Permission is hereby granted, free of charge, to any person 2 | obtaining a copy of this software and associated documentation 3 | files (the "Software"), to deal in the Software without 4 | restriction, including without limitation the rights to use, 5 | copy, modify, merge, publish, distribute, sublicense, and/or sell 6 | copies of the Software, and to permit persons to whom the 7 | Software is furnished to do so, subject to the following 8 | conditions: 9 | 10 | The above copyright notice and this permission notice shall be 11 | included in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 15 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 17 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 20 | OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /docs/content/threads/abnormal-exit-condition.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function ABNORMAL-EXIT-CONDITION' 4 | weight: 16 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **abnormal-exit-condition** => condition 10 | 11 | #### Arguments and values: 12 | 13 | *condition* -> a condition object or `:terminated`. 14 | 15 | #### Description 16 | 17 | Returns the terminating condition of an 18 | [**abnormal-exit**](../abnormal-exit) condition object. If the thread 19 | was terminated by [**destroy-thread**](../destroy-thread) or other 20 | kinds of non-local exits, the keyword `:terminated` is returned. 21 | 22 | #### Examples: 23 | 24 | ``` 25 | (let ((thread (bt2:make-thread 26 | (lambda () (error "This will terminate the thread"))))) 27 | (handler-case 28 | (bt2:join-thread thread) 29 | (abnormal-exit (e) 30 | (abnormal-exit-condition e)))) 31 | ``` 32 | => `#` 33 | 34 | #### See also: 35 | 36 | [**abnormal-exit-condition**](../abnormal-exit-condition), 37 | [**join-thread**](../join-thread) 38 | -------------------------------------------------------------------------------- /docs/content/semaphores/signal-semaphore.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function SIGNAL-SEMAPHORE 4 | weight: 4 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **signal-semaphore** semaphore -> t 10 | 11 | #### Arguments and values: 12 | 13 | *semaphore* -> a 14 | [**semaphore**](../semaphore) object. 15 | 16 | #### Description: 17 | 18 | Increment `semaphore` by `count`. If there are threads waiting on this 19 | semaphore, then `count` of them are woken up. 20 | 21 | Returns always 22 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true). 23 | 24 | #### Exceptional situations: 25 | 26 | Signals an error of type 27 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 28 | if `semaphore` is not a [**semaphore**](../semaphore) object. 29 | 30 | #### See also: 31 | 32 | [**make-semaphore**](./make-semaphore), 33 | [**wait-on-semaphore**](./wait-on-semaphore) 34 | 35 | #### Notes: 36 | 37 | It is unspecified which thread gets a wakeup and does not necessarily 38 | relate to the order in which the threads went to sleep. 39 | -------------------------------------------------------------------------------- /docs/content/threads/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Threads dictionary 4 | weight: 2 5 | --- 6 | 7 | ##### [Class THREAD](class-thread) 8 | 9 | ##### [Function THREAD-NAME, THREAD-NATIVE-THREAD](thread-readers) 10 | 11 | ##### [Function THREADP](threadp) 12 | 13 | ##### [Function MAKE-THREAD](make-thread) 14 | 15 | ##### [Variable \*DEFAULT-SPECIAL-BINDINGS\*](default-special-bindings) 16 | 17 | ##### [Function CURRENT-THREAD, ALL-THREADS](current-all-threads) 18 | 19 | ##### [Function JOIN-THREAD](join-thread) 20 | 21 | ##### [Function THREAD-YIELD](thread-yield) 22 | 23 | ##### [Function START-MULTIPROCESSING](start-multiprocessing) 24 | 25 | ##### [Function INTERRUPT-THREAD](interrupt-thread) 26 | 27 | ##### [Function SIGNAL-IN-THREAD, WARN-IN-THREAD, ERROR-IN-THREAD](signal-in-thread) 28 | 29 | ##### [Function DESTROY-THREAD](destroy-thread) 30 | 31 | ##### [Function THREAD-ALIVE-P](thread-alive-p) 32 | 33 | ##### [Condition BORDEAUX-THREADS-ERROR](bordeaux-threads-error) 34 | 35 | ##### [Condition ABNORMAL-EXIT](abnormal-exit) 36 | 37 | ##### [Function ABNORMAL-EXIT-CONDITION](abnormal-exit-condition) 38 | -------------------------------------------------------------------------------- /docs/content/semaphores/make-semaphore.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function MAKE-SEMAPHORE 4 | weight: 3 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-semaphore** *&key* name count => semaphore 10 | 11 | #### Arguments and values: 12 | 13 | *name* -> a string or nil.\ 14 | *count* -> non-negative integer.\ 15 | *semaphore* -> a [**semaphore**](../semaphore) object. 16 | 17 | #### Description: 18 | 19 | Creates a semaphore named `name` and with initial value `count`. 20 | 21 | #### Exceptional situations: 22 | 23 | Signals a condition of type 24 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 25 | if `name` is neither a string nor nil.\ 26 | Signals a condition of type 27 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 28 | if `count` is not a non-negative integer (an unsigned-byte). 29 | 30 | #### See also: 31 | 32 | [**semaphore**](../semaphore) 33 | 34 | #### Notes: 35 | 36 | On some implementations the library exposes the native type directly, 37 | while on others there is a custom implementations using condition 38 | variables and locks. 39 | -------------------------------------------------------------------------------- /docs/content/threads/signal-in-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function SIGNAL-IN-THREAD, WARN-IN-THREAD, ERROR-IN-THREAD' 4 | weight: 12 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **signal-in-thread** thread datum *&rest* arguments => thread\ 10 | **warn-in-thread** thread datum *&rest* arguments => thread\ 11 | **error-in-thread** thread datum *&rest* arguments => thread 12 | 13 | #### Arguments and values: 14 | 15 | *thread* -> a [thread](../class-thread) object.\ 16 | *datum, arguments* -> designators for a condition. 17 | 18 | #### Description: 19 | 20 | Interrupt `thread` and apply `signal/warn/error` passing `datum` and 21 | `arguments`. 22 | 23 | #### Exceptional situations: 24 | 25 | None. 26 | 27 | #### See also: 28 | 29 | [**interrupt-thread**](../interrupt-thread), 30 | [**error**](http://www.lispworks.com/documentation/HyperSpec/Body/f_error.htm), 31 | [**signal**](http://www.lispworks.com/documentation/HyperSpec/Body/f_signal.htm), 32 | [**warn**](http://www.lispworks.com/documentation/HyperSpec/Body/f_warn.htm) 33 | 34 | 35 | #### Notes: 36 | 37 | These functions are currently implemented on top of 38 | [**interrupt-thread**](../interrupt-thread). 39 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | os: linux 2 | dist: focal 3 | language: generic 4 | 5 | env: 6 | jobs: 7 | - LISP=sbcl 8 | - LISP=ccl 9 | - LISP=ecl 10 | - LISP=abcl 11 | - LISP=clisp 12 | - LISP=allegro 13 | # - LISP=sbcl32 14 | # - lisp=ccl32 15 | # - LISP=cmucl 16 | 17 | jobs: 18 | fast_finish: true 19 | allow_failures: 20 | - env: LISP=clisp 21 | - env: LISP=allegro 22 | # - env: LISP=sbcl32 23 | # - env: LISP=ccl32 24 | # - env: LISP=cmucl 25 | 26 | notifications: 27 | email: 28 | on_success: change 29 | on_failure: always 30 | irc: 31 | channels: 32 | - "chat.freenode.net#iolib" 33 | on_success: change 34 | on_failure: always 35 | use_notice: true 36 | skip_join: true 37 | 38 | install: 39 | - curl -L https://raw.githubusercontent.com/lispci/cl-travis/master/install.sh | sh 40 | 41 | script: 42 | - cl -e "(cl:in-package :cl-user) 43 | (prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri) 44 | (ql:quickload :bordeaux-threads/test :verbose t) 45 | (5am:run! :bordeaux-threads) 46 | (uiop:quit 47 | (if (5am:run! :bordeaux-threads-2) 0 -1))" 48 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer-decf.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ATOMIC-INTEGER-DECF 4 | weight: 5 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **atomic-integer-decf** atomic-integer *&optional* (delta 1) => new-value 10 | 11 | #### Arguments and values: 12 | 13 | *atomic-integer* -> an [**atomic-integer**](../atomic-integer) 14 | object.\ 15 | *delta* -> an integer.\ 16 | *new-value* -> a non-negative integer. 17 | 18 | #### Description 19 | 20 | Decrements the value of `atomic-integer` by `delta`. 21 | 22 | Returns the new value of `atomic-integer`. 23 | 24 | #### Exceptional situations: 25 | 26 | Signals an error of type 27 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 28 | if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) 29 | object.\ 30 | Signals an error of type 31 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 32 | if `delta` is not an integer. 33 | 34 | #### See also: 35 | 36 | [**atomic-integer**](../atomic-integer), 37 | [**atomic-integer-incf**](../atomic-integer-incf), 38 | [**make-atomic-integer**](../make-atomic-integer) 39 | 40 | #### Notes: 41 | 42 | None. 43 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer-incf.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ATOMIC-INTEGER-INCF 4 | weight: 6 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **atomic-integer-incf** atomic-integer *&optional* (delta 1) => new-value 10 | 11 | #### Arguments and values: 12 | 13 | *atomic-integer* -> an [**atomic-integer**](../atomic-integer) 14 | object.\ 15 | *delta* -> an integer.\ 16 | *new-value* -> a non-negative integer. 17 | 18 | #### Description 19 | 20 | Increments the value of `atomic-integer` by `delta`. 21 | 22 | Returns the new value of `atomic-integer`. 23 | 24 | #### Exceptional situations: 25 | 26 | Signals an error of type 27 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 28 | if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) 29 | object.\ 30 | Signals an error of type 31 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 32 | if `delta` is not an integer. 33 | 34 | #### See also: 35 | 36 | [**atomic-integer**](../atomic-integer), 37 | [**atomic-integer-decf**](../atomic-integer-decf), 38 | [**make-atomic-integer**](../make-atomic-integer) 39 | 40 | #### Notes: 41 | 42 | None. 43 | -------------------------------------------------------------------------------- /apiv1/condition-variables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; This file provides a portable implementation of condition 12 | ;;; variables (given a working WITH-LOCK-HELD and THREAD-YIELD), and 13 | ;;; should be used if there is no condition variable implementation in 14 | ;;; the host Lisp. 15 | 16 | (defstruct condition-var 17 | name 18 | lock 19 | active) 20 | 21 | (defun condition-wait (condition-variable lock &key timeout) 22 | (signal-error-if-condition-wait-timeout timeout) 23 | (check-type condition-variable condition-var) 24 | (setf (condition-var-active condition-variable) nil) 25 | (release-lock lock) 26 | (do () 27 | ((when (condition-var-active condition-variable) 28 | (acquire-lock lock) 29 | t)) 30 | (thread-yield)) 31 | t) 32 | 33 | (define-condition-wait-compiler-macro) 34 | 35 | (defun condition-notify (condition-variable) 36 | (check-type condition-variable condition-var) 37 | (with-lock-held ((condition-var-lock condition-variable)) 38 | (setf (condition-var-active condition-variable) t))) 39 | -------------------------------------------------------------------------------- /docs/content/condition-variables/condition-broadcast.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function CONDITION-BROADCAST 4 | weight: 6 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **condition-broadcast** condition-variable -> generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *condition-variable* -> a 14 | [**condition-variable**](../condition-variable) object.\ 15 | *generalized-boolean* -> a [generalized 16 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 17 | 18 | #### Description: 19 | 20 | Notify all the threads waiting for `condition-variable`. 21 | 22 | Returns always 23 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 24 | 25 | #### Exceptional situations: 26 | 27 | Signals an error of type 28 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 29 | if `condition-variable` is not a 30 | [**condition-variable**](../condition-variable) object. 31 | 32 | #### See also: 33 | 34 | [**condition-wait**](./condition-wait), 35 | [**condition-notify**](./condition-notify) 36 | 37 | #### Notes: 38 | 39 | The order of wakeup is unspecified and does not necessarily relate to 40 | the order in which the threads went to sleep. 41 | 42 | **condition-broadcast** always returns 43 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) 44 | because not all implementations' primitives can tell whether or not 45 | some threads were indeed woken up. 46 | -------------------------------------------------------------------------------- /docs/content/condition-variables/condition-notify.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function CONDITION-NOTIFY 4 | weight: 5 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **condition-notify** condition-variable -> generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *condition-variable* -> a 14 | [**condition-variable**](../condition-variable) object.\ 15 | *generalized-boolean* -> a [generalized 16 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 17 | 18 | #### Description: 19 | 20 | Notify one of the threads waiting for `condition-variable`. 21 | 22 | Returns always 23 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 24 | 25 | #### Exceptional situations: 26 | 27 | Signals an error of type 28 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 29 | if `condition-variable` is not a 30 | [**condition-variable**](../condition-variable) object. 31 | 32 | #### See also: 33 | 34 | [**condition-wait**](./condition-wait), 35 | [**condition-broadcast**](./condition-broadcast) 36 | 37 | #### Notes: 38 | 39 | It is unspecified which thread gets a wakeup and does not necessarily 40 | relate to the order in which the threads went to sleep. 41 | 42 | **condition-notify** always returns 43 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) 44 | because not all implementations' primitives can tell whether or not 45 | some threads were indeed woken up. 46 | -------------------------------------------------------------------------------- /docs/content/threads/interrupt-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function INTERRUPT-THREAD' 4 | weight: 11 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **interrupt-thread** thread function *&rest* arguments => thread 10 | 11 | #### Arguments and values: 12 | 13 | *thread* -> a [thread](../class-thread) object.\ 14 | *function* -> a function object.\ 15 | *arguments* -> values. 16 | 17 | #### Description: 18 | 19 | Interrupt `thread` and apply `function` to `arguments` within its 20 | dynamic context, then continue with the interrupted path of execution. 21 | 22 | Returns the thread object it acted on. 23 | 24 | #### Exceptional situations: 25 | 26 | An error of 27 | [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) 28 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 29 | will be signaled if `thread` is not a [**thread**](../class-thread) object.\ 30 | An error of 31 | [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) 32 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 33 | will be signaled if `function` is not a [function 34 | designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator). 35 | 36 | #### See also: 37 | 38 | [**make-thread**](../make-thread), [**join-thread**](../join-thread) 39 | 40 | #### Notes: 41 | 42 | This may not be a good idea if `thread` is holding locks or doing 43 | anything important. 44 | -------------------------------------------------------------------------------- /docs/content/locks/with-lock-held.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Macro WITH-LOCK-HELD 4 | weight: 12 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **with-lock-held** (lock *&key* timeout) declaration\* forms\* => results 10 | 11 | #### Arguments and values: 12 | 13 | *lock* -> a [**lock**](../lock) object.\ 14 | *timeout* -> a non-negative real number.\ 15 | *declaration* -> a declare expression; not evaluated.\ 16 | *forms* -> an implicit progn.\ 17 | *results* -> the values returned by the forms. 18 | 19 | #### Description: 20 | 21 | Evaluates `forms`. Before the forms in BODY are evaluated, `lock` is 22 | acquired as if by using [**acquire-lock**](../acquire-lock). After 23 | the forms have been evaluated, or if a non-local control transfer is 24 | caused (e.g. by `throw` or `signal`), the lock is released as if by 25 | [**release-lock**](../release-lock). 26 | 27 | #### Exceptional situations: 28 | 29 | Signals an error of type 30 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 31 | is `lock` is not a [**lock**](../lock) object.\ 32 | Signals an error of type 33 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 34 | if `timeout` is neither nil nor a non-negative real number. 35 | 36 | #### See also: 37 | 38 | [**lock**](../lock), [**acquire-lock**](../acquire-lock), 39 | [**release-lock**](../release-lock) 40 | 41 | #### Notes: 42 | 43 | If the debugger is entered, it is unspecified whether the lock is 44 | released at debugger entry or at debugger exit when execution is 45 | restarted. 46 | -------------------------------------------------------------------------------- /docs/content/locks/with-recursive-lock-held.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Macro WITH-RECURSIVE-LOCK-HELD 4 | weight: 15 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **with-recursive-lock-held** (lock *&key* timeout) declaration\* forms\* => results 10 | 11 | #### Arguments and values: 12 | 13 | *lock* -> a [**recursive-lock**](../recursive-lock) object.\ 14 | *timeout* -> a non-negative real number.\ 15 | *declaration* -> a declare expression; not evaluated.\ 16 | *forms* -> an implicit progn.\ 17 | *results* -> the values returned by the forms. 18 | 19 | #### Description: 20 | 21 | Evaluates `forms`. Before the forms in BODY are evaluated, `lock` is 22 | acquired as if by using 23 | [**acquire-recursive-lock**](../acquire-recursive-lock). After the 24 | forms have been evaluated, or if a non-local control transfer is 25 | caused (e.g. by `throw` or `signal`), the lock is released 26 | as if by [**release-recursive-lock**](../release-recursive-lock). 27 | 28 | #### Exceptional situations: 29 | 30 | Signals an error of type 31 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 32 | is `lock` is not a [**recursive-lock**](../recursive-lock) object.\ 33 | Signals an error of type 34 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 35 | if `timeout` is neither nil nor a non-negative real number. 36 | 37 | #### See also: 38 | 39 | [**recursive-lock**](../recursive-lock), 40 | [**acquire-recursive-lock**](../acquire-recursive-lock), 41 | [**release-recursive-lock**](../release-recursive-lock) 42 | 43 | #### Notes: 44 | 45 | If the debugger is entered, it is unspecified whether the lock is 46 | released at debugger entry or at debugger exit when execution is 47 | restarted. 48 | -------------------------------------------------------------------------------- /docs/content/threads/join-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function JOIN-THREAD' 4 | weight: 7 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **join-thread** thread => multiple values 10 | 11 | #### Arguments and values: 12 | 13 | *thread* -> a [thread](../class-thread) object. 14 | 15 | #### Description 16 | 17 | Wait until `thread` terminates, or if it has already terminated, 18 | return immediately. 19 | 20 | The return values of the thread function are returned. 21 | 22 | #### Examples 23 | 24 | 25 | ``` 26 | (let ((thread (bt2:make-thread 27 | (lambda () (values 1 2 3))))) 28 | (bt2:join-thread thread)) 29 | 30 | ``` 31 | => 1, 2, 3 32 | 33 | #### Exceptional situations: 34 | 35 | If a thread is terminated by an unhandled condition, or by 36 | [**destroy-thread**](../destroy-thread), then the condition 37 | [**abnormal-exit**](../abnormal-exit) is signaled. 38 | 39 | #### See also: 40 | 41 | [**make-thread**](./make-thread), 42 | [**abnormal-exit**](../abnormal-exit) 43 | 44 | #### Notes: 45 | 46 | Due to how **join-thread** interacts with the dynamic environment 47 | established by **make-thread**, it is not safe to join with a thread 48 | that was created outside Bordeaux-Threads. For example, the following 49 | code has undefined behaviour and might very well corrupt the image: 50 | 51 | ``` 52 | (mapcar #'bt2:join-thread (bt2:all-threads)) 53 | ``` 54 | 55 | Bordeaux-Threads can only record instances of thread termination due 56 | to unhandled conditions or the use of 57 | [**destroy-thread**](../destroy-thread). In case of other ways to 58 | terminate a thread, such as throwing to an implementation-specific tag 59 | defined in the dynamic environment of the thread function, the 60 | behaviour of **join-thread** is undefined. 61 | -------------------------------------------------------------------------------- /apiv1/impl-mcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | (deftype thread () 12 | 'ccl::process) 13 | 14 | ;;; Thread Creation 15 | 16 | (defun %make-thread (function name) 17 | (ccl:process-run-function name function)) 18 | 19 | (defun current-thread () 20 | ccl:*current-process*) 21 | 22 | (defun threadp (object) 23 | (ccl::processp object)) 24 | 25 | (defun thread-name (thread) 26 | (ccl:process-name thread)) 27 | 28 | ;;; Resource contention: locks and recursive locks 29 | 30 | (deftype lock () 'ccl:lock) 31 | 32 | (defun lock-p (object) 33 | (typep object 'ccl:lock)) 34 | 35 | (defun make-lock (&optional name) 36 | (ccl:make-lock (or name "Anonymous lock"))) 37 | 38 | (defun acquire-lock (lock &optional (wait-p t)) 39 | (if wait-p 40 | (ccl:process-lock lock ccl:*current-process*) 41 | ;; this is broken, but it's better than a no-op 42 | (ccl:without-interrupts 43 | (when (null (ccl::lock.value lock)) 44 | (ccl:process-lock lock ccl:*current-process*))))) 45 | 46 | (defun release-lock (lock) 47 | (ccl:process-unlock lock)) 48 | 49 | (defmacro with-lock-held ((place) &body body) 50 | `(ccl:with-lock-grabbed (,place) ,@body)) 51 | 52 | (defun thread-yield () 53 | (ccl:process-allow-schedule)) 54 | 55 | ;;; Introspection/debugging 56 | 57 | (defun all-threads () 58 | ccl:*all-processes*) 59 | 60 | (defun interrupt-thread (thread function &rest args) 61 | (declare (dynamic-extent args)) 62 | (apply #'ccl:process-interrupt thread function args)) 63 | 64 | (defun destroy-thread (thread) 65 | (signal-error-if-current-thread thread) 66 | (ccl:process-kill thread)) 67 | 68 | (mark-supported) 69 | -------------------------------------------------------------------------------- /docs/content/atomics/atomic-integer-compare-and-swap.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ATOMIC-INTEGER-COMPARE-AND-SWAP 4 | weight: 4 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **atomic-integer-compare-and-swap** atomic-integer old new => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *atomic-integer* -> an [**atomic-integer**](../atomic-integer) 14 | object.\ 15 | *old*, *new* -> non-negative integers.\ 16 | *generalized-boolean* -> a [generalized 17 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 18 | 19 | #### Description 20 | 21 | If the current value of `atomic-integer` is equal to `old`, replace it 22 | with `new`. 23 | 24 | Returns 25 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 26 | if the replacement was successful, otherwise 27 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 28 | 29 | #### Exceptional situations: 30 | 31 | Signals an error of type 32 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 33 | if `atomic-integer` is not an [**atomic-integer**](../atomic-integer) 34 | object.\ 35 | Signals an error of type 36 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 37 | if `old` is not a non-negative integer.\ 38 | Signals an error of type 39 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 40 | if `new` is not a non-negative integer. 41 | 42 | #### See also: 43 | 44 | [**atomic-integer**](../atomic-integer), 45 | [**atomic-integer-incf**](../atomic-integer-incf), 46 | [**atomic-integer-decf**](../atomic-integer-decf), 47 | [**make-atomic-integer**](../make-atomic-integer) 48 | 49 | #### Notes: 50 | 51 | None. 52 | -------------------------------------------------------------------------------- /site/style.css: -------------------------------------------------------------------------------- 1 | /* 2 | Copyright 2006,2007 Greg Pfeil 3 | 4 | Distributed under the MIT license (see LICENSE file) 5 | */ 6 | 7 | tbody { 8 | border-top: thin dotted black; 9 | } 10 | 11 | .failure { 12 | background-color: #ff0; 13 | } 14 | 15 | .nonexistant { 16 | background-color: #ccc; 17 | } 18 | 19 | .perfect { 20 | background-color: #0f0; 21 | } 22 | 23 | .error { 24 | background-color: #f00; 25 | } 26 | 27 | .header { 28 | font-size: medium; 29 | background-color:#336699; 30 | color:#ffffff; 31 | border-style:solid; 32 | border-width: 5px; 33 | border-color:#002244; 34 | padding: 1mm 1mm 1mm 5mm; 35 | } 36 | 37 | .footer { 38 | font-size: small; 39 | font-style: italic; 40 | text-align: right; 41 | background-color:#336699; 42 | color:#ffffff; 43 | border-style:solid; 44 | border-width: 2px; 45 | border-color:#002244; 46 | padding: 1mm 1mm 1mm 1mm; 47 | } 48 | 49 | .footer a:link { 50 | font-weight:bold; 51 | color:#ffffff; 52 | background-color: #336699; 53 | text-decoration:underline; 54 | } 55 | 56 | .footer a:visited { 57 | font-weight:bold; 58 | color:#ffffff; 59 | background-color: #336699; 60 | text-decoration:underline; 61 | } 62 | 63 | .footer a:hover { 64 | font-weight:bold; 65 | color:#002244; 66 | background-color: #336699; 67 | text-decoration:underline; } 68 | 69 | .check {font-size: x-small; 70 | text-align:right;} 71 | 72 | .check a:link { font-weight:bold; 73 | color:#a0a0ff; 74 | background-color: #FFFFFF; 75 | text-decoration:underline; } 76 | 77 | .check a:visited { font-weight:bold; 78 | color:#a0a0ff; 79 | background-color: #FFFFFF; 80 | text-decoration:underline; } 81 | 82 | .check a:hover { font-weight:bold; 83 | color:#000000; 84 | background-color: #FFFFFF; 85 | text-decoration:underline; } 86 | 87 | -------------------------------------------------------------------------------- /docs/content/locks/acquire-release-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ACQUIRE-LOCK, RELEASE-LOCK 4 | weight: 11 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **acquire-lock** lock &key (wait t) timeout => generalized-boolean\ 10 | **release-lock** lock => lock 11 | 12 | #### Arguments and values: 13 | 14 | *lock* -> a [**lock**](../lock) object.\ 15 | *wait* -> a [generalized 16 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean).\ 17 | *timeout* -> a non-negative real number.\ 18 | *generalized-boolean* -> a [generalized 19 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 20 | 21 | #### Description: 22 | 23 | Acquire `lock` for the calling thread. 24 | 25 | `wait` governs what happens if the lock is not available: if `wait` is 26 | true, the calling thread will wait until the lock is available and 27 | then acquire it; if `wait` is nil, `acquire-lock` will return 28 | immediately. If `wait` is true, `timeout` may specify a maximum amount 29 | of seconds to wait for the lock to become available. 30 | 31 | `acquire-lock` returns 32 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 33 | if the lock was acquired, otherwise 34 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 35 | 36 | #### Exceptional situations: 37 | 38 | Signals an error of type 39 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 40 | if `lock` is not a [**lock**](../lock) object.\ 41 | Signals an error of type 42 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 43 | if `timeout` is neither nil nor a non-negative real number. 44 | 45 | #### See also: 46 | 47 | [**lock**](../lock) 48 | 49 | #### Notes: 50 | 51 | It is implementation-defined what happens if a thread attempts to 52 | acquire a lock that it already holds. 53 | -------------------------------------------------------------------------------- /docs/content/locks/acquire-release-recursive-lock.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function ACQUIRE-RECURSIVE-LOCK, RELEASE-RECURSIVE-LOCK 4 | weight: 14 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **acquire-recursive-lock** lock &key (wait t) timeout => generalized-boolean\ 10 | **release-recursive-lock** lock => lock 11 | 12 | #### Arguments and values: 13 | 14 | *lock* -> a [**recursive-lock**](../recursive-lock) object.\ 15 | *wait* -> a [generalized 16 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean).\ 17 | *timeout* -> a non-negative real number.\ 18 | *generalized-boolean* -> a [generalized 19 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 20 | 21 | #### Description: 22 | 23 | Acquire `lock` for the calling thread. 24 | 25 | `wait` governs what happens if the lock is not available: if `wait` is 26 | true, the calling thread will wait until the lock is available and 27 | then acquire it; if `wait` is nil, `acquire-recursive-lock` will 28 | return immediately. If `wait` is true, `timeout` may specify a maximum 29 | amount of seconds to wait for the lock to become available. 30 | 31 | `acquire-recursive-lock` returns 32 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 33 | if the lock was acquired, otherwise 34 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false). 35 | 36 | #### Exceptional situations: 37 | 38 | Signals an error of type 39 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 40 | if `lock` is not a [**recursive-lock**](../recursive-lock) object.\ 41 | Signals an error of type 42 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 43 | if `timeout` is neither nil nor a non-negative real number. 44 | 45 | #### See also: 46 | 47 | [**recursive-lock**](../recursive-lock) 48 | 49 | #### Notes: 50 | 51 | None. 52 | -------------------------------------------------------------------------------- /docs/content/semaphores/wait-on-semaphore.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function WAIT-ON-SEMAPHORE 4 | weight: 5 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **wait-on-semaphore** semaphore *&key* timeout -> generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *semaphore* -> a 14 | [**semaphore**](../semaphore) object.\ 15 | *timeout* -> a non-negative real number.\ 16 | *generalized-boolean* -> a [generalized 17 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 18 | 19 | #### Description: 20 | 21 | Decrement the count of `semaphore` by 1 if the count is larger than zero.\ 22 | If the count is zero, blocks until `semaphore` can be decremented. 23 | Returns 24 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true) 25 | on success. 26 | 27 | If `timeout` is given, it is the maximum number of seconds to wait. If 28 | the count cannot be decremented in that time, returns 29 | [false](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#false) 30 | without decrementing the count. 31 | 32 | #### Exceptional situations: 33 | 34 | Signals an error of type 35 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 36 | if `semaphore` is not a [**semaphore**](../semaphore) object.\ 37 | Signals an error of type 38 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 39 | if `timeout` is neither nil nor a non-negative real number. 40 | 41 | #### See also: 42 | 43 | [**make-semaphore**](./make-semaphore), 44 | [**wait-on-semaphore**](./wait-on-semaphore) 45 | 46 | #### Notes: 47 | 48 | It is unspecified which thread gets a wakeup and does not necessarily 49 | relate to the order in which the threads went to sleep. 50 | 51 | On Allegro, a non-null `timeout` is forced to a minimum of 100ms, 52 | because Allegro does not provide a primitive for waiting with a 53 | timeout, which is emulated using 54 | [**with-timeout**](../../timeouts/with-timeout). 55 | -------------------------------------------------------------------------------- /docs/config.toml: -------------------------------------------------------------------------------- 1 | baseURL = "https://sionescu.github.io/bordeaux-threads/" 2 | languageCode = "en-us" 3 | title = "Bordeaux-Threads" 4 | 5 | theme = "techdoc" 6 | publishDir = "public" 7 | 8 | defaultContentLanguage = "en" 9 | defaultContentLanguageInSubdir= false 10 | enableMissingTranslationPlaceholders = false 11 | 12 | [params] 13 | 14 | # Source Code repository section 15 | description = "Common Lisp threading library" 16 | github_repository = "https://github.com/sionescu/bordeaux-threads" 17 | version = "0.8.8" 18 | 19 | # Documentation repository section 20 | # documentation repository (set edit link to documentation repository) 21 | github_doc_repository = "https://github.com/sionescu/bordeaux-threads" 22 | 23 | # Theme settings section 24 | # Theme color 25 | # See color value reference https://developer.mozilla.org/en-US/docs/Web/CSS/color 26 | custom_font_color = "" 27 | custom_background_color = "" 28 | 29 | # Documentation Menu section 30 | # Menu style settings 31 | menu_style = "slide-menu" # "open-menu" or "slide-menu" 32 | 33 | # Date format 34 | dateformat = "2006-01-02" # default "2 Jan 2006" 35 | # See the format reference https://gohugo.io/functions/format/#hugo-date-and-time-templating-reference 36 | 37 | # path name excluded from documentation menu 38 | menu_exclusion = [ 39 | "archives", 40 | "archive", 41 | "blog", 42 | "entry", 43 | "post", 44 | "posts", 45 | ] 46 | 47 | # Global menu section 48 | # See https://gohugo.io/content-management/menus/ 49 | [menu] 50 | [[menu.main]] 51 | name = "Home" 52 | url = "/" 53 | weight = 1 54 | 55 | # Markup configure section 56 | # See https://gohugo.io/getting-started/configuration-markup/ 57 | [markup] 58 | defaultMarkdownHandler = "goldmark" 59 | [markup.goldmark.renderer] 60 | unsafe = true 61 | [markup.tableOfContents] 62 | startLevel = 2 63 | endLevel = 6 64 | ordered = false 65 | -------------------------------------------------------------------------------- /apiv2/impl-corman.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'threads:thread) 11 | 12 | (defun %make-thread (function name) 13 | (declare (ignore name)) 14 | (threads:create-thread function)) 15 | 16 | (defun %current-thread () 17 | threads:*current-thread*) 18 | 19 | (defun %thread-name (thread) 20 | (declare (ignore thread)) 21 | nil) 22 | 23 | (mark-not-implemented 'join-thread) 24 | (defun %join-thread (thread) 25 | (declare (ignore thread)) 26 | (signal-not-implemented 'join-thread)) 27 | 28 | (mark-not-implemented 'thread-yield) 29 | (defun %thread-yield () 30 | (declare (ignore thread)) 31 | (signal-not-implemented 'thread-yield)) 32 | 33 | ;;; 34 | ;;; Introspection/debugging 35 | ;;; 36 | 37 | (mark-not-implemented 'all-threads) 38 | (defun %all-threads () 39 | (declare (ignore thread)) 40 | (signal-not-implemented 'all-threads)) 41 | 42 | (mark-not-implemented 'interrupt-thread) 43 | (defun %interrupt-thread (thread function) 44 | (declare (ignore thread)) 45 | (signal-not-implemented 'interrupt-thread)) 46 | 47 | (defun %destroy-thread (thread) 48 | (threads:terminate-thread thread)) 49 | 50 | (mark-not-implemented 'thread-alive-p) 51 | (defun %thread-alive-p (thread) 52 | (declare (ignore thread)) 53 | (signal-not-implemented 'thread-alive-p)) 54 | 55 | 56 | ;;; 57 | ;;; Locks 58 | ;;; 59 | 60 | (mark-not-implemented 'make-lock) 61 | (defun %make-lock (lock waitp timeout) 62 | (declare (ignore lock waitp timeout)) 63 | (signal-not-implemented 'make-lock)) 64 | 65 | (mark-not-implemented 'make-recursive-lock) 66 | (defun %make-recursive-lock (lock waitp timeout) 67 | (declare (ignore lock waitp timeout)) 68 | (signal-not-implemented 'make-recursive-lock)) 69 | 70 | 71 | ;;; 72 | ;;; Condition variables 73 | ;;; 74 | 75 | (mark-not-implemented 'make-condition-variable) 76 | (defun %make-condition-variable (name) 77 | (declare (ignore name)) 78 | (signal-not-implemented 'make-condition-variable)) 79 | -------------------------------------------------------------------------------- /docs/content/_index.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Documentation 4 | --- 5 | 6 | ## Raison d'être 7 | 8 | Bordeaux-Threads is a minimal library that aims to provide the basic 9 | concepts required for multi-threading programming, such as threads, 10 | mutexes, semaphores and condition variables. Higher-level data 11 | structures such as queues, mailboxes, thread pools, execution graphs, 12 | etc... tend to be more specialized and are better left to other 13 | libraries. 14 | 15 | This document describes the second version of the API (APIv2), which 16 | differs from the first version in a few key points and aims to provide 17 | a more uniformous interface across all Common Lisp implementations. 18 | 19 | ## Migration from APIv1 to APIv2 20 | 21 | APIv2 is mostly compatible with v1, and in most cases it should 22 | suffice to replace all references to package `bordeaux-threads` (or 23 | `bt`) with `bordeaux-threads-2` (or `bt2`). 24 | 25 | For more details, there's a [blog 26 | post](https://blog.cddr.org/posts/2023-05-27-bordeaux-threads-apiv2/). 27 | 28 | ## Host support 29 | 30 | When Bordeaux-Threads was created, most Common Lisp implementations 31 | were either single-threaded or provided user-space scheduling akin to 32 | green threads, and therefore Bordeaux-Threads tried to support all 33 | such implementations as well as possible. 34 | 35 | Bordeaux-Threads APIV2 no longer supports single-threaded 36 | implementations and was conceived to work best with hosts that provide 37 | SMP threads. 38 | 39 | In most cases Bordeaux-Threads simply wraps the primitives provided by 40 | the host implementation. Whenever the primitives are absent from the 41 | host, we try to provide an ersatz implementation that is optimized for 42 | correctness and readability rather than performance. 43 | 44 | The two absolutely necessary primitives are **threads** and 45 | **locks**. **Semaphores** and **condition variables** can be 46 | implemented in terms of one another, and that's the case on a few 47 | implementations. **Atomic operations** vary greatly in what kind of 48 | forms they operate on so we do not expose them, instead providing 49 | slightly higher-level constructs. 50 | -------------------------------------------------------------------------------- /site/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 8 | 9 | 11 | 12 | 13 | Bordeaux Threads project 14 | 15 | 16 | 17 | 18 | 19 |
20 |

Bordeaux Threads

21 |

Portable shared-state concurrency for Common Lisp

22 |
23 | 24 |

Based on an original proposal by Dan Barlow (Bordeaux-MP) this 25 | library is meant to make writing portable multi-threaded apps 26 | simple.

27 | 28 |

Read the current API documentation.

29 | 30 |

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

34 | 35 |

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

38 | 39 |

Source repository

40 | 41 |

Bordeaux-threads is developed 42 | at Github. The 43 | repository is also mirrored 44 | to Gitlab 45 | and Bitbucket.

46 | 47 |
48 | Stelian Ionescu. Last modified: 49 |
50 | 51 |
52 | Valid XHTML 1.0 Strict 53 |
54 | 55 | 56 | -------------------------------------------------------------------------------- /apiv2/impl-condition-variables-semaphores.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Portable condition variables using semaphores. 7 | ;;; 8 | ;;; The implementation is meant to be correct and readable, 9 | ;;; without trying too hard to be very fast. 10 | ;;; 11 | 12 | (defstruct queue 13 | (vector (make-array 7 :adjustable t :fill-pointer 0) :type vector) 14 | (lock (%make-lock nil) :type native-lock)) 15 | 16 | (defun queue-drain (queue) 17 | (%with-lock ((queue-lock queue) nil) 18 | (shiftf (queue-vector queue) 19 | (make-array 7 :adjustable t :fill-pointer 0)))) 20 | 21 | (defun queue-dequeue (queue) 22 | (%with-lock ((queue-lock queue) nil) 23 | (let ((vector (queue-vector queue))) 24 | (if (zerop (length vector)) 25 | nil 26 | (vector-pop vector))))) 27 | 28 | (defun queue-enqueue (queue value) 29 | (%with-lock ((queue-lock queue) nil) 30 | (vector-push-extend value (queue-vector queue)))) 31 | 32 | (defstruct (condition-variable 33 | (:constructor %make-condition-variable (name)) 34 | ;; CONDITION-VARIABLE-P is defined in API-CONDITION-VARIABLES.LISP 35 | (:predicate nil)) 36 | name 37 | (queue (make-queue))) 38 | 39 | (defmethod print-object ((cv condition-variable) stream) 40 | (print-unreadable-object (cv stream :type t :identity t) 41 | (format stream "~S" (condition-variable-name cv)))) 42 | 43 | (defun %condition-wait (cv lock timeout) 44 | (with-slots (queue) cv 45 | (let* ((thread (current-thread)) 46 | (semaphore (%thread-semaphore thread))) 47 | (queue-enqueue queue thread) 48 | (%release-lock lock) 49 | (unwind-protect 50 | (%wait-on-semaphore semaphore timeout) 51 | (%acquire-lock lock t nil))))) 52 | 53 | (defun %condition-notify (cv) 54 | (with-slots (queue) cv 55 | (when-let ((next-thread (queue-dequeue queue))) 56 | (%signal-semaphore (%thread-semaphore next-thread) 1)))) 57 | 58 | (defun %condition-broadcast (cv) 59 | (with-slots (queue) cv 60 | (let ((queued-threads (queue-drain queue))) 61 | (map nil (lambda (thr) 62 | (%signal-semaphore (%thread-semaphore thr) 1)) 63 | queued-threads)))) 64 | -------------------------------------------------------------------------------- /apiv2/timeout-interrupt.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2) 5 | 6 | #-(or allegro clisp cmu genera sbcl) 7 | (define-condition interrupt () 8 | ((tag :initarg :tag :reader interrupt-tag))) 9 | 10 | #-(or allegro clisp cmu genera sbcl) 11 | (defmacro with-timeout ((timeout) &body body) 12 | "Execute `BODY' and signal a condition of type TIMEOUT if the execution of 13 | BODY does not complete within `TIMEOUT' seconds. On implementations which do not 14 | support WITH-TIMEOUT natively and don't support threads either it signals a 15 | condition of type `NOT-IMPLEMENTED`." 16 | (declare (ignorable timeout body)) 17 | #+thread-support 18 | (once-only (timeout) 19 | (with-gensyms (ok-tag interrupt-tag caller interrupt-thread c) 20 | `(let (,interrupt-thread) 21 | (unwind-protect-case () 22 | (catch ',ok-tag 23 | (let* ((,interrupt-tag (gensym "INTERRUPT-TAG-")) 24 | (,caller (current-thread))) 25 | (setf ,interrupt-thread 26 | (make-thread 27 | #'(lambda () 28 | (sleep ,timeout) 29 | (interrupt-thread 30 | ,caller 31 | #'(lambda () (signal 'interrupt :tag ,interrupt-tag)))) 32 | :name (format nil "WITH-TIMEOUT thread serving: ~S." 33 | (thread-name ,caller)))) 34 | (handler-bind 35 | ((interrupt #'(lambda (,c) 36 | (when (eql ,interrupt-tag (interrupt-tag ,c)) 37 | (error 'timeout :length ,timeout))))) 38 | (throw ',ok-tag (progn ,@body))))) 39 | (:normal 40 | (when (and ,interrupt-thread (thread-alive-p ,interrupt-thread)) 41 | ;; There's a potential race condition between THREAD-ALIVE-P 42 | ;; and DESTROY-THREAD but calling the latter when a thread already 43 | ;; terminated should not be a grave matter. 44 | (ignore-errors (destroy-thread ,interrupt-thread)))))))) 45 | #-thread-support 46 | `(signal-not-implemented 'with-timeout)) 47 | -------------------------------------------------------------------------------- /apiv2/impl-mcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'ccl::process) 11 | 12 | (defun %make-thread (function name) 13 | (ccl:process-run-function name function)) 14 | 15 | (defun %current-thread () 16 | ccl:*current-process*) 17 | 18 | (defun %thread-name (thread) 19 | (ccl:process-name thread)) 20 | 21 | (mark-not-implemented 'join-thread) 22 | (defun %thread-join (thread) 23 | (declare (ignore thread)) 24 | (signal-not-implemented 'join-thread)) 25 | 26 | (defun %thread-yield () 27 | (ccl:process-allow-schedule)) 28 | 29 | ;;; 30 | ;;; Introspection/debugging 31 | ;;; 32 | 33 | (defun %all-threads () 34 | ccl:*all-processes*) 35 | 36 | (defun %interrupt-thread (thread function) 37 | (ccl:process-interrupt thread function)) 38 | 39 | (defun %destroy-thread (thread) 40 | (ccl:process-kill thread)) 41 | 42 | (mark-not-implemented 'thread-alive-p) 43 | (defun %thread-alive-p (thread) 44 | (declare (ignore thread)) 45 | (signal-not-implemented 'thread-alive-p)) 46 | 47 | 48 | ;;; 49 | ;;; Non-recursive locks 50 | ;;; 51 | 52 | (deftype native-lock () 'ccl:lock) 53 | 54 | (defun %make-lock (name) 55 | (ccl:make-lock name)) 56 | 57 | (mark-not-implemented 'acquire-lock :timeout) 58 | (defun %acquire-lock (lock waitp timeout) 59 | (when timeout 60 | (signal-not-implemented 'acquire-lock :timeout)) 61 | (if waitp 62 | (ccl:process-lock lock ccl:*current-process*) 63 | ;; this is broken, but it's better than a no-op 64 | (ccl:without-interrupts 65 | (when (null (ccl::lock.value lock)) 66 | (ccl:process-lock lock ccl:*current-process*))))) 67 | 68 | (defun %release-lock (lock) 69 | (ccl:process-unlock lock)) 70 | 71 | (mark-not-implemented 'with-lock-held :timeout) 72 | (defmacro %with-lock ((place timeout) &body body) 73 | (if timeout 74 | `(signal-not-implemented 'with-lock-held :timeout) 75 | `(ccl:with-lock-grabbed (,place) ,@body))) 76 | 77 | ;;; 78 | ;;; Recursive locks 79 | ;;; 80 | 81 | (mark-not-implemented 'acquire-recursive-lock) 82 | (defun %acquire-recursive-lock (lock waitp timeout) 83 | (declare (ignore lock waitp timeout)) 84 | (signal-not-implemented 'acquire-recursive-lock)) 85 | 86 | 87 | ;;; 88 | ;;; Condition variables 89 | ;;; 90 | 91 | (mark-not-implemented make-condition-variable) 92 | (defun %make-condition-variable (name) 93 | (declare (ignore name)) 94 | (signal-not-implemented make-condition-variable)) 95 | -------------------------------------------------------------------------------- /docs/content/condition-variables/condition-wait.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: Function CONDITION-WAIT 4 | weight: 4 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **condition-wait** condition-variable lock *&key* timeout => generalized-boolean 10 | 11 | #### Arguments and values: 12 | 13 | *condition-variable* -> a 14 | [**condition-variable**](../condition-variable) object.\ 15 | *lock* -> a [**lock**](../lock) object.\ 16 | *timeout* -> a non-negative real number.\ 17 | *generalized-boolean* -> a [generalized 18 | boolean](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean). 19 | 20 | #### Description: 21 | 22 | Atomically release `lock` and enqueue the calling thread waiting for 23 | `condition-variable`. The thread will resume when another thread has 24 | notified it using [**condition-notify**](./condition-notify); it may 25 | also resume if interrupted by some external event or in other 26 | implementation-dependent circumstances: the caller must always test on 27 | waking that there is threading to be done, instead of assuming that it 28 | can go ahead.\ 29 | It is an error to call this function unless from the thread that holds 30 | `lock`. 31 | 32 | If `timeout` is nil or not provided, the call blocks until a 33 | notification is received.\ 34 | If `timeout` is non-nil, the call will return after at most `timeout` 35 | seconds (approximately), whether or not a notification has occurred. 36 | 37 | Either **true** or **false** will be returned. **false** indicates 38 | that the timeout has expired without receiving a 39 | notification. **true** indicates that a notification was received. 40 | 41 | #### Exceptional situations: 42 | 43 | Signals an error of type 44 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 45 | if `condition-variable` is not a 46 | [**condition-variable**](../condition-variable) object.\ 47 | Signals an error of type 48 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 49 | if `lock` is not a [**lock**](../lock) object.\ 50 | Signals an error of type 51 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 52 | if `timeout` is neither nil nor a non-negative real number. 53 | 54 | #### See also: 55 | 56 | [**condition-notify**](./condition-notify), 57 | [**condition-broadcast**](./condition-broadcast) 58 | 59 | #### Notes: 60 | 61 | Due to implementation limitations, there is the possibility of 62 | spurious wakeups, i.e. for **condition-wait** to return **true** 63 | without the underlying condition being satisfied. Correct code must 64 | always check whether the condition is satisfied, and otherwise call 65 | **condition-wait** again, typically in a loop. 66 | -------------------------------------------------------------------------------- /apiv2/atomics-java.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | (defstruct (atomic-integer 6 | (:constructor %make-atomic-integer (cell))) 7 | "Wrapper for java.util.concurrent.AtomicLong." 8 | cell) 9 | 10 | (defmethod print-object ((aint atomic-integer) stream) 11 | (print-unreadable-object (aint stream :type t :identity t) 12 | (format stream "~S" (atomic-integer-value aint)))) 13 | 14 | (deftype %atomic-integer-value () 15 | '(unsigned-byte 63)) 16 | 17 | (defun make-atomic-integer (&key (value 0)) 18 | (check-type value %atomic-integer-value) 19 | (%make-atomic-integer 20 | (jnew "java.util.concurrent.atomic.AtomicLong" value))) 21 | 22 | (defconstant +atomic-long-cas+ 23 | (jmethod "java.util.concurrent.atomic.AtomicLong" "compareAndSet" 24 | (jclass "long") (jclass "long"))) 25 | 26 | (defun atomic-integer-compare-and-swap (atomic-integer old new) 27 | (declare (type atomic-integer atomic-integer) 28 | (type %atomic-integer-value old new) 29 | (optimize (safety 0) (speed 3))) 30 | (jcall +atomic-long-cas+ (atomic-integer-cell atomic-integer) 31 | old new)) 32 | 33 | (defconstant +atomic-long-incf+ 34 | (jmethod "java.util.concurrent.atomic.AtomicLong" "getAndAdd" 35 | (jclass "long"))) 36 | 37 | (defun atomic-integer-decf (atomic-integer &optional (delta 1)) 38 | (declare (type atomic-integer atomic-integer) 39 | (type %atomic-integer-value delta) 40 | (optimize (safety 0) (speed 3))) 41 | (let ((increment (- delta))) 42 | (+ (jcall +atomic-long-incf+ (atomic-integer-cell atomic-integer) 43 | increment) 44 | increment))) 45 | 46 | (defun atomic-integer-incf (atomic-integer &optional (delta 1)) 47 | (declare (type atomic-integer atomic-integer) 48 | (type %atomic-integer-value delta) 49 | (optimize (safety 0) (speed 3))) 50 | (+ (jcall +atomic-long-incf+ (atomic-integer-cell atomic-integer) 51 | delta) 52 | delta)) 53 | 54 | (defconstant +atomic-long-get+ 55 | (jmethod "java.util.concurrent.atomic.AtomicLong" "get")) 56 | 57 | (defun atomic-integer-value (atomic-integer) 58 | (declare (type atomic-integer atomic-integer) 59 | (optimize (safety 0) (speed 3))) 60 | (jcall +atomic-long-get+ (atomic-integer-cell atomic-integer))) 61 | 62 | (defconstant +atomic-long-set+ 63 | (jmethod "java.util.concurrent.atomic.AtomicLong" "set" 64 | (jclass "long"))) 65 | 66 | (defun (setf atomic-integer-value) (newval atomic-integer) 67 | (declare (type atomic-integer atomic-integer) 68 | (type %atomic-integer-value newval) 69 | (optimize (safety 0) (speed 3))) 70 | (jcall +atomic-long-set+ (atomic-integer-cell atomic-integer) 71 | newval) 72 | newval) 73 | -------------------------------------------------------------------------------- /docs/content/threads/default-special-bindings.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Variable *DEFAULT-SPECIAL-BINDINGS*' 4 | weight: 5 5 | --- 6 | 7 | #### Value type: 8 | 9 | an 10 | [alist](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist) 11 | mapping symbol names to forms to evaluate. 12 | 13 | #### Initial value: 14 | 15 | [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil). 16 | 17 | #### Description: 18 | 19 | Variables named in this list are locally bound in the new thread, 20 | before it begins executing user code, by calling 21 | [eval](http://www.lispworks.com/documentation/HyperSpec/Body/f_eval.htm#eval) 22 | on its associated form. 23 | 24 | This variable may be rebound around calls to [make-thread](../make-thread) 25 | to add/alter default bindings. The effect of mutating this list is 26 | undefined, but earlier forms take precedence over later forms for the 27 | same symbol, so defaults may be overridden by consing to the head of the 28 | list. 29 | 30 | The bindings in `*default-special-bindings*` are used to determine the 31 | initial bindings of a new thread, and take precedence over a default 32 | list of I/O bindings. The list of initial I/O bindings is not 33 | modifiable by the user and it was chosen to avoid potential 34 | implementation-defined differences in 35 | [with-standard-io-syntax](http://www.lispworks.com/documentation/HyperSpec/Body/m_w_std_.htm#with-standard-io-syntax). 36 | 37 | ``` 38 | *package* (find-package :common-lisp-user) 39 | *print-array* t 40 | *print-base* 10 41 | *print-case* :upcase 42 | *print-circle* nil 43 | *print-escape* t 44 | *print-gensym* t 45 | *print-length* nil 46 | *print-level* nil 47 | *print-lines* nil 48 | *print-miser-width* nil 49 | *print-pprint-dispatch* (copy-pprint-dispatch nil) 50 | *print-pretty* nil 51 | *print-radix* nil 52 | *print-readably* t 53 | *print-right-margin* nil 54 | *random-state* (make-random-state t) 55 | *read-base* 10 56 | *read-default-float-format* 'double-float 57 | *read-eval* nil 58 | *read-suppress* nil 59 | *readtable* (copy-readtable nil) 60 | ``` 61 | 62 | #### Examples: 63 | 64 | ``` 65 | ;;; Make a thread read integers in base 7. 66 | (let* ((bt2:*default-special-bindings* 67 | (acons '*read-base* 7 68 | bt2:*default-special-bindings*)) 69 | (thread (bt2:make-thread (lambda () (read-from-string "10"))))) 70 | (bt2:join-thread thread)) 71 | ``` 72 | => 7, 2 73 | 74 | #### See also: 75 | 76 | [**make-thread**](../make-thread) 77 | 78 | #### Notes: 79 | 80 | The binding code does not check whether a symbol is indeed declared 81 | special or not. 82 | -------------------------------------------------------------------------------- /apiv2/impl-clasp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'mp:process) 11 | 12 | (defun %make-thread (function name) 13 | (mp:process-run-function name function)) 14 | 15 | (defun %current-thread () 16 | mp:*current-process*) 17 | 18 | (defun %thread-name (thread) 19 | (mp:process-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (mp:process-join thread)) 23 | 24 | (defun %thread-yield () 25 | (mp:process-yield)) 26 | 27 | ;;; 28 | ;;; Introspection/debugging 29 | ;;; 30 | 31 | (defun %all-threads () 32 | (mp:all-processes)) 33 | 34 | (defun %interrupt-thread (thread function) 35 | (mp:interrupt-process thread function)) 36 | 37 | (defun %destroy-thread (thread) 38 | (mp:process-kill thread)) 39 | 40 | (defun %thread-alive-p (thread) 41 | (mp:process-active-p thread)) 42 | 43 | 44 | ;;; 45 | ;;; Non-recursive locks 46 | ;;; 47 | 48 | (deftype native-lock () 'mp:mutex) 49 | 50 | (defun %make-lock (name) 51 | (mp:make-lock :name name)) 52 | 53 | (mark-not-implemented 'acquire-lock :timeout) 54 | (defun %acquire-lock (lock waitp timeout) 55 | (when timeout 56 | (signal-not-implemented 'acquire-lock :timeout)) 57 | (mp:get-lock lock waitp)) 58 | 59 | (defun %release-lock (lock) 60 | (mp:giveup-lock lock)) 61 | 62 | (mark-not-implemented 'with-lock-held :timeout) 63 | (defmacro %with-lock ((place timeout) &body body) 64 | (if timeout 65 | `(signal-not-implemented 'with-lock-held :timeout) 66 | `(mp:with-lock (,place) ,@body))) 67 | 68 | ;;; 69 | ;;; Recursive locks 70 | ;;; 71 | 72 | (deftype native-recursive-lock () 73 | '(and mp:mutex (satisfies mp:recursive-lock-p))) 74 | 75 | (defun %make-recursive-lock (name) 76 | (mp:make-recursive-mutex name)) 77 | 78 | (mark-not-implemented 'acquire-recursive-lock :timeout) 79 | (defun %acquire-recursive-lock (lock waitp timeout) 80 | (when timeout 81 | (signal-not-implemented 'acquire-recursive-lock :timeout)) 82 | (mp:get-lock lock waitp)) 83 | 84 | (defun %release-recursive-lock (lock) 85 | (mp:giveup-lock lock)) 86 | 87 | (mark-not-implemented 'with-recursive-lock-held :timeout) 88 | (defmacro %with-recursive-lock ((place timeout) &body body) 89 | (if timeout 90 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 91 | `(mp:with-lock (,place) ,@body))) 92 | 93 | 94 | ;;; 95 | ;;; Condition variables 96 | ;;; 97 | 98 | (deftype condition-variable () 99 | 'mp:condition-variable) 100 | 101 | (defun %make-condition-variable (name) 102 | (declare (ignore name)) 103 | (mp:make-condition-variable)) 104 | 105 | (defun %condition-wait (cv lock timeout) 106 | (if timeout 107 | (mp:condition-variable-timedwait cv lock timeout) 108 | (mp:condition-variable-wait cv lock))) 109 | 110 | (defun %condition-notify (cv) 111 | (mp:condition-variable-signal cv)) 112 | 113 | (defun %condition-broadcast (cv) 114 | (mp:condition-variable-broadcast cv)) 115 | -------------------------------------------------------------------------------- /apiv2/impl-mkcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'mt:thread) 11 | 12 | (defun %make-thread (function name) 13 | (mt:thread-run-function name function)) 14 | 15 | (defun %current-thread () 16 | mt::*thread*) 17 | 18 | (defun %thread-name (thread) 19 | (mt:thread-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (mt:thread-join thread)) 23 | 24 | (defun %thread-yield () 25 | (mt:thread-yield)) 26 | 27 | ;;; 28 | ;;; Introspection/debugging 29 | ;;; 30 | 31 | (defun %all-threads () 32 | (mt:all-threads)) 33 | 34 | (defun %interrupt-thread (thread function) 35 | (mt:interrupt-thread thread function)) 36 | 37 | (defun %destroy-thread (thread) 38 | (mt:thread-kill thread)) 39 | 40 | (defun %thread-alive-p (thread) 41 | (mt:thread-active-p thread)) 42 | 43 | 44 | ;;; 45 | ;;; Non-recursive locks 46 | ;;; 47 | 48 | (deftype native-lock () 'mp:lock) 49 | 50 | (defun %make-lock (name) 51 | (mp:make-lock :name name)) 52 | 53 | (mark-not-implemented 'acquire-lock :timeout) 54 | (defun %acquire-lock (lock waitp timeout) 55 | (when timeout 56 | (signal-not-implemented 'acquire-lock :timeout)) 57 | (mp:get-lock lock waitp)) 58 | 59 | (defun %release-lock (lock) 60 | (mp:giveup-lock lock)) 61 | 62 | (mark-not-implemented 'with-lock-held :timeout) 63 | (defmacro %with-lock ((place timeout) &body body) 64 | (if timeout 65 | `(signal-not-implemented 'with-lock-held :timeout) 66 | `(mp:with-lock (,place) ,@body))) 67 | 68 | ;;; 69 | ;;; Recursive locks 70 | ;;; 71 | 72 | (deftype native-recursive-lock () 73 | '(and mp:lock (satisfies mp:recursive-lock-p))) 74 | 75 | (defun %make-recursive-lock (name) 76 | (mp:make-lock :name name :recursive t)) 77 | 78 | (mark-not-implemented 'acquire-recursive-lock :timeout) 79 | (defun %acquire-recursive-lock (lock waitp timeout) 80 | (when timeout 81 | (signal-not-implemented 'acquire-recursive-lock :timeout)) 82 | (mp:get-lock lock waitp)) 83 | 84 | (defun %release-recursive-lock (lock) 85 | (mp:giveup-lock lock)) 86 | 87 | (mark-not-implemented 'with-recursive-lock-held :timeout) 88 | (defmacro %with-recursive-lock ((place timeout) &body body) 89 | (if timeout 90 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 91 | `(mp:with-lock (,place) ,@body))) 92 | 93 | 94 | ;;; 95 | ;;; Condition variables 96 | ;;; 97 | 98 | (deftype condition-variable () 99 | 'mt:condition-variable) 100 | 101 | (defun %make-condition-variable (name) 102 | (declare (ignore name)) 103 | (mt:make-condition-variable)) 104 | 105 | (mark-not-implemented 'condition-wait :timeout) 106 | (defun %condition-wait (cv lock timeout) 107 | (when timeout 108 | (signal-not-implemented 'condition-wait :timeout)) 109 | (mt:condition-wait cv lock) 110 | t) 111 | 112 | (defun %condition-notify (cv) 113 | (mt:condition-signal cv)) 114 | 115 | (defun %condition-broadcast (cv) 116 | (mt:condition-broadcast cv)) 117 | -------------------------------------------------------------------------------- /apiv1/impl-mkcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | Copyright 2010 Jean-Claude Beaudoin. 6 | 7 | Distributed under the MIT license (see LICENSE file) 8 | |# 9 | 10 | (in-package #:bordeaux-threads) 11 | 12 | (deftype thread () 13 | 'mt:thread) 14 | 15 | ;;; Thread Creation 16 | 17 | (defun %make-thread (function name) 18 | (mt:thread-run-function name function)) 19 | 20 | (defun current-thread () 21 | mt::*thread*) 22 | 23 | (defun threadp (object) 24 | (typep object 'mt:thread)) 25 | 26 | (defun thread-name (thread) 27 | (mt:thread-name thread)) 28 | 29 | ;;; Resource contention: locks and recursive locks 30 | 31 | (deftype lock () 'mt:lock) 32 | 33 | (deftype recursive-lock () 34 | '(and mt:lock (satisfies mt:recursive-lock-p))) 35 | 36 | (defun lock-p (object) 37 | (typep object 'mt:lock)) 38 | 39 | (defun recursive-lock-p (object) 40 | (and (typep object 'mt:lock) 41 | (mt:recursive-lock-p object))) 42 | 43 | (defun make-lock (&optional name) 44 | (mt:make-lock :name (or name "Anonymous lock"))) 45 | 46 | (defun acquire-lock (lock &optional (wait-p t)) 47 | (mt:get-lock lock wait-p)) 48 | 49 | (defun release-lock (lock) 50 | (mt:giveup-lock lock)) 51 | 52 | (defmacro with-lock-held ((place) &body body) 53 | `(mt:with-lock (,place) ,@body)) 54 | 55 | (defun make-recursive-lock (&optional name) 56 | (mt:make-lock :name (or name "Anonymous recursive lock") :recursive t)) 57 | 58 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 59 | (mt:get-lock lock wait-p)) 60 | 61 | (defun release-recursive-lock (lock) 62 | (mt:giveup-lock lock)) 63 | 64 | (defmacro with-recursive-lock-held ((place) &body body) 65 | `(mt:with-lock (,place) ,@body)) 66 | 67 | ;;; Resource contention: condition variables 68 | 69 | (defun make-condition-variable (&key name) 70 | (declare (ignore name)) 71 | (mt:make-condition-variable)) 72 | 73 | (defun condition-wait (condition-variable lock &key timeout) 74 | (signal-error-if-condition-wait-timeout timeout) 75 | (mt:condition-wait condition-variable lock) 76 | t) 77 | 78 | (define-condition-wait-compiler-macro) 79 | 80 | (defun condition-notify (condition-variable) 81 | (mt:condition-signal condition-variable)) 82 | 83 | (defun thread-yield () 84 | (mt:thread-yield)) 85 | 86 | ;;; Introspection/debugging 87 | 88 | (defun all-threads () 89 | (mt:all-threads)) 90 | 91 | (defun interrupt-thread (thread function &rest args) 92 | (flet ((apply-function () 93 | (if args 94 | (named-lambda %interrupt-thread-wrapper () 95 | (apply function args)) 96 | function))) 97 | (declare (dynamic-extent #'apply-function)) 98 | (mt:interrupt-thread thread (apply-function)))) 99 | 100 | (defun destroy-thread (thread) 101 | (signal-error-if-current-thread thread) 102 | (mt:thread-kill thread)) 103 | 104 | (defun thread-alive-p (thread) 105 | (mt:thread-active-p thread)) 106 | 107 | (defun join-thread (thread) 108 | (mt:thread-join thread)) 109 | 110 | (mark-supported) 111 | -------------------------------------------------------------------------------- /apiv2/impl-lispworks.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | #+(or lispworks4 lispworks5) 6 | (error 'bordeaux-threads-error 7 | :message "Threading not supported") 8 | 9 | ;;; 10 | ;;; Threads 11 | ;;; 12 | 13 | (deftype native-thread () 14 | 'mp:process) 15 | 16 | (defun %start-multiprocessing () 17 | (mp:initialize-multiprocessing)) 18 | 19 | (defun %make-thread (function name) 20 | (mp:process-run-function name nil function)) 21 | 22 | (defun %current-thread () 23 | (mp:get-current-process)) 24 | 25 | (defun %thread-name (thread) 26 | (mp:process-name thread)) 27 | 28 | (defun %join-thread (thread) 29 | (mp:process-join thread)) 30 | 31 | (defun %thread-yield () 32 | (mp:process-allow-scheduling)) 33 | 34 | ;;; 35 | ;;; Introspection/debugging 36 | ;;; 37 | 38 | (defun %all-threads () 39 | (mp:list-all-processes)) 40 | 41 | (defun %interrupt-thread (thread function) 42 | (mp:process-interrupt thread function)) 43 | 44 | (defun %destroy-thread (thread) 45 | (mp:process-kill thread)) 46 | 47 | (defun %thread-alive-p (thread) 48 | (mp:process-alive-p thread)) 49 | 50 | 51 | ;;; 52 | ;;; Non-recursive locks 53 | ;;; 54 | 55 | (deftype native-lock () 'mp:lock) 56 | 57 | (defun %make-lock (name) 58 | (mp:make-lock :name name :recursivep nil)) 59 | 60 | (defun %acquire-lock (lock waitp timeout) 61 | (mp:process-lock lock "Lock" (if waitp timeout 0))) 62 | 63 | (defun %release-lock (lock) 64 | (mp:process-unlock lock)) 65 | 66 | (defmacro %with-lock ((place timeout) &body body) 67 | `(mp:with-lock (,place nil ,timeout) ,@body)) 68 | 69 | ;;; 70 | ;;; Recursive locks 71 | ;;; 72 | 73 | (deftype native-recursive-lock () 74 | '(and mp:lock (satisfies mp:lock-recursive-p))) 75 | 76 | (defun %make-recursive-lock (name) 77 | (mp:make-lock :name name :recursivep t)) 78 | 79 | (defun %acquire-recursive-lock (lock waitp timeout) 80 | (%acquire-lock lock waitp timeout)) 81 | 82 | (defun %release-recursive-lock (lock) 83 | (%release-lock lock)) 84 | 85 | (defmacro %with-recursive-lock ((place timeout) &body body) 86 | `(mp:with-lock (,place nil ,timeout) ,@body)) 87 | 88 | 89 | ;;; 90 | ;;; Semaphores 91 | ;;; 92 | 93 | (deftype semaphore () 94 | 'mp:semaphore) 95 | 96 | (defun %make-semaphore (name count) 97 | (mp:make-semaphore :name name :count count)) 98 | 99 | (defun %signal-semaphore (semaphore count) 100 | (mp:semaphore-release semaphore :count count)) 101 | 102 | (defun %wait-on-semaphore (semaphore timeout) 103 | (if (mp:semaphore-acquire semaphore :timeout timeout :count 1) 104 | t nil)) 105 | 106 | 107 | ;;; 108 | ;;; Condition variables 109 | ;;; 110 | 111 | (deftype condition-variable () 112 | 'mp:condition-variable) 113 | 114 | (defun %make-condition-variable (name) 115 | (mp:make-condition-variable :name name)) 116 | 117 | (defun %condition-wait (cv lock timeout) 118 | (mp:condition-variable-wait cv lock :timeout timeout)) 119 | 120 | (defun %condition-notify (cv) 121 | (mp:condition-variable-signal cv)) 122 | 123 | (defun %condition-broadcast (cv) 124 | (mp:condition-variable-broadcast cv)) 125 | -------------------------------------------------------------------------------- /apiv1/impl-scl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2008 Scieneer Pty Ltd 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | (deftype thread () 12 | 'thread:thread) 13 | 14 | (defun %make-thread (function name) 15 | (thread:thread-create function :name name)) 16 | 17 | (defun current-thread () 18 | thread:*thread*) 19 | 20 | (defun threadp (object) 21 | (typep object 'thread:thread)) 22 | 23 | (defun thread-name (thread) 24 | (thread:thread-name thread)) 25 | 26 | ;;; Resource contention: locks and recursive locks 27 | 28 | (deftype lock () 'thread:lock) 29 | 30 | (deftype recursive-lock () 'thread:recursive-lock) 31 | 32 | (defun lock-p (object) 33 | (typep object 'thread:lock)) 34 | 35 | (defun recursive-lock-p (object) 36 | (typep object 'thread:recursive-lock)) 37 | 38 | (defun make-lock (&optional name) 39 | (thread:make-lock (or name "Anonymous lock"))) 40 | 41 | (defun acquire-lock (lock &optional (wait-p t)) 42 | (thread::acquire-lock lock nil wait-p)) 43 | 44 | (defun release-lock (lock) 45 | (thread::release-lock lock)) 46 | 47 | (defmacro with-lock-held ((place) &body body) 48 | `(thread:with-lock-held (,place) ,@body)) 49 | 50 | (defun make-recursive-lock (&optional name) 51 | (thread:make-lock (or name "Anonymous recursive lock") 52 | :type :recursive)) 53 | 54 | ;;; XXX acquire-recursive-lock and release-recursive-lock are actually 55 | ;;; complicated because we can't use control stack tricks. We need to 56 | ;;; actually count something to check that the acquire/releases are 57 | ;;; balanced 58 | 59 | (defmacro with-recursive-lock-held ((place) &body body) 60 | `(thread:with-lock-held (,place) 61 | ,@body)) 62 | 63 | ;;; Resource contention: condition variables 64 | 65 | (defun make-condition-variable (&key name) 66 | (thread:make-cond-var (or name "Anonymous condition variable"))) 67 | 68 | (defun condition-wait (condition-variable lock &key timeout) 69 | (if timeout 70 | (thread:cond-var-timedwait condition-variable lock timeout) 71 | (thread:cond-var-wait condition-variable lock)) 72 | t) 73 | 74 | (defun condition-notify (condition-variable) 75 | (thread:cond-var-broadcast condition-variable)) 76 | 77 | (defun thread-yield () 78 | (mp:process-yield)) 79 | 80 | ;;; Introspection/debugging 81 | 82 | (defun all-threads () 83 | (mp:all-processes)) 84 | 85 | (defun interrupt-thread (thread function &rest args) 86 | (flet ((apply-function () 87 | (if args 88 | (named-lambda %interrupt-thread-wrapper () 89 | (apply function args)) 90 | function))) 91 | (declare (dynamic-extent #'apply-function)) 92 | (thread:thread-interrupt thread (apply-function)))) 93 | 94 | (defun destroy-thread (thread) 95 | (thread:destroy-thread thread)) 96 | 97 | (defun thread-alive-p (thread) 98 | (mp:process-alive-p thread)) 99 | 100 | (defun join-thread (thread) 101 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 102 | (named-lambda %thread-completedp () 103 | (not (mp:process-alive-p thread))))) 104 | 105 | (mark-supported) 106 | -------------------------------------------------------------------------------- /apiv2/impl-scl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'thread:thread) 11 | 12 | (defun %make-thread (function name) 13 | (thread:thread-create function :name name)) 14 | 15 | (defun %current-thread () 16 | thread:*thread*) 17 | 18 | (defun %thread-name (thread) 19 | (thread:thread-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 23 | (named-lambda %thread-completed-p () 24 | (not (mp:process-alive-p thread))))) 25 | 26 | (defun %thread-yield () 27 | (mp:process-yield)) 28 | 29 | ;;; 30 | ;;; Introspection/debugging 31 | ;;; 32 | 33 | (defun %all-threads () 34 | (mp:all-processes)) 35 | 36 | (defun %interrupt-thread (thread function) 37 | (thread:thread-interrupt thread function)) 38 | 39 | (defun %destroy-thread (thread) 40 | (thread:destroy-thread thread)) 41 | 42 | (defun %thread-alive-p (thread) 43 | (mp:process-alive-p thread)) 44 | 45 | 46 | ;;; 47 | ;;; Non-recursive locks 48 | ;;; 49 | 50 | (deftype native-lock () 'thread:lock) 51 | 52 | (defun %make-lock (name) 53 | (thread:make-lock name)) 54 | 55 | (mark-not-implemented 'acquire-lock :timeout) 56 | (defun %acquire-lock (lock waitp timeout) 57 | (when timeout 58 | (signal-not-implemented 'acquire-lock :timeout)) 59 | (thread::acquire-lock lock nil wait-p)) 60 | 61 | (defun %release-lock (lock) 62 | (thread::release-lock lock)) 63 | 64 | (mark-not-implemented 'with-lock-held :timeout) 65 | (defmacro %with-lock ((place timeout) &body body) 66 | (if timeout 67 | `(signal-not-implemented 'with-lock-held :timeout) 68 | `(thread:with-lock-held (,place) ,@body))) 69 | 70 | ;;; 71 | ;;; Recursive locks 72 | ;;; 73 | 74 | (deftype native-recursive-lock () 'thread:recursive-lock) 75 | 76 | (defun %make-recursive-lock (name) 77 | (thread:make-lock name :type :recursive)) 78 | 79 | (mark-not-implemented 'acquire-recursive-lock) 80 | (defun %acquire-recursive-lock (lock waitp timeout) 81 | (declare (ignore lock waitp timeout)) 82 | (signal-not-implemented 'acquire-recursive-lock)) 83 | 84 | (mark-not-implemented 'release-recursive-lock) 85 | (defun %release-recursive-lock (lock) 86 | (declare (ignore lock)) 87 | (signal-not-implemented 'release-recursive-lock)) 88 | 89 | (mark-not-implemented 'with-recursive-lock-held :timeout) 90 | (defmacro %with-recursive-lock ((place timeout) &body body) 91 | (if timeout 92 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 93 | `(thread:with-lock-held (,place) 94 | ,@body))) 95 | 96 | 97 | ;;; 98 | ;;; Condition variables 99 | ;;; 100 | 101 | (deftype condition-variable () 102 | 'thread:cond-var) 103 | 104 | (defun %make-condition-variable (name) 105 | (thread:make-cond-var name)) 106 | 107 | (defun %condition-wait (cv lock timeout) 108 | (if timeout 109 | (thread:cond-var-timedwait cv lock timeout) 110 | (thread:cond-var-wait cv lock))) 111 | 112 | (defun %condition-notify (cv) 113 | (thread:cond-var-signal cv)) 114 | 115 | (defun %condition-broadcast (cv) 116 | (thread:cond-var-broadcast v)) 117 | -------------------------------------------------------------------------------- /apiv1/impl-clasp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; documentation on the ECL Multiprocessing interface can be found at 12 | ;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing 13 | 14 | (deftype thread () 15 | 'mp:process) 16 | 17 | ;;; Thread Creation 18 | 19 | (defun %make-thread (function name) 20 | (mp:process-run-function name function bordeaux-threads:*default-special-bindings*)) 21 | 22 | (defun current-thread () 23 | mp:*current-process*) 24 | 25 | (defun threadp (object) 26 | (typep object 'mp:process)) 27 | 28 | (defun thread-name (thread) 29 | (mp:process-name thread)) 30 | 31 | ;;; Resource contention: locks and recursive locks 32 | 33 | (deftype lock () 'mp:mutex) 34 | 35 | (deftype recursive-lock () 36 | '(and mp:mutex (satisfies mp:recursive-lock-p))) 37 | 38 | (defun lock-p (object) 39 | (typep object 'mp:mutex)) 40 | 41 | (defun recursive-lock-p (object) 42 | (and (typep object 'mp:mutex) 43 | (mp:recursive-lock-p object))) 44 | 45 | (defun make-lock (&optional name) 46 | (mp:make-lock :name (or name :anonymous))) 47 | 48 | (defun acquire-lock (lock &optional (wait-p t)) 49 | (mp:get-lock lock wait-p)) 50 | 51 | (defun release-lock (lock) 52 | (mp:giveup-lock lock)) 53 | 54 | 55 | (defmacro with-lock-held ((place) &body body) 56 | `(mp:with-lock (,place) ,@body)) 57 | 58 | (defun make-recursive-lock (&optional name) 59 | (mp:make-recursive-mutex (or name :anonymous-recursive-lock))) 60 | 61 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 62 | (mp:get-lock lock wait-p)) 63 | 64 | (defun release-recursive-lock (lock) 65 | (mp:giveup-lock lock)) 66 | 67 | (defmacro with-recursive-lock-held ((place) &body body) 68 | `(mp:with-lock (,place) ,@body)) 69 | 70 | ;;; Resource contention: condition variables 71 | 72 | (defun make-condition-variable (&key name) 73 | (declare (ignore name)) 74 | (mp:make-condition-variable)) 75 | 76 | (defun condition-wait (condition-variable lock &key timeout) 77 | (if timeout 78 | (mp:condition-variable-timedwait condition-variable lock timeout) 79 | (mp:condition-variable-wait condition-variable lock)) 80 | t) 81 | 82 | (defun condition-notify (condition-variable) 83 | (mp:condition-variable-signal condition-variable)) 84 | 85 | (defun thread-yield () 86 | (mp:process-yield)) 87 | 88 | ;;; Introspection/debugging 89 | 90 | (defun all-threads () 91 | (mp:all-processes)) 92 | 93 | (defun interrupt-thread (thread function &rest args) 94 | (flet ((apply-function () 95 | (if args 96 | (named-lambda %interrupt-thread-wrapper () 97 | (apply function args)) 98 | function))) 99 | (declare (dynamic-extent #'apply-function)) 100 | (mp:interrupt-process thread (apply-function)))) 101 | 102 | (defun destroy-thread (thread) 103 | (signal-error-if-current-thread thread) 104 | (mp:process-kill thread)) 105 | 106 | (defun thread-alive-p (thread) 107 | (mp:process-active-p thread)) 108 | 109 | (defun join-thread (thread) 110 | (mp:process-join thread)) 111 | 112 | (mark-supported) 113 | -------------------------------------------------------------------------------- /apiv1/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (cl:defpackage :bordeaux-threads 5 | (:nicknames #:bt) 6 | (:use #:cl #:alexandria) 7 | #+abcl 8 | (:import-from :java #:jnew #:jcall #:jmethod) 9 | (:export #:thread #:make-thread #:current-thread #:threadp #:thread-name 10 | #:start-multiprocessing 11 | #:*default-special-bindings* #:*standard-io-bindings* 12 | #:*supports-threads-p* 13 | 14 | #:lock #:make-lock #:lock-p 15 | #:acquire-lock #:release-lock #:with-lock-held 16 | 17 | #:recursive-lock #:make-recursive-lock #:recursive-lock-p 18 | #:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held 19 | 20 | #:make-condition-variable #:condition-wait #:condition-notify 21 | 22 | #:make-semaphore #:signal-semaphore #:wait-on-semaphore #:semaphore #:semaphore-p 23 | 24 | #:with-timeout #:timeout 25 | 26 | #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p 27 | #:join-thread #:thread-yield) 28 | (:documentation "BORDEAUX-THREADS is a proposed standard for a minimal 29 | MP/threading interface. It is similar to the CLIM-SYS threading and 30 | lock support, but for the following broad differences: 31 | 32 | 1) Some behaviours are defined in additional detail: attention has 33 | been given to special variable interaction, whether and when 34 | cleanup forms are run. Some behaviours are defined in less 35 | detail: an implementation that does not support multiple 36 | threads is not required to use a new list (nil) for a lock, for 37 | example. 38 | 39 | 2) Many functions which would be difficult, dangerous or inefficient 40 | to provide on some implementations have been removed. Chiefly 41 | these are functions such as thread-wait which expect for 42 | efficiency that the thread scheduler is written in Lisp and 43 | 'hookable', which can't sensibly be done if the scheduler is 44 | external to the Lisp image, or the system has more than one CPU. 45 | 46 | 3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been 47 | added. 48 | 49 | 4) Posix-style condition variables have been added, as it's not 50 | otherwise possible to implement them correctly using the other 51 | operations that are specified. 52 | 53 | Threads may be implemented using whatever applicable techniques are 54 | provided by the operating system: user-space scheduling, 55 | kernel-based LWPs or anything else that does the job. 56 | 57 | Some parts of this specification can also be implemented in a Lisp 58 | that does not support multiple threads. Thread creation and some 59 | thread inspection operations will not work, but the locking 60 | functions are still present (though they may do nothing) so that 61 | thread-safe code can be compiled on both multithread and 62 | single-thread implementations without need of conditionals. 63 | 64 | To avoid conflict with existing MP/threading interfaces in 65 | implementations, these symbols live in the BORDEAUX-THREADS package. 66 | Implementations and/or users may also make them visible or exported 67 | in other more traditionally named packages.")) 68 | -------------------------------------------------------------------------------- /apiv2/impl-clisp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'mt:thread) 11 | 12 | (defun %make-thread (function name) 13 | (mt:make-thread function :name name)) 14 | 15 | (defun %current-thread () 16 | (mt:current-thread)) 17 | 18 | (defun %thread-name (thread) 19 | (mt:thread-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (mt:thread-join thread)) 23 | 24 | (defun %thread-yield () 25 | (mt:thread-yield)) 26 | 27 | ;;; 28 | ;;; Introspection/debugging 29 | ;;; 30 | 31 | ;;; VTZ: mt:list-threads returns all threads that are not garbage collected. 32 | (defun %all-threads () 33 | (delete-if-not #'mt:thread-active-p (mt:list-threads))) 34 | 35 | (defun %interrupt-thread (thread function) 36 | (mt:thread-interrupt thread :function function)) 37 | 38 | (defun %destroy-thread (thread) 39 | (mt:thread-interrupt thread :function t)) 40 | 41 | (defun %thread-alive-p (thread) 42 | (mt:thread-active-p thread)) 43 | 44 | 45 | ;;; 46 | ;;; Non-recursive locks 47 | ;;; 48 | 49 | (deftype native-lock () 50 | 'mt:mutex) 51 | 52 | (defun %make-lock (name) 53 | (mt:make-mutex :name name)) 54 | 55 | (mark-not-implemented 'acquire-lock :timeout) 56 | (defun %acquire-lock (lock waitp timeout) 57 | (when timeout 58 | (signal-not-implemented 'acquire-lock :timeout)) 59 | (mt:mutex-lock lock :timeout (if waitp nil 0))) 60 | 61 | (defun %release-lock (lock) 62 | (mt:mutex-unlock lock)) 63 | 64 | (mark-not-implemented 'with-lock-held :timeout) 65 | (defmacro %with-lock ((place timeout) &body body) 66 | (if timeout 67 | `(signal-not-implemented 'with-lock-held :timeout) 68 | `(mt:with-mutex-lock (,place) ,@body))) 69 | 70 | ;;; 71 | ;;; Recursive locks 72 | ;;; 73 | 74 | (deftype native-recursive-lock () 75 | '(and mt:mutex (satisfies mt:mutex-recursive-p))) 76 | 77 | (defun %make-recursive-lock (name) 78 | (mt:make-mutex :name name :recursive-p t)) 79 | 80 | (mark-not-implemented 'acquire-recursive-lock :timeout) 81 | (defun %acquire-recursive-lock (lock waitp timeout) 82 | (when timeout 83 | (signal-not-implemented 'acquire-recursive-lock :timeout)) 84 | (%acquire-lock lock waitp nil)) 85 | 86 | (defun %release-recursive-lock (lock) 87 | (%release-lock lock)) 88 | 89 | (mark-not-implemented 'with-recursive-lock-held :timeout) 90 | (defmacro %with-recursive-lock ((place timeout) &body body) 91 | (if timeout 92 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 93 | `(mt:with-mutex-lock (,place) ,@body))) 94 | 95 | 96 | ;;; 97 | ;;; Condition variables 98 | ;;; 99 | 100 | (deftype condition-variable () 101 | 'mt:exemption) 102 | 103 | (defun %make-condition-variable (name) 104 | (mt:make-exemption :name name)) 105 | 106 | (defun %condition-wait (cv lock timeout) 107 | (mt:exemption-wait cv lock :timeout timeout)) 108 | 109 | (defun %condition-notify (cv) 110 | (mt:exemption-signal cv)) 111 | 112 | (defun %condition-broadcast (cv) 113 | (mt:exemption-broadcast cv)) 114 | 115 | 116 | ;;; 117 | ;;; Timeouts 118 | ;;; 119 | 120 | (defmacro with-timeout ((timeout) &body body) 121 | (once-only (timeout) 122 | `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) 123 | ,@body))) 124 | -------------------------------------------------------------------------------- /apiv1/impl-clisp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | (deftype thread () 12 | 'mt:thread) 13 | 14 | ;;; Thread Creation 15 | (defun %make-thread (function name) 16 | (mt:make-thread function 17 | :name name 18 | :initial-bindings mt:*default-special-bindings*)) 19 | 20 | (defun current-thread () 21 | (mt:current-thread)) 22 | 23 | (defun threadp (object) 24 | (mt:threadp object)) 25 | 26 | (defun thread-name (thread) 27 | (mt:thread-name thread)) 28 | 29 | ;;; Resource contention: locks and recursive locks 30 | 31 | (deftype lock () 'mt:mutex) 32 | 33 | (deftype recursive-lock () 34 | '(and mt:mutex (satisfies mt:mutex-recursive-p))) 35 | 36 | (defun lock-p (object) 37 | (typep object 'mt:mutex)) 38 | 39 | (defun recursive-lock-p (object) 40 | (and (typep object 'mt:mutex) 41 | (mt:mutex-recursive-p object))) 42 | 43 | (defun make-lock (&optional name) 44 | (mt:make-mutex :name (or name "Anonymous lock"))) 45 | 46 | (defun acquire-lock (lock &optional (wait-p t)) 47 | (mt:mutex-lock lock :timeout (if wait-p nil 0))) 48 | 49 | (defun release-lock (lock) 50 | (mt:mutex-unlock lock)) 51 | 52 | (defmacro with-lock-held ((place) &body body) 53 | `(mt:with-mutex-lock (,place) ,@body)) 54 | 55 | (defun make-recursive-lock (&optional name) 56 | (mt:make-mutex :name (or name "Anonymous recursive lock") 57 | :recursive-p t)) 58 | 59 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 60 | (acquire-lock lock wait-p)) 61 | 62 | (defun release-recursive-lock (lock) 63 | (release-lock lock)) 64 | 65 | (defmacro with-recursive-lock-held ((place) &body body) 66 | `(mt:with-mutex-lock (,place) ,@body)) 67 | 68 | ;;; Resource contention: condition variables 69 | 70 | (defun make-condition-variable (&key name) 71 | (mt:make-exemption :name (or name "Anonymous condition variable"))) 72 | 73 | (defun condition-wait (condition-variable lock &key timeout) 74 | (mt:exemption-wait condition-variable lock :timeout timeout) 75 | t) 76 | 77 | (defun condition-notify (condition-variable) 78 | (mt:exemption-signal condition-variable)) 79 | 80 | (defun thread-yield () 81 | (mt:thread-yield)) 82 | 83 | ;;; Timeouts 84 | 85 | (defmacro with-timeout ((timeout) &body body) 86 | (once-only (timeout) 87 | `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) 88 | ,@body))) 89 | 90 | ;;; Introspection/debugging 91 | 92 | ;;; VTZ: mt:list-threads returns all threads that are not garbage collected. 93 | (defun all-threads () 94 | (delete-if-not #'mt:thread-active-p (mt:list-threads))) 95 | 96 | (defun interrupt-thread (thread function &rest args) 97 | (mt:thread-interrupt thread :function function :arguments args)) 98 | 99 | (defun destroy-thread (thread) 100 | ;;; VTZ: actually we can kill ourselelf. 101 | ;;; suicide is part of our contemporary life :) 102 | (signal-error-if-current-thread thread) 103 | (mt:thread-interrupt thread :function t)) 104 | 105 | (defun thread-alive-p (thread) 106 | (mt:thread-active-p thread)) 107 | 108 | (defun join-thread (thread) 109 | (values-list (mt:thread-join thread))) 110 | 111 | (mark-supported) 112 | -------------------------------------------------------------------------------- /apiv2/api-semaphores.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2) 5 | 6 | #-(or abcl allegro ccl ecl lispworks mezzano sbcl) 7 | (defstruct (%semaphore 8 | (:constructor %make-semaphore (name counter))) 9 | name counter 10 | (lock (make-lock)) 11 | (condition-variable (%make-condition-variable nil))) 12 | 13 | #-(or abcl allegro ccl ecl lispworks mezzano sbcl) 14 | (deftype semaphore () '%semaphore) 15 | 16 | (defun make-semaphore (&key name (count 0)) 17 | "Create a semaphore with the supplied NAME and initial counter value COUNT." 18 | (check-type name (or null string)) 19 | (%make-semaphore name count)) 20 | 21 | #-(or abcl allegro ccl ecl lispworks mezzano sbcl) 22 | (defun %signal-semaphore (semaphore count) 23 | (with-lock-held ((%semaphore-lock semaphore)) 24 | (incf (%semaphore-counter semaphore) count) 25 | (dotimes (v count) 26 | (%condition-notify (%semaphore-condition-variable semaphore))))) 27 | 28 | (defun signal-semaphore (semaphore &key (count 1)) 29 | "Increment SEMAPHORE by COUNT. If there are threads waiting on this 30 | semaphore, then COUNT of them are woken up." 31 | (%signal-semaphore semaphore count) 32 | t) 33 | 34 | #-(or abcl allegro ccl ecl lispworks mezzano sbcl) 35 | (defun %wait-on-semaphore (semaphore timeout) 36 | (with-lock-held ((%semaphore-lock semaphore)) 37 | (if (plusp (%semaphore-counter semaphore)) 38 | (decf (%semaphore-counter semaphore)) 39 | (let ((deadline (when timeout 40 | (+ (get-internal-real-time) 41 | (* timeout internal-time-units-per-second))))) 42 | ;; we need this loop because of a spurious wakeup possibility 43 | (loop until (plusp (%semaphore-counter semaphore)) 44 | do (cond 45 | ((null (%condition-wait 46 | (%semaphore-condition-variable semaphore) 47 | (lock-native-lock (%semaphore-lock semaphore)) 48 | timeout)) 49 | (return-from %wait-on-semaphore)) 50 | ;; unfortunately cv-wait may return T on timeout too 51 | ((and deadline (>= (get-internal-real-time) deadline)) 52 | (return-from %wait-on-semaphore)) 53 | (timeout 54 | (setf timeout (/ (- deadline (get-internal-real-time)) 55 | internal-time-units-per-second))))) 56 | (decf (%semaphore-counter semaphore)))) 57 | ;; Semaphore acquired. 58 | t)) 59 | 60 | #+cmu (mark-not-implemented 'wait-on-semaphore :timeout) 61 | (defun wait-on-semaphore (semaphore &key timeout) 62 | "Decrement the count of SEMAPHORE by 1 if the count is larger than zero. 63 | 64 | If count is zero, blocks until the semaphore can be decremented. 65 | Returns generalized boolean T on success. 66 | 67 | If TIMEOUT is given, it is the maximum number of seconds to wait. If the count 68 | cannot be decremented in that time, returns NIL without decrementing the count." 69 | (%wait-on-semaphore semaphore timeout)) 70 | 71 | (defun semaphorep (object) 72 | "Returns T if OBJECT is a semaphore, otherwise NIL." 73 | (typep object 'semaphore)) 74 | -------------------------------------------------------------------------------- /apiv2/bordeaux-threads.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2) 5 | 6 | (defconstant +supports-threads-p+ 7 | #+thread-support t 8 | #-thread-support nil 9 | "This should be set to T if the running instance has thread support.") 10 | 11 | #+thread-support 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (pushnew :bordeaux-threads *features*)) 14 | 15 | (defun bool (thing) (if thing t nil)) 16 | 17 | (define-condition bordeaux-threads-error (error) ()) 18 | 19 | (define-condition abnormal-exit (bordeaux-threads-error) 20 | ((exit-condition :initarg :condition 21 | :reader abnormal-exit-condition)) 22 | (:report (lambda (condition stream) 23 | (format stream "Thread exited with condition: ~A" 24 | (abnormal-exit-condition condition))))) 25 | 26 | (define-condition bordeaux-threads-simple-error 27 | (simple-error bordeaux-threads-error) 28 | ()) 29 | 30 | (defun bt-error (msg &rest args) 31 | (error 'bordeaux-threads-simple-error 32 | :format-control msg 33 | :format-arguments args)) 34 | 35 | (define-condition not-implemented (bordeaux-threads-error) 36 | ()) 37 | 38 | (define-condition operation-not-implemented (not-implemented) 39 | ((operation :initarg :operation :reader operation-not-implemented-operation)) 40 | (:report (lambda (condition stream) 41 | (format stream "Operation not implemented: ~A" 42 | (operation-not-implemented-operation condition))))) 43 | 44 | (define-condition keyarg-not-implemented (not-implemented) 45 | ((operation :initarg :operation :reader keyarg-not-implemented-operation) 46 | (keyarg :initarg :keyarg :reader keyarg-not-implemented-keyarg)) 47 | (:report (lambda (condition stream) 48 | (format stream "~A does not implement argument ~S" 49 | (keyarg-not-implemented-operation condition) 50 | (keyarg-not-implemented-keyarg condition))))) 51 | 52 | (defun signal-not-implemented (op &optional keyarg) 53 | (if keyarg 54 | (error 'keyarg-not-implemented :operation op :keyarg keyarg) 55 | (error 'operation-not-implemented :operation op))) 56 | 57 | (defparameter *missing-functions* 58 | (make-hash-table :test #'eql)) 59 | 60 | (defparameter *missing-features* 61 | (make-hash-table :test #'equal)) 62 | 63 | (defun mark-not-implemented (op &rest features) 64 | (if (null features) 65 | (setf (gethash op *missing-functions*) t) 66 | (dolist (f features) 67 | (setf (gethash (cons op f) *missing-features*) t)))) 68 | 69 | (defun implemented-p (op &optional feature) 70 | (cond 71 | ((null feature) 72 | (not (gethash op *missing-functions*))) 73 | ((gethash op *missing-functions*) 74 | nil) 75 | (t 76 | (not (gethash (cons op feature) *missing-features*))))) 77 | 78 | (defun implemented-p* (op &optional feature) 79 | (if (implemented-p op feature) 80 | '(:and) 81 | '(:or))) 82 | 83 | #-sbcl 84 | (define-condition timeout (serious-condition) 85 | ((length :initform nil 86 | :initarg :length 87 | :reader timeout-length)) 88 | (:report (lambda (c s) 89 | (if (timeout-length c) 90 | (format s "A timeout set to ~A seconds occurred." 91 | (timeout-length c)) 92 | (format s "A timeout occurred."))))) 93 | -------------------------------------------------------------------------------- /docs/content/threads/make-thread.md: -------------------------------------------------------------------------------- 1 | --- 2 | date: 2022-01-07T08:00:00Z 3 | title: 'Function: MAKE-THREAD' 4 | weight: 4 5 | --- 6 | 7 | #### Syntax: 8 | 9 | **make-thread** function *&key* name initial-bindings trap-conditions => thread 10 | 11 | #### Arguments and values: 12 | 13 | *function* -> a [function 14 | designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator).\ 15 | *name* -> a 16 | [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string) 17 | or 18 | [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil).\ 19 | *initial-bindings* -> an alist mapping special variable names to 20 | values. Defaults to [\*default-special-bindings\*](default-special-bindings).\ 21 | *trap-conditions* -> if 22 | [true](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true), 23 | wrap the thread function in a handler-case. 24 | 25 | #### Description: 26 | 27 | Creates and returns a thread named `name`, which will call the 28 | function `function` with no arguments: when `function` returns, the 29 | thread terminates. 30 | 31 | The interaction between threads and dynamic variables is in some cases 32 | complex, and depends on whether the variable has only a global binding 33 | (as established by 34 | 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 35 | [setq](http://www.lispworks.com/documentation/HyperSpec/Body/s_setq.htm)) 36 | or has been bound locally (e.g. with 37 | [let](http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm) 38 | or 39 | [let*](http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm)) 40 | in the calling thread. 41 | 42 | - Global bindings are shared between threads: the initial value of a 43 | global variable in the new thread will be the same as in the 44 | parent, and an assignment to such a variable in any thread will be 45 | visible to all threads in which the global binding is visible. 46 | 47 | - Local bindings, such as the ones introduced by `initial-bindings`, 48 | are local to the thread they are introduced in, except that 49 | 50 | - Local bindings in the the caller of [make-thread](.) may or may not 51 | be shared with the new thread that it creates: this is 52 | implementation-defined. Portable code should not depend on 53 | particular behaviour in this case, nor should it assign to such 54 | variables without first rebinding them in the new thread. 55 | 56 | #### Exceptional situations: 57 | 58 | An error of 59 | [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) 60 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 61 | will be signaled if `function` is not a [function 62 | designator](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator).\ 63 | An error of 64 | [type](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#type) 65 | [**type-error**](http://www.lispworks.com/documentation/HyperSpec/Body/e_tp_err.htm#type-error) 66 | will be signaled if `name` is anything other than 67 | [nil](http://www.lispworks.com/documentation/HyperSpec/Body/a_nil.htm#nil) 68 | or a [string](http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string). 69 | 70 | #### Affected by: 71 | 72 | [**\*default-special-bindings\***](../default-special-bindings). 73 | 74 | #### See also: 75 | 76 | [**join-thread**](../join-thread) 77 | 78 | #### Notes: 79 | 80 | The threading model is implementation-dependent. 81 | -------------------------------------------------------------------------------- /apiv1/impl-clozure.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; documentation on the OpenMCL Threads interface can be found at 12 | ;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html 13 | 14 | (deftype thread () 15 | 'ccl:process) 16 | 17 | ;;; Thread Creation 18 | 19 | (defun %make-thread (function name) 20 | (ccl:process-run-function name function)) 21 | 22 | (defun current-thread () 23 | ccl:*current-process*) 24 | 25 | (defun threadp (object) 26 | (typep object 'ccl:process)) 27 | 28 | (defun thread-name (thread) 29 | (ccl:process-name thread)) 30 | 31 | ;;; Resource contention: locks and recursive locks 32 | 33 | (deftype lock () 'ccl:lock) 34 | 35 | (deftype recursive-lock () 'ccl:lock) 36 | 37 | (defun lock-p (object) 38 | (typep object 'ccl:lock)) 39 | 40 | (defun recursive-lock-p (object) 41 | (typep object 'ccl:lock)) 42 | 43 | (defun make-lock (&optional name) 44 | (ccl:make-lock (or name "Anonymous lock"))) 45 | 46 | (defun acquire-lock (lock &optional (wait-p t)) 47 | (if wait-p 48 | (ccl:grab-lock lock) 49 | (ccl:try-lock lock))) 50 | 51 | (defun release-lock (lock) 52 | (ccl:release-lock lock)) 53 | 54 | (defmacro with-lock-held ((place) &body body) 55 | `(ccl:with-lock-grabbed (,place) 56 | ,@body)) 57 | 58 | (defun make-recursive-lock (&optional name) 59 | (ccl:make-lock (or name "Anonymous recursive lock"))) 60 | 61 | (defun acquire-recursive-lock (lock) 62 | (ccl:grab-lock lock)) 63 | 64 | (defun release-recursive-lock (lock) 65 | (ccl:release-lock lock)) 66 | 67 | (defmacro with-recursive-lock-held ((place) &body body) 68 | `(ccl:with-lock-grabbed (,place) 69 | ,@body)) 70 | 71 | ;;; Resource contention: condition variables 72 | 73 | (defun make-condition-variable (&key name) 74 | (declare (ignore name)) 75 | (ccl:make-semaphore)) 76 | 77 | (defun condition-wait (condition-variable lock &key timeout) 78 | (release-lock lock) 79 | (unwind-protect 80 | (if timeout 81 | (ccl:timed-wait-on-semaphore condition-variable timeout) 82 | (ccl:wait-on-semaphore condition-variable)) 83 | (acquire-lock lock t)) 84 | t) 85 | 86 | (defun condition-notify (condition-variable) 87 | (ccl:signal-semaphore condition-variable)) 88 | 89 | (defun thread-yield () 90 | (ccl:process-allow-schedule)) 91 | 92 | ;;; Semaphores 93 | 94 | (deftype semaphore () 95 | 'ccl:semaphore) 96 | 97 | (defun make-semaphore (&key name (count 0)) 98 | (declare (ignore name)) 99 | (ccl:make-semaphore :count count)) 100 | 101 | (defun signal-semaphore (semaphore &key (count 1)) 102 | (dotimes (c count) (ccl:signal-semaphore semaphore))) 103 | 104 | (defun wait-on-semaphore (semaphore &key timeout) 105 | (if timeout 106 | (ccl:timed-wait-on-semaphore semaphore timeout) 107 | (ccl:wait-on-semaphore semaphore))) 108 | 109 | ;;; Introspection/debugging 110 | 111 | (defun all-threads () 112 | (ccl:all-processes)) 113 | 114 | (defun interrupt-thread (thread function &rest args) 115 | (declare (dynamic-extent args)) 116 | (apply #'ccl:process-interrupt thread function args)) 117 | 118 | (defun destroy-thread (thread) 119 | (signal-error-if-current-thread thread) 120 | (ccl:process-kill thread)) 121 | 122 | (defun thread-alive-p (thread) 123 | (not (ccl:process-exhausted-p thread))) 124 | 125 | (defun join-thread (thread) 126 | (ccl:join-process thread)) 127 | 128 | (mark-supported) 129 | -------------------------------------------------------------------------------- /apiv1/impl-ecl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | (eval-when (:compile-toplevel :execute) 12 | (when (>= ext:+ecl-version-number+ 230909) 13 | (pushnew :has-timeouts *features*))) 14 | 15 | ;;; documentation on the ECL Multiprocessing interface can be found at 16 | ;;; https://ecl.common-lisp.dev/static/manual/Native-threads.html 17 | 18 | (deftype thread () 19 | 'mp:process) 20 | 21 | ;;; Thread Creation 22 | 23 | (defun %make-thread (function name) 24 | (mp:process-run-function name function)) 25 | 26 | (defun current-thread () 27 | mp::*current-process*) 28 | 29 | (defun threadp (object) 30 | (typep object 'mp:process)) 31 | 32 | (defun thread-name (thread) 33 | (mp:process-name thread)) 34 | 35 | ;;; Resource contention: locks and recursive locks 36 | 37 | (deftype lock () 'mp:lock) 38 | 39 | (deftype recursive-lock () 40 | '(and mp:lock (satisfies mp:recursive-lock-p))) 41 | 42 | (defun lock-p (object) 43 | (typep object 'mp:lock)) 44 | 45 | (defun recursive-lock-p (object) 46 | (and (typep object 'mp:lock) 47 | (mp:recursive-lock-p object))) 48 | 49 | (defun make-lock (&optional name) 50 | (mp:make-lock :name (or name "Anonymous lock"))) 51 | 52 | (defun acquire-lock (lock &optional (wait-p t)) 53 | (mp:get-lock lock wait-p)) 54 | 55 | (defun release-lock (lock) 56 | (mp:giveup-lock lock)) 57 | 58 | (defmacro with-lock-held ((place) &body body) 59 | `(mp:with-lock (,place) ,@body)) 60 | 61 | (defun make-recursive-lock (&optional name) 62 | (mp:make-lock :name (or name "Anonymous recursive lock") :recursive t)) 63 | 64 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 65 | (mp:get-lock lock wait-p)) 66 | 67 | (defun release-recursive-lock (lock) 68 | (mp:giveup-lock lock)) 69 | 70 | (defmacro with-recursive-lock-held ((place) &body body) 71 | `(mp:with-lock (,place) ,@body)) 72 | 73 | ;;; Resource contention: condition variables 74 | 75 | (defun make-condition-variable (&key name) 76 | (declare (ignore name)) 77 | (mp:make-condition-variable)) 78 | 79 | (defun condition-wait (condition-variable lock &key timeout) 80 | (if timeout 81 | #-has-timeouts 82 | (handler-case 83 | (with-timeout (timeout) 84 | (mp:condition-variable-wait condition-variable lock)) 85 | (timeout () 86 | (acquire-lock lock) 87 | nil)) 88 | #+has-timeouts 89 | (mp:condition-variable-timedwait condition-variable lock timeout) 90 | (mp:condition-variable-wait condition-variable lock))) 91 | 92 | (defun condition-notify (condition-variable) 93 | (mp:condition-variable-signal condition-variable)) 94 | 95 | (defun thread-yield () 96 | (mp:process-yield)) 97 | 98 | ;;; Introspection/debugging 99 | 100 | (defun all-threads () 101 | (mp:all-processes)) 102 | 103 | (defun interrupt-thread (thread function &rest args) 104 | (flet ((apply-function () 105 | (if args 106 | (named-lambda %interrupt-thread-wrapper () 107 | (apply function args)) 108 | function))) 109 | (declare (dynamic-extent #'apply-function)) 110 | (mp:interrupt-process thread (apply-function)))) 111 | 112 | (defun destroy-thread (thread) 113 | (signal-error-if-current-thread thread) 114 | (mp:process-kill thread)) 115 | 116 | (defun thread-alive-p (thread) 117 | (mp:process-active-p thread)) 118 | 119 | (defun join-thread (thread) 120 | (mp:process-join thread)) 121 | 122 | (eval-when (:compile-toplevel :execute) 123 | (setf *features* (remove :has-timeouts *features*))) 124 | 125 | (mark-supported) 126 | -------------------------------------------------------------------------------- /apiv2/impl-clozure.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'ccl:process) 11 | 12 | (defun %make-thread (function name) 13 | (ccl:process-run-function name function)) 14 | 15 | (defun %current-thread () 16 | ccl:*current-process*) 17 | 18 | (defun %thread-name (thread) 19 | (ccl:process-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (ccl:join-process thread)) 23 | 24 | (defun %thread-yield () 25 | (ccl:process-allow-schedule)) 26 | 27 | ;;; 28 | ;;; Introspection/debugging 29 | ;;; 30 | 31 | (defun %all-threads () 32 | (ccl:all-processes)) 33 | 34 | (defun %interrupt-thread (thread function) 35 | (ccl:process-interrupt thread function)) 36 | 37 | (defun %destroy-thread (thread) 38 | (ccl:process-kill thread)) 39 | 40 | (defun %thread-alive-p (thread) 41 | (not (ccl:process-exhausted-p thread))) 42 | 43 | 44 | ;;; 45 | ;;; Non-recursive locks 46 | ;;; 47 | 48 | (deftype native-lock () 'ccl:lock) 49 | 50 | (defun %make-lock (name) 51 | (ccl:make-lock name)) 52 | 53 | (mark-not-implemented 'acquire-lock :timeout) 54 | (defun %acquire-lock (lock waitp timeout) 55 | (when timeout 56 | (signal-not-implemented 'acquire-lock :timeout)) 57 | ;; This is not guaranteed to work all the times, but that's OK. 58 | (when (eql (ccl::%%lock-owner lock) (%current-thread)) 59 | (bt-error "Attempted recursive acquisition of lock: ~A" lock)) 60 | (if waitp 61 | (ccl:grab-lock lock) 62 | (ccl:try-lock lock))) 63 | 64 | (defun %release-lock (lock) 65 | (ccl:release-lock lock)) 66 | 67 | (mark-not-implemented 'with-lock-held :timeout) 68 | (defmacro %with-lock ((place timeout) &body body) 69 | (declare (ignorable place timeout)) 70 | (if timeout 71 | `(signal-not-implemented 'with-lock-held :timeout) 72 | `(ccl:with-lock-grabbed (,place) 73 | ,@body))) 74 | 75 | ;;; 76 | ;;; Recursive locks 77 | ;;; 78 | 79 | (deftype native-recursive-lock () 'ccl:lock) 80 | 81 | (defun %make-recursive-lock (name) 82 | (ccl:make-lock name)) 83 | 84 | (mark-not-implemented 'acquire-recursive-lock :timeout) 85 | (defun %acquire-recursive-lock (lock waitp timeout) 86 | (when timeout 87 | (signal-not-implemented 'acquire-recursive-lock :timeout)) 88 | (if waitp 89 | (ccl:grab-lock lock) 90 | (ccl:try-lock lock))) 91 | 92 | (defun %release-recursive-lock (lock) 93 | (ccl:release-lock lock)) 94 | 95 | (mark-not-implemented 'with-recursive-lock-held :timeout) 96 | (defmacro %with-recursive-lock ((place timeout) &body body) 97 | (declare (ignorable place timeout)) 98 | (if timeout 99 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 100 | `(ccl:with-lock-grabbed (,place) 101 | ,@body))) 102 | 103 | 104 | ;;; 105 | ;;; Semaphores 106 | ;;; 107 | 108 | (deftype semaphore () 'ccl:semaphore) 109 | 110 | ;;; CCL:MAKE-SEMAPHORE had been extended to accept COUNT argument 111 | #+ccl-1.12 112 | (defun %make-semaphore (name count) 113 | (declare (ignore name)) 114 | (ccl:make-semaphore :count count)) 115 | 116 | #-ccl-1.12 117 | (defun %make-semaphore (name count) 118 | (declare (ignore name)) 119 | (let ((sem (ccl:make-semaphore))) 120 | (%signal-semaphore sem count) 121 | sem)) 122 | 123 | (defun %signal-semaphore (semaphore count) 124 | (dotimes (c count) (ccl:signal-semaphore semaphore))) 125 | 126 | (defun %wait-on-semaphore (semaphore timeout) 127 | (if timeout 128 | (ccl:timed-wait-on-semaphore semaphore timeout) 129 | (ccl:wait-on-semaphore semaphore))) 130 | 131 | 132 | ;;; 133 | ;;; Condition variables 134 | ;;; 135 | 136 | ;;; Clozure doesn't have native condition variables. 137 | ;;; We'll use the implementation in 138 | ;;; impl-condition-variables-semaphores.lisp 139 | -------------------------------------------------------------------------------- /apiv2/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: CL-USER -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (defpackage :bt2 5 | (:nicknames :bordeaux-threads-2) 6 | (:use :common-lisp :alexandria :global-vars) 7 | #+abcl 8 | (:import-from :java #:jnew #:jcall #:jclass #:jmethod) 9 | #+sbcl 10 | (:import-from :sb-ext #:timeout) 11 | 12 | (:export 13 | #:+supports-threads-p+ 14 | #:bordeaux-threads-error 15 | #:not-implemented) 16 | 17 | ;; Threads 18 | (:export 19 | #:thread 20 | #:thread-name 21 | #:thread-native-thread 22 | #:threadp 23 | #:make-thread 24 | #:*default-special-bindings* 25 | #:*standard-io-bindings* 26 | #:current-thread 27 | #:all-threads 28 | #:start-multiprocessing 29 | 30 | #:interrupt-thread 31 | #:signal-in-thread 32 | #:warn-in-thread 33 | #:error-in-thread 34 | #:destroy-thread 35 | #:thread-alive-p 36 | #:join-thread 37 | #:abnormal-exit 38 | #:abnormal-exit-condition 39 | #:thread-yield) 40 | 41 | ;; Locks 42 | (:export 43 | #:lock 44 | #:lockp 45 | #:recursive-lock 46 | #:recursive-lock-p 47 | #:lock-name 48 | #:lock-native-lock 49 | #:native-lock 50 | #:native-lock-p 51 | #:native-recursive-lock 52 | #:native-recursive-lock-p 53 | 54 | #:make-lock 55 | #:acquire-lock 56 | #:release-lock 57 | #:with-lock-held 58 | 59 | #:make-recursive-lock 60 | #:acquire-recursive-lock 61 | #:release-recursive-lock 62 | #:with-recursive-lock-held) 63 | 64 | ;; Condition variables 65 | (:export 66 | #:condition-variable 67 | #:condition-variable-p 68 | #:make-condition-variable 69 | #:condition-wait 70 | #:condition-notify 71 | #:condition-broadcast) 72 | 73 | ;; Semaphores 74 | (:export 75 | #:semaphore 76 | #:semaphorep 77 | #:make-semaphore 78 | #:signal-semaphore 79 | #:wait-on-semaphore) 80 | 81 | ;; Atomic operations 82 | (:export 83 | #:atomic-integer 84 | #:make-atomic-integer 85 | #:atomic-integer-compare-and-swap 86 | #:atomic-integer-decf 87 | #:atomic-integer-incf 88 | #:atomic-integer-value) 89 | 90 | ;; Timeouts 91 | (:export 92 | #:timeout 93 | #:with-timeout) 94 | 95 | (:documentation "BORDEAUX-THREADS is a proposed standard for a minimal 96 | MP/threading interface. It is similar to the CLIM-SYS threading and 97 | lock support, but for the following broad differences: 98 | 99 | 1) Some behaviours are defined in additional detail: attention has 100 | been given to special variable interaction, whether and when 101 | cleanup forms are run. Some behaviours are defined in less 102 | detail: an implementation that does not support multiple 103 | threads is not required to use a new list (nil) for a lock, for 104 | example. 105 | 106 | 2) Many functions which would be difficult, dangerous or inefficient 107 | to provide on some implementations have been removed. Chiefly 108 | these are functions such as thread-wait which expect for 109 | efficiency that the thread scheduler is written in Lisp and 110 | 'hookable', which can't sensibly be done if the scheduler is 111 | external to the Lisp image, or the system has more than one CPU. 112 | 113 | 3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been 114 | added. 115 | 116 | 4) Posix-style condition variables have been added, as it's not 117 | otherwise possible to implement them correctly using the other 118 | operations that are specified. 119 | 120 | Threads may be implemented using whatever applicable techniques are 121 | provided by the operating system: user-space scheduling, 122 | kernel-based LWPs or anything else that does the job. 123 | 124 | To avoid conflict with existing MP/threading interfaces in 125 | implementations, these symbols live in the BORDEAUX-THREADS-2 package. 126 | Implementations and/or users may also make them visible or exported 127 | in other more traditionally named packages.")) 128 | -------------------------------------------------------------------------------- /apiv1/impl-mezzano.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | Copyright 2016 Henry Harrington 6 | 7 | Distributed under the MIT license (see LICENSE file) 8 | |# 9 | 10 | (in-package #:bordeaux-threads) 11 | 12 | (deftype thread () 13 | 'mezzano.supervisor:thread) 14 | 15 | ;;; Thread Creation 16 | 17 | (defun %make-thread (function name) 18 | (mezzano.supervisor:make-thread function :name name)) 19 | 20 | (defun current-thread () 21 | (mezzano.supervisor:current-thread)) 22 | 23 | (defun threadp (object) 24 | (mezzano.supervisor:threadp object)) 25 | 26 | (defun thread-name (thread) 27 | (mezzano.supervisor:thread-name thread)) 28 | 29 | ;;; Resource contention: locks and recursive locks 30 | 31 | (deftype lock () 'mezzano.supervisor:mutex) 32 | 33 | (defun lock-p (object) 34 | (mezzano.supervisor:mutex-p object)) 35 | 36 | (defun make-lock (&optional name) 37 | (mezzano.supervisor:make-mutex name)) 38 | 39 | (defun acquire-lock (lock &optional (wait-p t)) 40 | (mezzano.supervisor:acquire-mutex lock wait-p)) 41 | 42 | (defun release-lock (lock) 43 | (mezzano.supervisor:release-mutex lock)) 44 | 45 | (defmacro with-lock-held ((place) &body body) 46 | `(mezzano.supervisor:with-mutex (,place) ,@body)) 47 | 48 | (defstruct (recursive-lock 49 | (:constructor make-recursive-lock 50 | (&optional name &aux 51 | (mutex (mezzano.supervisor:make-mutex name))))) 52 | mutex 53 | (depth 0)) 54 | 55 | (defun call-with-recursive-lock-held (lock function) 56 | (cond ((mezzano.supervisor:mutex-held-p 57 | (recursive-lock-mutex lock)) 58 | (unwind-protect 59 | (progn (incf (recursive-lock-depth lock)) 60 | (funcall function)) 61 | (decf (recursive-lock-depth lock)))) 62 | (t 63 | (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock)) 64 | (multiple-value-prog1 65 | (funcall function) 66 | (assert (zerop (recursive-lock-depth lock)))))))) 67 | 68 | (defmacro with-recursive-lock-held ((place) &body body) 69 | `(call-with-recursive-lock-held ,place (lambda () ,@body))) 70 | 71 | ;;; Resource contention: condition variables 72 | 73 | (defun make-condition-variable (&key name) 74 | (mezzano.supervisor:make-condition-variable name)) 75 | 76 | (defun condition-wait (condition-variable lock &key timeout) 77 | (mezzano.supervisor:condition-wait condition-variable lock timeout)) 78 | 79 | (defun condition-notify (condition-variable) 80 | (mezzano.supervisor:condition-notify condition-variable)) 81 | 82 | (defun thread-yield () 83 | (mezzano.supervisor:thread-yield)) 84 | 85 | ;;; Timeouts 86 | 87 | ;;; Semaphores 88 | 89 | (deftype semaphore () 90 | 'mezzano.sync:semaphore) 91 | 92 | (defun make-semaphore (&key name (count 0)) 93 | (mezzano.sync:make-semaphore :name name :value count)) 94 | 95 | (defun signal-semaphore (semaphore &key (count 1)) 96 | (dotimes (c count) (mezzano.sync:semaphore-up semaphore))) 97 | 98 | (defun wait-on-semaphore (semaphore &key timeout) 99 | (mezzano.supervisor:event-wait-for (semaphore :timeout timeout) 100 | (mezzano.sync:semaphore-down semaphore :wait-p nil))) 101 | 102 | ;;; Introspection/debugging 103 | 104 | (defun all-threads () 105 | (mezzano.supervisor:all-threads)) 106 | 107 | (defun interrupt-thread (thread function &rest args) 108 | (mezzano.supervisor:establish-thread-foothold 109 | thread 110 | (named-lambda %interrupt-thread-wrapper () 111 | (apply function args)))) 112 | 113 | (defun destroy-thread (thread) 114 | (signal-error-if-current-thread thread) 115 | (mezzano.supervisor:terminate-thread thread)) 116 | 117 | (defun thread-alive-p (thread) 118 | (not (eql (mezzano.supervisor:thread-state thread) :dead))) 119 | 120 | (defun join-thread (thread) 121 | (signal-error-if-current-thread thread) 122 | ;; THREAD-JOIN can return non-lists if the thread was destroyed. 123 | (let ((values (mezzano.supervisor:thread-join thread))) 124 | (if (listp values) 125 | (values-list values) 126 | nil))) 127 | 128 | (mark-supported) 129 | -------------------------------------------------------------------------------- /apiv1/impl-sbcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; documentation on the SBCL Threads interface can be found at 12 | ;;; http://www.sbcl.org/manual/Threading.html 13 | 14 | (deftype thread () 15 | 'sb-thread:thread) 16 | 17 | ;;; Thread Creation 18 | 19 | (defun %make-thread (function name) 20 | (sb-thread:make-thread function :name name)) 21 | 22 | (defun current-thread () 23 | sb-thread:*current-thread*) 24 | 25 | (defun threadp (object) 26 | (typep object 'sb-thread:thread)) 27 | 28 | (defun thread-name (thread) 29 | (sb-thread:thread-name thread)) 30 | 31 | ;;; Resource contention: locks and recursive locks 32 | 33 | (deftype lock () 'sb-thread:mutex) 34 | 35 | (deftype recursive-lock () 'sb-thread:mutex) 36 | 37 | (defun lock-p (object) 38 | (typep object 'sb-thread:mutex)) 39 | 40 | (defun recursive-lock-p (object) 41 | (typep object 'sb-thread:mutex)) 42 | 43 | (defun make-lock (&optional name) 44 | (sb-thread:make-mutex :name (or name "Anonymous lock"))) 45 | 46 | (defun acquire-lock (lock &optional (wait-p t)) 47 | #+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) 48 | (sb-thread:grab-mutex lock :waitp wait-p) 49 | #-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) 50 | (sb-thread:get-mutex lock nil wait-p)) 51 | 52 | (defun release-lock (lock) 53 | (sb-thread:release-mutex lock)) 54 | 55 | (defmacro with-lock-held ((place) &body body) 56 | `(sb-thread:with-mutex (,place) ,@body)) 57 | 58 | (defun make-recursive-lock (&optional name) 59 | (sb-thread:make-mutex :name (or name "Anonymous recursive lock"))) 60 | 61 | ;;; XXX acquire-recursive-lock and release-recursive-lock are actually 62 | ;;; complicated because we can't use control stack tricks. We need to 63 | ;;; actually count something to check that the acquire/releases are 64 | ;;; balanced 65 | 66 | (defmacro with-recursive-lock-held ((place) &body body) 67 | `(sb-thread:with-recursive-lock (,place) 68 | ,@body)) 69 | 70 | ;;; Resource contention: condition variables 71 | 72 | (defun make-condition-variable (&key name) 73 | (sb-thread:make-waitqueue :name (or name "Anonymous condition variable"))) 74 | 75 | (defun condition-wait (condition-variable lock &key timeout) 76 | (let ((success 77 | (sb-thread:condition-wait condition-variable lock :timeout timeout))) 78 | (when (not success) 79 | (acquire-lock lock)) 80 | success)) 81 | 82 | (defun condition-notify (condition-variable) 83 | (sb-thread:condition-notify condition-variable)) 84 | 85 | (defun thread-yield () 86 | (sb-thread:thread-yield)) 87 | 88 | ;;; Timeouts 89 | 90 | (deftype timeout () 91 | 'sb-ext:timeout) 92 | 93 | (defmacro with-timeout ((timeout) &body body) 94 | `(sb-ext:with-timeout ,timeout 95 | ,@body)) 96 | 97 | ;;; Semaphores 98 | 99 | (deftype semaphore () 100 | 'sb-thread:semaphore) 101 | 102 | (defun make-semaphore (&key name (count 0)) 103 | (sb-thread:make-semaphore :name name :count count)) 104 | 105 | (defun signal-semaphore (semaphore &key (count 1)) 106 | (sb-thread:signal-semaphore semaphore count)) 107 | 108 | (defun wait-on-semaphore (semaphore &key timeout) 109 | (sb-thread:wait-on-semaphore semaphore :timeout timeout)) 110 | 111 | ;;; Introspection/debugging 112 | 113 | (defun all-threads () 114 | (sb-thread:list-all-threads)) 115 | 116 | (defun interrupt-thread (thread function &rest args) 117 | (flet ((apply-function () 118 | (if args 119 | (named-lambda %interrupt-thread-wrapper () 120 | (apply function args)) 121 | function))) 122 | (declare (dynamic-extent #'apply-function)) 123 | (sb-thread:interrupt-thread thread (apply-function)))) 124 | 125 | (defun destroy-thread (thread) 126 | (signal-error-if-current-thread thread) 127 | (sb-thread:terminate-thread thread)) 128 | 129 | (defun thread-alive-p (thread) 130 | (sb-thread:thread-alive-p thread)) 131 | 132 | (defun join-thread (thread) 133 | (sb-thread:join-thread thread)) 134 | 135 | (mark-supported) 136 | -------------------------------------------------------------------------------- /apiv2/api-condition-variables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2) 5 | 6 | ;;; Resource contention: condition variables 7 | 8 | ;;; A condition variable provides a mechanism for threads to put 9 | ;;; themselves to sleep while waiting for the state of something to 10 | ;;; change, then to be subsequently woken by another thread which has 11 | ;;; changed the state. 12 | ;;; 13 | ;;; A condition variable must be used in conjunction with a lock to 14 | ;;; protect access to the state of the object of interest. The 15 | ;;; procedure is as follows: 16 | ;;; 17 | ;;; Suppose two threads A and B, and some kind of notional event 18 | ;;; channel C. A is consuming events in C, and B is producing them. 19 | ;;; CV is a condition-variable 20 | ;;; 21 | ;;; 1) A acquires the lock that safeguards access to C 22 | ;;; 2) A threads and removes all events that are available in C 23 | ;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically 24 | ;;; releases the lock and puts A to sleep on CV 25 | ;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again 26 | ;;; before returning 27 | ;;; 5) Loop back to step 2, for as long as threading should continue 28 | ;;; 29 | ;;; When B generates an event E, it 30 | ;;; 1) acquires the lock guarding C 31 | ;;; 2) adds E to the channel 32 | ;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread 33 | ;;; 4) releases the lock 34 | ;;; 35 | ;;; To avoid the "lost wakeup" problem, the implementation must 36 | ;;; guarantee that CONDITION-WAIT in thread A atomically releases the 37 | ;;; lock and sleeps. If this is not guaranteed there is the 38 | ;;; possibility that thread B can add an event and call 39 | ;;; CONDITION-NOTIFY between the lock release and the sleep - in this 40 | ;;; case the notify call would not see A, which would be left sleeping 41 | ;;; despite there being an event available. 42 | 43 | (defun condition-variable-p (object) 44 | "Returns TRUE if OBJECT is a condition variable, and NIL otherwise." 45 | (typep object 'condition-variable)) 46 | 47 | (defun make-condition-variable (&key name) 48 | "Returns a new condition-variable object for use 49 | with CONDITION-WAIT and CONDITION-NOTIFY." 50 | (check-type name (or null string)) 51 | (%make-condition-variable name)) 52 | 53 | (defun condition-wait (condition-variable lock &key timeout) 54 | "Atomically release LOCK and enqueue the calling 55 | thread waiting for CONDITION-VARIABLE. The thread will resume when 56 | another thread has notified it using CONDITION-NOTIFY; it may also 57 | resume if interrupted by some external event or in other 58 | implementation-dependent circumstances: the caller must always test 59 | on waking that there is threading to be done, instead of assuming 60 | that it can go ahead. 61 | 62 | It is an error to call this function unless from the thread that 63 | holds LOCK. 64 | 65 | If TIMEOUT is nil or not provided, the call blocks until a 66 | notification is received. 67 | 68 | If TIMEOUT is non-nil, the call will return after at most TIMEOUT 69 | seconds (approximately), whether or not a notification has occurred. 70 | 71 | Either NIL or T will be returned. A return of NIL indicates that the 72 | timeout has expired without receiving a notification. A return of T 73 | indicates that a notification was received." 74 | (check-type timeout (or null (real 0))) 75 | (%condition-wait condition-variable 76 | (lock-native-lock lock) 77 | timeout)) 78 | 79 | (defun condition-notify (condition-variable) 80 | "Notify one of the threads waiting for 81 | CONDITION-VARIABLE. 82 | 83 | It is unspecified which thread gets a wakeup and does not 84 | necessarily relate to the order that the threads went to sleep in. 85 | 86 | CONDITION-NOTIFY returns always NIL." 87 | (%condition-notify condition-variable) 88 | nil) 89 | 90 | (defun condition-broadcast (condition-variable) 91 | "Notify all threads waiting for CONDITION-VARIABLE. 92 | 93 | The order of wakeup is unspecified and does not necessarily relate 94 | to the order that the threads went to sleep in. 95 | 96 | CONDITION-BROADCAST returns always NIL." 97 | (%condition-broadcast condition-variable) 98 | nil) 99 | -------------------------------------------------------------------------------- /apiv2/impl-cmucl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'mp::process) 11 | 12 | (defun %start-multiprocessing () 13 | (mp::startup-idle-and-top-level-loops)) 14 | 15 | (defun %make-thread (function name) 16 | ;; CMUCL doesn't like NIL names. 17 | (mp:make-process function :name (or name ""))) 18 | 19 | (defun %current-thread () 20 | mp:*current-process*) 21 | 22 | (defun %thread-name (thread) 23 | (mp:process-name thread)) 24 | 25 | (defun %join-thread (thread) 26 | (mp:process-join thread)) 27 | 28 | (defun %thread-yield () 29 | (mp:process-yield)) 30 | 31 | ;;; 32 | ;;; Introspection/debugging 33 | ;;; 34 | 35 | (defun %all-threads () 36 | (mp:all-processes)) 37 | 38 | (defun %interrupt-thread (thread function) 39 | (mp:process-interrupt thread function)) 40 | 41 | (defun %destroy-thread (thread) 42 | (mp:destroy-process thread)) 43 | 44 | (defun %thread-alive-p (thread) 45 | (mp:process-active-p thread)) 46 | 47 | 48 | ;;; 49 | ;;; Non-recursive locks 50 | ;;; 51 | 52 | (deftype native-lock () 'mp::error-check-lock) 53 | 54 | (defun %make-lock (name) 55 | (mp:make-lock name :kind :error-check)) 56 | 57 | (defun %acquire-lock (lock waitp timeout) 58 | (if (and waitp (null timeout)) 59 | (mp::lock-wait lock "Lock wait") 60 | (mp::lock-wait-with-timeout lock "Lock wait" 61 | (if waitp timeout 0)))) 62 | 63 | (defun %release-lock (lock) 64 | (setf (mp::lock-process lock) nil)) 65 | 66 | (defmacro %with-lock ((place timeout) &body body) 67 | `(mp:with-lock-held (,place "Lock wait" :timeout ,timeout) ,@body)) 68 | 69 | ;;; 70 | ;;; Recursive locks 71 | ;;; 72 | 73 | ;;; Note that the locks _are_ recursive, but not "balanced", and only 74 | ;;; checked if they are being held by the same process by with-lock-held. 75 | ;;; The default with-lock-held in sort of works, in that 76 | ;;; it will wait for recursive locks by the same process as well. 77 | 78 | (deftype native-recursive-lock () 'mp::recursive-lock) 79 | 80 | (defun %make-recursive-lock (name) 81 | (mp:make-lock name :kind :recursive)) 82 | 83 | (defun %acquire-recursive-lock (lock waitp timeout) 84 | (%acquire-lock lock waitp timeout)) 85 | 86 | (defun %release-recursive-lock (lock) 87 | (%release-lock lock)) 88 | 89 | (defmacro %with-recursive-lock ((place timeout) &body body) 90 | `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) 91 | 92 | 93 | ;;; 94 | ;;; Condition variables 95 | ;;; 96 | 97 | ;;; There's some stuff in x86-vm.lisp that might be worth investigating 98 | ;;; whether to build on. There's also process-wait and friends. 99 | 100 | (defstruct (condition-variable 101 | (:constructor %make-condition-variable (name))) 102 | "Bordeaux-threads implementation of condition variables." 103 | name 104 | (lock (%make-lock nil)) 105 | active) 106 | 107 | (defmethod print-object ((cv condition-variable) stream) 108 | (print-unreadable-object (cv stream :type t :identity t) 109 | (format stream "~S" (condition-variable-name cv)))) 110 | 111 | (mark-not-implemented 'condition-wait :timeout) 112 | (defun %condition-wait (cv lock timeout) 113 | (check-type cv condition-variable) 114 | (when timeout 115 | (signal-not-implemented 'condition-wait :timeout)) 116 | (%with-lock ((condition-variable-lock cv) nil) 117 | (setf (condition-variable-active cv) nil)) 118 | (%release-lock lock) 119 | (mp:process-wait "Condition Wait" 120 | #'(lambda () (condition-variable-active cv))) 121 | (%acquire-lock lock t nil) 122 | t) 123 | 124 | (defun %condition-notify (cv) 125 | (check-type cv condition-variable) 126 | (%with-lock ((condition-variable-lock cv) nil) 127 | (setf (condition-variable-active cv) t)) 128 | (thread-yield)) 129 | 130 | (mark-not-implemented 'condition-broadcast) 131 | (defun %condition-broadcast (cv) 132 | (declare (ignore cv)) 133 | (signal-not-implemented 'condition-broadcast)) 134 | 135 | 136 | ;;; 137 | ;;; Timeouts 138 | ;;; 139 | 140 | (defmacro with-timeout ((timeout) &body body) 141 | (once-only (timeout) 142 | `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) 143 | ,@body))) 144 | -------------------------------------------------------------------------------- /apiv1/impl-allegro.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; documentation on the Allegro Multiprocessing interface can be found at 12 | ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm 13 | 14 | ;;; Resource contention: locks and recursive locks 15 | 16 | (deftype lock () 'mp:process-lock) 17 | 18 | (deftype recursive-lock () 'mp:process-lock) 19 | 20 | (defun lock-p (object) 21 | (typep object 'mp:process-lock)) 22 | 23 | (defun recursive-lock-p (object) 24 | (typep object 'mp:process-lock)) 25 | 26 | (defun make-lock (&optional name) 27 | (mp:make-process-lock :name (or name "Anonymous lock"))) 28 | 29 | (defun make-recursive-lock (&optional name) 30 | (mp:make-process-lock :name (or name "Anonymous recursive lock"))) 31 | 32 | (defun acquire-lock (lock &optional (wait-p t)) 33 | (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0))) 34 | 35 | (defun release-lock (lock) 36 | (mp:process-unlock lock)) 37 | 38 | (defmacro with-lock-held ((place) &body body) 39 | `(mp:with-process-lock (,place :norecursive t) 40 | ,@body)) 41 | 42 | (defmacro with-recursive-lock-held ((place &key timeout) &body body) 43 | `(mp:with-process-lock (,place :timeout ,timeout) 44 | ,@body)) 45 | 46 | ;;; Resource contention: condition variables 47 | 48 | (defun make-condition-variable (&key name) 49 | (declare (ignorable name)) 50 | #-(version>= 9) 51 | (mp:make-gate nil) 52 | #+(version>= 9) 53 | (mp:make-condition-variable :name name)) 54 | 55 | (defun condition-wait (condition-variable lock &key timeout) 56 | #-(version>= 9) 57 | (progn 58 | (release-lock lock) 59 | (if timeout 60 | (mp:process-wait-with-timeout "wait for message" timeout 61 | #'mp:gate-open-p condition-variable) 62 | (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable)) 63 | (acquire-lock lock) 64 | (mp:close-gate condition-variable)) 65 | #+(version>= 9) 66 | (mp:condition-variable-wait condition-variable lock :timeout timeout) 67 | t) 68 | 69 | (defun condition-notify (condition-variable) 70 | #-(version>= 9) 71 | (mp:open-gate condition-variable) 72 | #+(version>= 9) 73 | (mp:condition-variable-signal condition-variable)) 74 | 75 | (defun thread-yield () 76 | (mp:process-allow-schedule)) 77 | 78 | (deftype thread () 79 | 'mp:process) 80 | 81 | ;;; Thread Creation 82 | 83 | (defun start-multiprocessing () 84 | (mp:start-scheduler)) 85 | 86 | (defun %make-thread (function name) 87 | #+smp 88 | (mp:process-run-function name function) 89 | #-smp 90 | (mp:process-run-function 91 | name 92 | (named-lambda %join-thread-wrapper () 93 | (let ((return-values 94 | (multiple-value-list (funcall function)))) 95 | (setf (getf (mp:process-property-list mp:*current-process*) 96 | 'return-values) 97 | return-values) 98 | (values-list return-values))))) 99 | 100 | (defun current-thread () 101 | mp:*current-process*) 102 | 103 | (defun threadp (object) 104 | (typep object 'mp:process)) 105 | 106 | (defun thread-name (thread) 107 | (mp:process-name thread)) 108 | 109 | ;;; Timeouts 110 | 111 | (defmacro with-timeout ((timeout) &body body) 112 | (once-only (timeout) 113 | `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) 114 | ,@body))) 115 | 116 | ;;; Introspection/debugging 117 | 118 | (defun all-threads () 119 | mp:*all-processes*) 120 | 121 | (defun interrupt-thread (thread function &rest args) 122 | (apply #'mp:process-interrupt thread function args)) 123 | 124 | (defun destroy-thread (thread) 125 | (signal-error-if-current-thread thread) 126 | (mp:process-kill thread)) 127 | 128 | (defun thread-alive-p (thread) 129 | (mp:process-alive-p thread)) 130 | 131 | (defun join-thread (thread) 132 | #+smp 133 | (values-list (mp:process-join thread)) 134 | #-smp 135 | (progn 136 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 137 | (complement #'mp:process-alive-p) 138 | thread) 139 | (let ((return-values 140 | (getf (mp:process-property-list thread) 'return-values))) 141 | (values-list return-values)))) 142 | 143 | (mark-supported) 144 | -------------------------------------------------------------------------------- /apiv2/impl-allegro.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | #-(version>= 9) 6 | (error 'bordeaux-threads-error 7 | :message "Threading not supported") 8 | 9 | ;;; 10 | ;;; Threads 11 | ;;; 12 | 13 | (deftype native-thread () 14 | 'mp:process) 15 | 16 | (defun %start-multiprocessing () 17 | (mp:start-scheduler)) 18 | 19 | (defun %make-thread (function name) 20 | (mp:process-run-function name function)) 21 | 22 | (defun %current-thread () 23 | mp:*current-process*) 24 | 25 | (defun %thread-name (thread) 26 | (mp:process-name thread)) 27 | 28 | (defun %join-thread (thread) 29 | #+smp 30 | (mp:process-join thread) 31 | #-smp 32 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 33 | (complement #'mp:process-alive-p) 34 | thread)) 35 | 36 | (defun %thread-yield () 37 | (mp:process-allow-schedule)) 38 | 39 | ;;; 40 | ;;; Introspection/debugging 41 | ;;; 42 | 43 | (defun %all-threads () 44 | mp:*all-processes*) 45 | 46 | (defun %interrupt-thread (thread function) 47 | (mp:process-interrupt thread function)) 48 | 49 | (defun %destroy-thread (thread) 50 | (mp:process-kill thread)) 51 | 52 | (defun %thread-alive-p (thread) 53 | (mp:process-alive-p thread)) 54 | 55 | 56 | ;;; 57 | ;;; Non-recursive locks 58 | ;;; 59 | 60 | (deftype native-lock () 'mp:process-lock) 61 | 62 | (defun %make-lock (name) 63 | (mp:make-process-lock :name name)) 64 | 65 | (defun %acquire-lock (lock waitp timeout) 66 | (mp:process-lock lock mp:*current-process* "Lock" 67 | (if waitp timeout 0))) 68 | 69 | (defun %release-lock (lock) 70 | (mp:process-unlock lock)) 71 | 72 | (defmacro %with-lock ((place timeout) &body body) 73 | `(mp:with-process-lock (,place :timeout ,timeout :norecursive t) 74 | ,@body)) 75 | 76 | ;;; 77 | ;;; Recursive locks 78 | ;;; 79 | 80 | (deftype native-recursive-lock () 'mp:process-lock) 81 | 82 | (defun %make-recursive-lock (name) 83 | (mp:make-process-lock :name name)) 84 | 85 | (mark-not-implemented 'acquire-recursive-lock) 86 | (defun %acquire-recursive-lock (lock waitp timeout) 87 | (declare (ignore lock waitp timeout)) 88 | (signal-not-implemented 'acquire-recursive-lock)) 89 | 90 | (mark-not-implemented 'release-recursive-lock) 91 | (defun %release-recursive-lock (lock) 92 | (declare (ignore lock)) 93 | (signal-not-implemented 'release-recursive-lock)) 94 | 95 | (defmacro %with-recursive-lock ((place timeout) &body body) 96 | `(mp:with-process-lock (,place :timeout ,timeout) 97 | ,@body)) 98 | 99 | 100 | ;;; 101 | ;;; Timeouts 102 | ;;; 103 | 104 | (defmacro with-timeout ((timeout) &body body) 105 | (once-only (timeout) 106 | `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) 107 | ,@body))) 108 | 109 | 110 | ;;; 111 | ;;; Semaphores 112 | ;;; 113 | 114 | (defstruct (semaphore 115 | (:constructor %%make-semaphore (name))) 116 | "Bordeaux-threads implementation of semaphores." 117 | name 118 | (gate (mp:make-gate nil))) 119 | 120 | (defmethod print-object ((sem semaphore) stream) 121 | (print-unreadable-object (sem stream :type t :identity t) 122 | (format stream "~S" (semaphore-name sem)))) 123 | 124 | (defun %make-semaphore (name count) 125 | (let ((sem (%%make-semaphore name))) 126 | (%signal-semaphore sem count) 127 | sem)) 128 | 129 | (defun %signal-semaphore (semaphore count) 130 | (dotimes (i count) 131 | (mp:put-semaphore (semaphore-gate semaphore)))) 132 | 133 | (defun %wait-on-semaphore (semaphore timeout) 134 | (cond 135 | (timeout 136 | ;; Timeouts that are too small expire immediately. 137 | ;; 100ms should suffice. 138 | (when (< timeout 0.1) 139 | (setf timeout 0.1)) 140 | (handler-case 141 | (with-timeout (timeout) 142 | (mp:get-semaphore (semaphore-gate semaphore)) 143 | t) 144 | (timeout () nil))) 145 | (t 146 | (mp:get-semaphore (semaphore-gate semaphore)) 147 | t))) 148 | 149 | 150 | ;;; 151 | ;;; Condition variables 152 | ;;; 153 | 154 | (deftype condition-variable () 155 | 'mp:condition-variable) 156 | 157 | (defun %make-condition-variable (name) 158 | (mp:make-condition-variable :name name)) 159 | 160 | (defun %condition-wait (cv lock timeout) 161 | (mp:condition-variable-wait cv lock :timeout timeout)) 162 | 163 | (defun %condition-notify (cv) 164 | (mp:condition-variable-signal cv)) 165 | 166 | (defun %condition-broadcast (cv) 167 | (mp:condition-variable-broadcast cv)) 168 | -------------------------------------------------------------------------------- /test/not-implemented.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2/TEST -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2/test) 5 | 6 | (in-suite :bordeaux-threads-2) 7 | 8 | (test not-implemented.whole-function 9 | (let ((*missing-functions* (make-hash-table :test #'eql)) 10 | (*missing-features* (make-hash-table :test #'equal)) 11 | (op 'acquire-lock) 12 | (feature :some-feature)) 13 | (is-true (implemented-p op)) 14 | (is-true (implemented-p op feature)) 15 | (mark-not-implemented op) 16 | (is-false (implemented-p op)) 17 | (is-false (implemented-p op feature)))) 18 | 19 | (test not-implemented.one-feature 20 | (let ((*missing-functions* (make-hash-table :test #'eql)) 21 | (*missing-features* (make-hash-table :test #'equal)) 22 | (op 'acquire-lock) 23 | (feature :timeout)) 24 | (is-true (implemented-p op)) 25 | (is-true (implemented-p op feature)) 26 | (mark-not-implemented op feature) 27 | (is-true (implemented-p op)) 28 | (is-false (implemented-p op feature)))) 29 | 30 | ;;; 31 | ;;; Threads 32 | ;;; 33 | 34 | (test make-thread.not-implemented 35 | (if (implemented-p 'bt2:make-thread) 36 | (pass) 37 | (signals not-implemented (make-thread (lambda ()))))) 38 | 39 | (test join-thread.not-implemented 40 | (if (implemented-p 'bt2:join-thread) 41 | (pass) 42 | (signals not-implemented (join-thread (make-thread (lambda ())))))) 43 | 44 | (test current-thread.not-implemented 45 | (if (implemented-p 'bt2:current-thread) 46 | (pass) 47 | (signals not-implemented (current-thread)))) 48 | 49 | (test thread-yield.not-implemented 50 | (if (implemented-p 'bt2:thread-yield) 51 | (pass) 52 | (signals not-implemented (thread-yield)))) 53 | 54 | (test all-threads.not-implemented 55 | (if (implemented-p 'bt2:all-threads) 56 | (pass) 57 | (signals not-implemented (all-threads)))) 58 | 59 | (test interrupt-thread.not-implemented 60 | (if (implemented-p 'bt2:interrupt-thread) 61 | (pass) 62 | (signals not-implemented 63 | (let ((thread (make-thread (lambda () (sleep 5))))) 64 | (interrupt-thread thread (lambda ())))))) 65 | 66 | (test destroy-thread.not-implemented 67 | (if (implemented-p 'bt2:destroy-thread) 68 | (pass) 69 | (signals not-implemented 70 | (destroy-thread (make-thread (lambda ())))))) 71 | 72 | (test thread-alive-p.not-implemented 73 | (if (implemented-p 'bt2:thread-alive-p) 74 | (pass) 75 | (signals not-implemented 76 | (thread-alive-p (make-thread (lambda ())))))) 77 | 78 | 79 | ;;; 80 | ;;; Locks 81 | ;;; 82 | 83 | (test make-lock.not-implemented 84 | (if (implemented-p 'bt2:make-lock) 85 | (pass) 86 | (signals not-implemented (make-lock)))) 87 | 88 | (test acquire-lock.not-implemented 89 | (if (implemented-p 'bt2:acquire-lock) 90 | (pass) 91 | (signals not-implemented 92 | (acquire-lock (make-lock))))) 93 | 94 | (test release-lock.not-implemented 95 | (if (implemented-p 'bt2:release-lock) 96 | (pass) 97 | (signals not-implemented 98 | (let ((lock (make-lock))) 99 | (acquire-lock lock) 100 | (release-lock lock))))) 101 | 102 | (test with-lock-held.not-implemented 103 | (if (implemented-p 'bt2:with-lock-held) 104 | (pass) 105 | (signals not-implemented 106 | (let ((lock (make-lock))) 107 | (with-lock-held (lock)))))) 108 | 109 | (test make-recursive-lock.not-implemented 110 | (if (implemented-p 'bt2:make-recursive-lock) 111 | (pass) 112 | (signals not-implemented (make-recursive-lock)))) 113 | 114 | (test acquire-recursive-lock.not-implemented 115 | (if (implemented-p 'bt2:acquire-recursive-lock) 116 | (pass) 117 | (signals not-implemented 118 | (acquire-recursive-lock (make-recursive-lock))))) 119 | 120 | (test release-recursive-lock.not-implemented 121 | (if (implemented-p 'bt2:release-recursive-lock) 122 | (pass) 123 | (signals not-implemented 124 | (let ((lock (make-recursive-lock))) 125 | (acquire-recursive-lock lock) 126 | (release-recursive-lock lock))))) 127 | 128 | (test with-recursive-lock-held.not-implemented 129 | (if (implemented-p 'bt2:with-recursive-lock-held) 130 | (pass) 131 | (signals not-implemented 132 | (let ((lock (make-recursive-lock))) 133 | (with-recursive-lock-held (lock)))))) 134 | 135 | 136 | ;;; 137 | ;;; Condition variables 138 | ;;; 139 | 140 | 141 | 142 | ;;; 143 | ;;; Semaphores 144 | ;;; 145 | -------------------------------------------------------------------------------- /apiv1/impl-lispworks.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | ;;; documentation on the LispWorks Multiprocessing interface can be found at 12 | ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm 13 | 14 | (deftype thread () 15 | 'mp:process) 16 | 17 | ;;; Thread Creation 18 | 19 | (defun start-multiprocessing () 20 | (mp:initialize-multiprocessing)) 21 | 22 | (defun %make-thread (function name) 23 | (mp:process-run-function 24 | name nil 25 | (named-lambda %join-thread-wrapper () 26 | (let ((return-values 27 | (multiple-value-list (funcall function)))) 28 | (setf (mp:process-property 'return-values) 29 | return-values) 30 | (values-list return-values))))) 31 | 32 | (defun current-thread () 33 | #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) 34 | mp:*current-process* 35 | ;; introduced in LispWorks 5.1 36 | #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) 37 | (mp:get-current-process)) 38 | 39 | (defun threadp (object) 40 | (mp:process-p object)) 41 | 42 | (defun thread-name (thread) 43 | (mp:process-name thread)) 44 | 45 | ;;; Resource contention: locks and recursive locks 46 | 47 | 48 | (deftype lock () 'mp:lock) 49 | 50 | #-(or lispworks4 lispworks5) 51 | (deftype recursive-lock () 52 | '(and mp:lock (satisfies mp:lock-recursive-p))) 53 | 54 | (defun lock-p (object) 55 | (typep object 'mp:lock)) 56 | 57 | (defun recursive-lock-p (object) 58 | #+(or lispworks4 lispworks5) 59 | nil 60 | #-(or lispworks4 lispworks5) ; version 6+ 61 | (and (typep object 'mp:lock) 62 | (mp:lock-recursive-p object))) 63 | 64 | (defun make-lock (&optional name) 65 | (mp:make-lock :name (or name "Anonymous lock") 66 | #-(or lispworks4 lispworks5) :recursivep 67 | #-(or lispworks4 lispworks5) nil)) 68 | 69 | (defun acquire-lock (lock &optional (wait-p t)) 70 | (mp:process-lock lock nil 71 | (cond ((null wait-p) 0) 72 | ((numberp wait-p) wait-p) 73 | (t nil)))) 74 | 75 | (defun release-lock (lock) 76 | (mp:process-unlock lock)) 77 | 78 | (defmacro with-lock-held ((place) &body body) 79 | `(mp:with-lock (,place) ,@body)) 80 | 81 | (defun make-recursive-lock (&optional name) 82 | (mp:make-lock :name (or name "Anonymous recursive lock") 83 | #-(or lispworks4 lispworks5) :recursivep 84 | #-(or lispworks4 lispworks5) t)) 85 | 86 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 87 | (acquire-lock lock wait-p)) 88 | 89 | (defun release-recursive-lock (lock) 90 | (release-lock lock)) 91 | 92 | (defmacro with-recursive-lock-held ((place) &body body) 93 | `(mp:with-lock (,place) ,@body)) 94 | 95 | ;;; Resource contention: condition variables 96 | 97 | #-(or lispworks4 lispworks5) 98 | (defun make-condition-variable (&key name) 99 | (mp:make-condition-variable :name (or name "Anonymous condition variable"))) 100 | 101 | #-(or lispworks4 lispworks5) 102 | (defun condition-wait (condition-variable lock &key timeout) 103 | (mp:condition-variable-wait condition-variable lock :timeout timeout)) 104 | 105 | #-(or lispworks4 lispworks5) 106 | (defun condition-notify (condition-variable) 107 | (mp:condition-variable-signal condition-variable)) 108 | 109 | (defun thread-yield () 110 | (mp:process-allow-scheduling)) 111 | 112 | ;;; Introspection/debugging 113 | 114 | (defun all-threads () 115 | (mp:list-all-processes)) 116 | 117 | (defun interrupt-thread (thread function &rest args) 118 | (apply #'mp:process-interrupt thread function args)) 119 | 120 | (defun destroy-thread (thread) 121 | (signal-error-if-current-thread thread) 122 | (mp:process-kill thread)) 123 | 124 | (defun thread-alive-p (thread) 125 | (mp:process-alive-p thread)) 126 | 127 | (declaim (inline %join-thread)) 128 | (defun %join-thread (thread) 129 | #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 130 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 131 | (complement #'mp:process-alive-p) 132 | thread) 133 | #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 134 | (mp:process-join thread)) 135 | 136 | (defun join-thread (thread) 137 | (%join-thread thread) 138 | (let ((return-values 139 | (mp:process-property 'return-values thread))) 140 | (values-list return-values))) 141 | 142 | (mark-supported) 143 | -------------------------------------------------------------------------------- /apiv2/impl-sbcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'sb-thread:thread) 11 | 12 | (defun %make-thread (function name) 13 | (sb-thread:make-thread function :name name)) 14 | 15 | (defun %current-thread () 16 | sb-thread:*current-thread*) 17 | 18 | (defun %thread-name (thread) 19 | (sb-thread:thread-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | (ignore-some-conditions (sb-thread:join-thread-error) 23 | (sb-thread:join-thread thread))) 24 | 25 | (defun %thread-yield () 26 | (sb-thread:thread-yield)) 27 | 28 | ;;; 29 | ;;; Introspection/debugging 30 | ;;; 31 | 32 | (defun %all-threads () 33 | (sb-thread:list-all-threads)) 34 | 35 | (defun %interrupt-thread (thread function) 36 | (sb-thread:interrupt-thread thread function)) 37 | 38 | (defun %destroy-thread (thread) 39 | (sb-thread:terminate-thread thread)) 40 | 41 | (defun %thread-alive-p (thread) 42 | (sb-thread:thread-alive-p thread)) 43 | 44 | 45 | ;;; 46 | ;;; Non-recursive locks 47 | ;;; 48 | 49 | (deftype native-lock () 50 | 'sb-thread:mutex) 51 | 52 | (defun %make-lock (name) 53 | (sb-thread:make-mutex :name name)) 54 | 55 | (defun %try-lock (lock) 56 | (sb-sys:without-interrupts 57 | (sb-thread:grab-mutex lock :waitp nil))) 58 | 59 | (defun %lock (lock) 60 | (sb-sys:without-interrupts 61 | (sb-sys:allow-with-interrupts 62 | (loop :while (not (sb-thread:grab-mutex lock :waitp t))) 63 | t))) 64 | 65 | (defun %timedlock (lock timeout) 66 | (let ((deadline (+ (get-internal-real-time) 67 | (* internal-time-units-per-second 68 | timeout)))) 69 | (sb-sys:without-interrupts 70 | (sb-sys:allow-with-interrupts 71 | (loop :while (not (sb-thread:grab-mutex lock :waitp t :timeout timeout)) 72 | :for now := (get-internal-real-time) 73 | :do (if (>= now deadline) 74 | (return-from %timedlock nil) 75 | (setf timeout (/ (- deadline now) 76 | internal-time-units-per-second)))) 77 | t)))) 78 | 79 | (defun %acquire-lock (lock waitp timeout) 80 | (cond 81 | ((not waitp) 82 | (%try-lock lock)) 83 | ((null timeout) 84 | (%lock lock)) 85 | (t 86 | (%timedlock lock timeout)))) 87 | 88 | (defun %release-lock (lock) 89 | (sb-sys:without-interrupts 90 | (sb-thread:release-mutex lock))) 91 | 92 | (defmacro %with-lock ((place timeout) &body body) 93 | `(sb-thread:with-mutex (,place :timeout ,timeout) ,@body)) 94 | 95 | ;;; 96 | ;;; Recursive locks 97 | ;;; 98 | 99 | (deftype native-recursive-lock () 100 | 'sb-thread:mutex) 101 | 102 | (defun %make-recursive-lock (name) 103 | (sb-thread:make-mutex :name name)) 104 | 105 | (mark-not-implemented 'acquire-recursive-lock) 106 | (defun %acquire-recursive-lock (lock waitp timeout) 107 | (declare (ignore lock waitp timeout)) 108 | (signal-not-implemented 'acquire-recursive-lock)) 109 | 110 | (mark-not-implemented 'release-recursive-lock) 111 | (defun %release-recursive-lock (lock) 112 | (declare (ignore lock)) 113 | (signal-not-implemented 'release-recursive-lock)) 114 | 115 | (defmacro %with-recursive-lock ((place timeout) &body body) 116 | `(sb-thread:with-recursive-lock (,place :timeout ,timeout) 117 | ,@body)) 118 | 119 | 120 | ;;; 121 | ;;; Semaphores 122 | ;;; 123 | 124 | (deftype semaphore () 125 | 'sb-thread:semaphore) 126 | 127 | (defun %make-semaphore (name count) 128 | (sb-thread:make-semaphore :name name :count count)) 129 | 130 | (defun %signal-semaphore (semaphore count) 131 | (sb-thread:signal-semaphore semaphore count)) 132 | 133 | (defun %wait-on-semaphore (semaphore timeout) 134 | (cond 135 | ((and timeout (zerop timeout)) 136 | (sb-thread:try-semaphore semaphore)) 137 | (t 138 | (if (sb-thread:wait-on-semaphore semaphore :timeout timeout) 139 | t nil)))) 140 | 141 | 142 | ;;; 143 | ;;; Condition variables 144 | ;;; 145 | 146 | (deftype condition-variable () 147 | 'sb-thread:waitqueue) 148 | 149 | (defun %make-condition-variable (name) 150 | (sb-thread:make-waitqueue :name name)) 151 | 152 | (defun %condition-wait (cv lock timeout) 153 | (let ((success 154 | (sb-thread:condition-wait cv lock :timeout timeout))) 155 | (when (not success) 156 | (%acquire-lock lock t nil)) 157 | success)) 158 | 159 | (defun %condition-notify (cv) 160 | (sb-thread:condition-notify cv)) 161 | 162 | (defun %condition-broadcast (cv) 163 | (sb-thread:condition-broadcast cv)) 164 | 165 | 166 | ;;; 167 | ;;; Timeouts 168 | ;;; 169 | 170 | (defmacro with-timeout ((timeout) &body body) 171 | `(sb-ext:with-timeout ,timeout 172 | ,@body)) 173 | -------------------------------------------------------------------------------- /apiv2/impl-mezzano.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | ;;; 6 | ;;; Threads 7 | ;;; 8 | 9 | (deftype native-thread () 10 | 'mezzano.supervisor:thread) 11 | 12 | (defun %make-thread (function name) 13 | (mezzano.supervisor:make-thread function :name name)) 14 | 15 | (defun %current-thread () 16 | (mezzano.supervisor:current-thread)) 17 | 18 | (defun %thread-name (thread) 19 | (mezzano.supervisor:thread-name thread)) 20 | 21 | (defun %join-thread (thread) 22 | ;; THREAD-JOIN can return non-lists if the thread was destroyed. 23 | (let ((values (mezzano.supervisor:thread-join thread))) 24 | (if (listp values) 25 | (values-list values) 26 | nil))) 27 | 28 | (defun %thread-yield () 29 | (mezzano.supervisor:thread-yield)) 30 | 31 | ;;; 32 | ;;; Introspection/debugging 33 | ;;; 34 | 35 | (defun %all-threads () 36 | (mezzano.supervisor:all-threads)) 37 | 38 | (defun %interrupt-thread (thread function) 39 | (mezzano.supervisor:establish-thread-foothold thread function)) 40 | 41 | (defun %destroy-thread (thread) 42 | (mezzano.supervisor:terminate-thread thread)) 43 | 44 | (defun %thread-alive-p (thread) 45 | (not (eql (mezzano.supervisor:thread-state thread) :dead))) 46 | 47 | 48 | ;;; 49 | ;;; Non-recursive locks 50 | ;;; 51 | 52 | (deftype native-lock () 'mezzano.supervisor:mutex) 53 | 54 | (defun %make-lock (name) 55 | (mezzano.supervisor:make-mutex name)) 56 | 57 | (mark-not-implemented 'acquire-lock :timeout) 58 | (defun %acquire-lock (lock waitp timeout) 59 | (when timeout 60 | (signal-not-implemented 'acquire-lock :timeout)) 61 | (mezzano.supervisor:acquire-mutex lock waitp)) 62 | 63 | (defun %release-lock (lock) 64 | (mezzano.supervisor:release-mutex lock)) 65 | 66 | (mark-not-implemented 'with-lock-held :timeout) 67 | (defmacro %with-lock ((place timeout) &body body) 68 | (if timeout 69 | `(signal-not-implemented 'with-lock-held :timeout) 70 | `(mezzano.supervisor:with-mutex (,place) ,@body))) 71 | 72 | ;;; 73 | ;;; Recursive locks 74 | ;;; 75 | 76 | (defstruct (%recursive-lock 77 | (:constructor %make-recursive-lock-internal (mutex))) 78 | mutex 79 | (depth 0)) 80 | 81 | (deftype native-recursive-lock () '%recursive-lock) 82 | 83 | (defun %make-recursive-lock (name) 84 | (%make-recursive-lock-internal (%make-lock name))) 85 | 86 | (mark-not-implemented 'acquire-recursive-lock) 87 | (defun %acquire-recursive-lock (lock waitp timeout) 88 | (declare (ignore lock waitp timeout)) 89 | (signal-not-implemented 'acquire-recursive-lock)) 90 | 91 | (release-not-implemented 'release-recursive-lock) 92 | (defun %release-recursive-lock (lock) 93 | (declare (ignore lock)) 94 | (signal-not-implemented 'release-recursive-lock)) 95 | 96 | (defun call-with-recursive-lock-held (lock function) 97 | (cond ((mezzano.supervisor:mutex-held-p 98 | (%recursive-lock-mutex lock)) 99 | (unwind-protect 100 | (progn (incf (%recursive-lock-depth lock)) 101 | (funcall function)) 102 | (decf (%recursive-lock-depth lock)))) 103 | (t 104 | (mezzano.supervisor:with-mutex ((%recursive-lock-mutex lock)) 105 | (multiple-value-prog1 106 | (funcall function) 107 | (assert (zerop (%recursive-lock-depth lock)))))))) 108 | 109 | (mark-not-implemented 'with-recursive-lock-held :timeout) 110 | (defmacro %with-recursive-lock ((place timeout) &body body) 111 | (if timeout 112 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 113 | `(call-with-recursive-lock-held ,place (lambda () ,@body)))) 114 | 115 | 116 | ;;; 117 | ;;; Semaphores 118 | ;;; 119 | 120 | (deftype semaphore () 121 | 'mezzano.sync:semaphore) 122 | 123 | (defun %make-semaphore (name count) 124 | (mezzano.sync:make-semaphore :name name :value count)) 125 | 126 | (defun %signal-semaphore (semaphore count) 127 | (dotimes (c count) (mezzano.sync:semaphore-up semaphore))) 128 | 129 | (defun %wait-on-semaphore (semaphore timeout) 130 | (mezzano.supervisor:event-wait-for (semaphore :timeout timeout) 131 | (mezzano.sync:semaphore-down semaphore :wait-p nil))) 132 | 133 | 134 | ;;; 135 | ;;; Condition variables 136 | ;;; 137 | 138 | (deftype condition-variable () 139 | 'mezzano.supervisor:condition-variable) 140 | 141 | (defun %make-condition-variable (name) 142 | (mezzano.supervisor:make-condition-variable name)) 143 | 144 | (defun %condition-wait (cv lock timeout) 145 | (mezzano.supervisor:condition-wait cv lock timeout)) 146 | 147 | (defun %condition-notify (cv) 148 | (mezzano.supervisor:condition-notify cv)) 149 | 150 | (mark-not-implemented 'condition-broadcast) 151 | (defun %condition-broadcast (cv) 152 | (declare (ignore cv)) 153 | (signal-not-implemented 'condition-broadcast)) 154 | -------------------------------------------------------------------------------- /apiv1/impl-abcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011. 7 | 8 | Distributed under the MIT license (see LICENSE file) 9 | |# 10 | 11 | (in-package #:bordeaux-threads) 12 | 13 | ;;; the implementation of the Armed Bear thread interface can be found in 14 | ;;; src/org/armedbear/lisp/LispThread.java 15 | 16 | (deftype thread () 17 | 'threads:thread) 18 | 19 | ;;; Thread Creation 20 | 21 | (defun %make-thread (function name) 22 | (threads:make-thread function :name name)) 23 | 24 | (defun current-thread () 25 | (threads:current-thread)) 26 | 27 | (defun thread-name (thread) 28 | (threads:thread-name thread)) 29 | 30 | (defun threadp (object) 31 | (typep object 'thread)) 32 | 33 | ;;; Resource contention: locks and recursive locks 34 | 35 | (defstruct mutex name lock) 36 | (defstruct (mutex-recursive (:include mutex))) 37 | 38 | ;; Making methods constants in this manner avoids the runtime expense of 39 | ;; introspection involved in JCALL with string arguments. 40 | (defconstant +lock+ 41 | (jmethod "java.util.concurrent.locks.ReentrantLock" "lock")) 42 | (defconstant +try-lock+ 43 | (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock")) 44 | (defconstant +is-held-by-current-thread+ 45 | (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread")) 46 | (defconstant +unlock+ 47 | (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock")) 48 | (defconstant +get-hold-count+ 49 | (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount")) 50 | 51 | (deftype lock () 'mutex) 52 | 53 | (deftype recursive-lock () 'mutex-recursive) 54 | 55 | (defun lock-p (object) 56 | (typep object 'mutex)) 57 | 58 | (defun recursive-lock-p (object) 59 | (typep object 'mutex-recursive)) 60 | 61 | (defun make-lock (&optional name) 62 | (make-mutex 63 | :name (or name "Anonymous lock") 64 | :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) 65 | 66 | (defun acquire-lock (lock &optional (wait-p t)) 67 | (check-type lock mutex) 68 | (when (jcall +is-held-by-current-thread+ (mutex-lock lock)) 69 | (error "Non-recursive lock being reacquired by owner.")) 70 | (cond 71 | (wait-p 72 | (jcall +lock+ (mutex-lock lock)) 73 | t) 74 | (t (jcall +try-lock+ (mutex-lock lock))))) 75 | 76 | (defun release-lock (lock) 77 | (check-type lock mutex) 78 | (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) 79 | (error "Attempt to release lock not held by calling thread.")) 80 | (jcall +unlock+ (mutex-lock lock)) 81 | (values)) 82 | 83 | (defun make-recursive-lock (&optional name) 84 | (make-mutex-recursive 85 | :name (or name "Anonymous lock") 86 | :lock (jnew "java.util.concurrent.locks.ReentrantLock"))) 87 | 88 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 89 | (check-type lock mutex-recursive) 90 | (cond 91 | (wait-p 92 | (jcall +lock+ (mutex-recursive-lock lock)) 93 | t) 94 | (t (jcall +try-lock+ (mutex-recursive-lock lock))))) 95 | 96 | (defun release-recursive-lock (lock) 97 | (check-type lock mutex-recursive) 98 | (unless (jcall +is-held-by-current-thread+ (mutex-lock lock)) 99 | (error "Attempt to release lock not held by calling thread.")) 100 | (jcall +unlock+ (mutex-lock lock)) 101 | (values)) 102 | 103 | ;;; Resource contention: condition variables 104 | 105 | (defun thread-yield () 106 | (java:jstatic "yield" "java.lang.Thread")) 107 | 108 | (defstruct condition-variable 109 | (name "Anonymous condition variable")) 110 | 111 | (defun condition-wait (condition lock &key timeout) 112 | (threads:synchronized-on condition 113 | (release-lock lock) 114 | (if timeout 115 | ;; Since giving a zero time value to threads:object-wait means 116 | ;; an indefinite wait, use some arbitrary small number. 117 | (threads:object-wait condition 118 | (if (zerop timeout) 119 | least-positive-single-float 120 | timeout)) 121 | (threads:object-wait condition))) 122 | (acquire-lock lock) 123 | t) 124 | 125 | (defun condition-notify (condition) 126 | (threads:synchronized-on condition 127 | (threads:object-notify condition))) 128 | 129 | ;;; Introspection/debugging 130 | 131 | (defun all-threads () 132 | (let ((threads ())) 133 | (threads:mapcar-threads (lambda (thread) 134 | (push thread threads))) 135 | (reverse threads))) 136 | 137 | (defun interrupt-thread (thread function &rest args) 138 | (apply #'threads:interrupt-thread thread function args)) 139 | 140 | (defun destroy-thread (thread) 141 | (signal-error-if-current-thread thread) 142 | (threads:destroy-thread thread)) 143 | 144 | (defun thread-alive-p (thread) 145 | (threads:thread-alive-p thread)) 146 | 147 | (defun join-thread (thread) 148 | (threads:thread-join thread)) 149 | 150 | (mark-supported) 151 | -------------------------------------------------------------------------------- /apiv2/impl-ecl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | (in-package :bordeaux-threads-2) 4 | 5 | (eval-when (:compile-toplevel :execute) 6 | (when (>= ext:+ecl-version-number+ 230909) 7 | (pushnew :has-timeouts *features*))) 8 | 9 | ;;; 10 | ;;; Threads 11 | ;;; 12 | 13 | (deftype native-thread () 14 | 'mp:process) 15 | 16 | (defun %make-thread (function name) 17 | (mp:process-run-function name function)) 18 | 19 | (defun %current-thread () 20 | mp:*current-process*) 21 | 22 | (defun %thread-name (thread) 23 | ;; Some system threads have symbols for a name. 24 | (string (mp:process-name thread))) 25 | 26 | (defun %join-thread (thread) 27 | (mp:process-join thread)) 28 | 29 | (defun %thread-yield () 30 | (mp:process-yield)) 31 | 32 | ;;; 33 | ;;; Introspection/debugging 34 | ;;; 35 | 36 | (defun %all-threads () 37 | (mp:all-processes)) 38 | 39 | (defun %interrupt-thread (thread function) 40 | (mp:interrupt-process thread function)) 41 | 42 | (defun %destroy-thread (thread) 43 | (mp:process-kill thread)) 44 | 45 | (defun %thread-alive-p (thread) 46 | (mp:process-active-p thread)) 47 | 48 | 49 | ;;; 50 | ;;; Non-recursive locks 51 | ;;; 52 | 53 | (deftype native-lock () 'mp:lock) 54 | 55 | (defun %make-lock (name) 56 | (mp:make-lock :name name)) 57 | 58 | #-has-timeouts 59 | (progn 60 | (mark-not-implemented 'acquire-lock :timeout) 61 | (defun %acquire-lock (lock waitp timeout) 62 | (when timeout 63 | (signal-not-implemented 'acquire-lock :timeout)) 64 | (mp:get-lock lock waitp))) 65 | 66 | #+has-timeouts 67 | (defun %acquire-lock (lock waitp timeout) 68 | (mp:get-lock lock (cond ((not waitp) nil) 69 | (timeout timeout) 70 | (t t)))) 71 | 72 | (defun %release-lock (lock) 73 | (mp:giveup-lock lock)) 74 | 75 | #-has-timeouts 76 | (progn 77 | (mark-not-implemented 'with-lock-held :timeout) 78 | (defmacro %with-lock ((place timeout) &body body) 79 | (if timeout 80 | `(signal-not-implemented 'with-lock-held :timeout) 81 | `(mp:with-lock (,place) ,@body)))) 82 | 83 | #+has-timeouts 84 | (defmacro %with-lock ((place timeout) &body body) 85 | `(mp:with-lock (,place :wait-form (or ,timeout t)) 86 | ,@body)) 87 | 88 | ;;; 89 | ;;; Recursive locks 90 | ;;; 91 | 92 | (deftype native-recursive-lock () 93 | '(and mp:lock (satisfies mp:recursive-lock-p))) 94 | 95 | (defun %make-recursive-lock (name) 96 | (mp:make-lock :name name :recursive t)) 97 | 98 | #-has-timeouts 99 | (progn 100 | (mark-not-implemented 'acquire-recursive-lock :timeout) 101 | (defun %acquire-recursive-lock (lock waitp timeout) 102 | (when timeout 103 | (signal-not-implemented 'acquire-recursive-lock :timeout)) 104 | (mp:get-lock lock waitp))) 105 | 106 | #+has-timeouts 107 | (defun %acquire-recursive-lock (lock waitp timeout) 108 | (mp:get-lock lock (cond ((not waitp) nil) 109 | (timeout timeout) 110 | (t t)))) 111 | 112 | (defun %release-recursive-lock (lock) 113 | (mp:giveup-lock lock)) 114 | 115 | #-has-timeouts 116 | (progn 117 | (mark-not-implemented 'with-recursive-lock-held :timeout) 118 | (defmacro %with-recursive-lock ((place timeout) &body body) 119 | (if timeout 120 | `(signal-not-implemented 'with-recursive-lock-held :timeout) 121 | `(mp:with-lock (,place) ,@body)))) 122 | 123 | #+has-timeouts 124 | (defmacro %with-recursive-lock ((place timeout) &body body) 125 | `(mp:with-lock (,place :wait-form (or ,timeout t)) 126 | ,@body)) 127 | 128 | 129 | ;;; 130 | ;;; Semaphores 131 | ;;; 132 | 133 | (deftype semaphore () 'mp:semaphore) 134 | 135 | (defun %make-semaphore (name count) 136 | (mp:make-semaphore :name name :count count)) 137 | 138 | (defun %signal-semaphore (semaphore count) 139 | (mp:signal-semaphore semaphore count)) 140 | 141 | (defun %wait-on-semaphore (semaphore timeout) 142 | (cond 143 | ((null timeout) 144 | (mp:wait-on-semaphore semaphore) 145 | t) 146 | ((plusp timeout) 147 | #-has-timeouts 148 | (handler-case 149 | (with-timeout (timeout) 150 | (mp:wait-on-semaphore semaphore) 151 | t) 152 | (timeout () nil)) 153 | #+has-timeouts 154 | (mp:semaphore-wait semaphore 1 timeout)) 155 | (t 156 | (if (mp:try-get-semaphore semaphore) t nil)))) 157 | 158 | 159 | ;;; 160 | ;;; Condition variables 161 | ;;; 162 | 163 | (deftype condition-variable () 164 | 'mp:condition-variable) 165 | 166 | (defun %make-condition-variable ( name) 167 | (declare (ignore name)) 168 | (mp:make-condition-variable)) 169 | 170 | (defun %condition-wait (cv lock timeout) 171 | (if timeout 172 | #-has-timeouts 173 | (handler-case 174 | (with-timeout (timeout) 175 | (mp:condition-variable-wait cv lock)) 176 | (timeout () 177 | (%acquire-lock lock t nil) 178 | nil)) 179 | #+has-timeouts 180 | (mp:condition-variable-timedwait cv lock timeout) 181 | (mp:condition-variable-wait cv lock))) 182 | 183 | (defun %condition-notify (cv) 184 | (mp:condition-variable-signal cv)) 185 | 186 | (defun %condition-broadcast (cv) 187 | (mp:condition-variable-broadcast cv)) 188 | 189 | (eval-when (:compile-toplevel :execute) 190 | (setf *features* (remove :has-timeouts *features*))) 191 | -------------------------------------------------------------------------------- /apiv1/impl-cmucl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- indent-tabs-mode: nil -*- 2 | 3 | #| 4 | Copyright 2006, 2007 Greg Pfeil 5 | 6 | Distributed under the MIT license (see LICENSE file) 7 | |# 8 | 9 | (in-package #:bordeaux-threads) 10 | 11 | (deftype thread () 12 | 'mp::process) 13 | 14 | ;;; Thread Creation 15 | 16 | (defun start-multiprocessing () 17 | (mp::startup-idle-and-top-level-loops)) 18 | 19 | (defun %make-thread (function name) 20 | #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 21 | (mp:make-process function :name name) 22 | #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 23 | (mp:make-process (named-lambda %join-thread-wrapper () 24 | (let ((return-values 25 | (multiple-value-list (funcall function)))) 26 | (setf (getf (mp:process-property-list mp:*current-process*) 27 | 'return-values) 28 | return-values) 29 | (values-list return-values))) 30 | :name name)) 31 | 32 | (defun current-thread () 33 | mp:*current-process*) 34 | 35 | (defun threadp (object) 36 | (mp:processp object)) 37 | 38 | (defun thread-name (thread) 39 | (mp:process-name thread)) 40 | 41 | ;;; Resource contention: locks and recursive locks 42 | 43 | (deftype lock () 'mp::error-check-lock) 44 | 45 | (deftype recursive-lock () 'mp::recursive-lock) 46 | 47 | (defun lock-p (object) 48 | (typep object 'mp::error-check-lock)) 49 | 50 | (defun recursive-lock-p (object) 51 | (typep object 'mp::recursive-lock)) 52 | 53 | (defun make-lock (&optional name) 54 | (mp:make-lock (or name "Anonymous lock") 55 | :kind :error-check)) 56 | 57 | (defun acquire-lock (lock &optional (wait-p t)) 58 | (if wait-p 59 | (mp::lock-wait lock "Lock wait") 60 | (mp::lock-wait-with-timeout lock "Lock wait" 0))) 61 | 62 | (defun release-lock (lock) 63 | (setf (mp::lock-process lock) nil)) 64 | 65 | (defmacro with-lock-held ((place) &body body) 66 | `(mp:with-lock-held (,place "Lock wait") ,@body)) 67 | 68 | (defun make-recursive-lock (&optional name) 69 | (mp:make-lock (or name "Anonymous recursive lock") 70 | :kind :recursive)) 71 | 72 | (defun acquire-recursive-lock (lock &optional (wait-p t)) 73 | (acquire-lock lock)) 74 | 75 | (defun release-recursive-lock (lock) 76 | (release-lock lock)) 77 | 78 | (defmacro with-recursive-lock-held ((place &key timeout) &body body) 79 | `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) 80 | 81 | ;;; Note that the locks _are_ recursive, but not "balanced", and only 82 | ;;; checked if they are being held by the same process by with-lock-held. 83 | ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that 84 | ;;; it will wait for recursive locks by the same process as well. 85 | 86 | ;;; Resource contention: condition variables 87 | 88 | ;;; There's some stuff in x86-vm.lisp that might be worth investigating 89 | ;;; whether to build on. There's also process-wait and friends. 90 | 91 | (defstruct condition-var 92 | "CMUCL doesn't have conditions, so we need to create our own type." 93 | name 94 | lock 95 | active) 96 | 97 | (defun make-condition-variable (&key name) 98 | (make-condition-var :lock (make-lock) 99 | :name (or name "Anonymous condition variable"))) 100 | 101 | (defun condition-wait (condition-variable lock &key timeout) 102 | (signal-error-if-condition-wait-timeout timeout) 103 | (check-type condition-variable condition-var) 104 | (with-lock-held ((condition-var-lock condition-variable)) 105 | (setf (condition-var-active condition-variable) nil)) 106 | (release-lock lock) 107 | (mp:process-wait "Condition Wait" 108 | #'(lambda () (condition-var-active condition-variable))) 109 | (acquire-lock lock) 110 | t) 111 | 112 | (defun condition-notify (condition-variable) 113 | (check-type condition-variable condition-var) 114 | (with-lock-held ((condition-var-lock condition-variable)) 115 | (setf (condition-var-active condition-variable) t)) 116 | (thread-yield)) 117 | 118 | (defun thread-yield () 119 | (mp:process-yield)) 120 | 121 | ;;; Timeouts 122 | 123 | (defmacro with-timeout ((timeout) &body body) 124 | (once-only (timeout) 125 | `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) 126 | ,@body))) 127 | 128 | ;;; Introspection/debugging 129 | 130 | (defun all-threads () 131 | (mp:all-processes)) 132 | 133 | (defun interrupt-thread (thread function &rest args) 134 | (flet ((apply-function () 135 | (if args 136 | (lambda () (apply function args)) 137 | function))) 138 | (declare (dynamic-extent #'apply-function)) 139 | (mp:process-interrupt thread (apply-function)))) 140 | 141 | (defun destroy-thread (thread) 142 | (signal-error-if-current-thread thread) 143 | (mp:destroy-process thread)) 144 | 145 | (defun thread-alive-p (thread) 146 | (mp:process-active-p thread)) 147 | 148 | (defun join-thread (thread) 149 | #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 150 | (mp:process-join thread) 151 | #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 152 | (progn 153 | (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 154 | (lambda () (not (mp:process-alive-p thread)))) 155 | (let ((return-values 156 | (getf (mp:process-property-list thread) 'return-values))) 157 | (values-list return-values)))) 158 | 159 | (mark-supported) 160 | -------------------------------------------------------------------------------- /bordeaux-threads.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: ASDF -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | #.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) 5 | (error "You need ASDF >= 3.1 to load this system correctly.")) 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | #+(or armedbear 9 | (and allegro multiprocessing) 10 | (and clasp threads) 11 | (and clisp mt) 12 | (and openmcl openmcl-native-threads) 13 | (and cmu mp) 14 | corman 15 | (and ecl threads) 16 | genera 17 | mezzano 18 | mkcl 19 | lispworks 20 | (and digitool ccl-5.1) 21 | (and sbcl sb-thread) 22 | scl) 23 | (pushnew :thread-support *features*)) 24 | 25 | #-thread-support 26 | (error "This implementation is unsupported.") 27 | 28 | (defsystem :bordeaux-threads 29 | :author "Stelian Ionescu " 30 | :licence "MIT" 31 | :description "Bordeaux Threads makes writing portable multi-threaded apps simple." 32 | :version (:read-file-form "version.sexp") 33 | :depends-on (:alexandria :global-vars :trivial-features :trivial-garbage 34 | #+(and allegro (version>= 9)) (:require "smputil") 35 | #+(and allegro (not (version>= 9))) (:require "process") 36 | (:feature :corman (:require "threads"))) 37 | :components ((:static-file "version.sexp") 38 | (:module "api-v1" 39 | :pathname "apiv1/" 40 | :serial t 41 | :components 42 | ((:file "pkgdcl") 43 | (:file "bordeaux-threads") 44 | (:file "impl-abcl" :if-feature :armedbear) 45 | (:file "impl-allegro" :if-feature :allegro) 46 | (:file "impl-clasp" :if-feature :clasp) 47 | (:file "impl-clisp" :if-feature :clisp) 48 | (:file "impl-clozure" :if-feature :openmcl) 49 | (:file "impl-cmucl" :if-feature :cmu) 50 | (:file "impl-corman" :if-feature :corman) 51 | (:file "impl-ecl" :if-feature :ecl) 52 | (:file "impl-genera" :if-feature :genera) 53 | (:file "impl-mezzano" :if-feature :mezzano) 54 | (:file "impl-mkcl" :if-feature :mkcl) 55 | (:file "impl-lispworks" :if-feature :lispworks) 56 | (:file "impl-mcl" :if-feature :digitool) 57 | (:file "impl-sbcl" :if-feature :sbcl) 58 | (:file "impl-scl" :if-feature :scl) 59 | (:file "impl-lispworks-condition-variables" :if-feature (:and :lispworks 60 | (:or :lispworks4 :lispworks5))) 61 | (:file "condition-variables" :if-feature :digitool) 62 | (:file "default-implementations"))) 63 | (:module "api-v2" 64 | :pathname "apiv2/" 65 | :depends-on ("api-v1") 66 | :serial t 67 | :components 68 | ((:file "pkgdcl") 69 | (:file "bordeaux-threads") 70 | (:file "timeout-interrupt") 71 | (:file "impl-abcl" :if-feature :abcl) 72 | (:file "impl-allegro" :if-feature :allegro) 73 | (:file "impl-clasp" :if-feature :clasp) 74 | (:file "impl-clisp" :if-feature :clisp) 75 | (:file "impl-clozure" :if-feature :clozure) 76 | (:file "impl-cmucl" :if-feature :cmu) 77 | (:file "impl-corman" :if-feature :corman) 78 | (:file "impl-ecl" :if-feature :ecl) 79 | (:file "impl-genera" :if-feature :genera) 80 | (:file "impl-mezzano" :if-feature :mezzano) 81 | (:file "impl-mkcl" :if-feature :mkcl) 82 | (:file "impl-lispworks" :if-feature :lispworks) 83 | (:file "impl-mcl" :if-feature :digitool) 84 | (:file "impl-sbcl" :if-feature :sbcl) 85 | (:file "impl-scl" :if-feature :scl) 86 | (:file "atomics" :if-feature (:not :abcl)) 87 | (:file "atomics-java" :if-feature :abcl) 88 | (:file "api-locks") 89 | (:file "api-threads") 90 | (:file "api-semaphores") 91 | (:file "impl-condition-variables-semaphores" 92 | :if-feature :ccl) 93 | (:file "api-condition-variables")))) 94 | :in-order-to ((test-op (test-op :bordeaux-threads/test)))) 95 | 96 | (defsystem :bordeaux-threads/test 97 | :author "Stelian Ionescu " 98 | :description "Bordeaux Threads test suite." 99 | :licence "MIT" 100 | :version (:read-file-form "version.sexp") 101 | :depends-on (:bordeaux-threads :fiveam) 102 | :pathname "test/" 103 | :serial t 104 | :components ((:file "tests-v1") 105 | (:file "pkgdcl") 106 | (:file "not-implemented") 107 | (:file "tests-v2")) 108 | :perform (test-op (o c) 109 | (symbol-call :5am :run! :bordeaux-threads) 110 | (symbol-call :5am :run! :bordeaux-threads-2))) 111 | -------------------------------------------------------------------------------- /apiv2/api-locks.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*- 2 | ;;;; The above modeline is required for Genera. Do not change. 3 | 4 | (in-package :bordeaux-threads-2) 5 | 6 | (defun native-lock-p (object) 7 | (typep object 'native-lock)) 8 | 9 | (defclass lock () 10 | ((name :initarg :name :reader lock-name) 11 | (native-lock :initarg :native-lock :reader lock-native-lock)) 12 | (:documentation "Wrapper for a native non-recursive lock.")) 13 | 14 | (defmethod print-object ((lock lock) stream) 15 | (print-unreadable-object (lock stream :type t :identity t) 16 | (format stream "~S" (lock-name lock)))) 17 | 18 | (defun lockp (object) 19 | "Returns T if OBJECT is a non-recursive lock; returns NIL otherwise." 20 | (typep object 'lock)) 21 | 22 | (defun make-lock (&key name) 23 | "Creates a lock (a mutex) whose name is NAME." 24 | (check-type name (or null string)) 25 | (make-instance 'lock 26 | :name name 27 | :native-lock (%make-lock name))) 28 | 29 | (defun acquire-lock (lock &key (wait t) timeout) 30 | "Acquire the lock LOCK for the calling thread. 31 | 32 | WAIT governs what happens if the lock is not available: if WAIT 33 | is true, the calling thread will wait until the lock is available 34 | and then acquire it; if WAIT is NIL, ACQUIRE-LOCK will return 35 | immediately. 36 | 37 | If WAIT is true, TIMEOUT may specify a maximum amount of seconds to 38 | wait for the lock to become available. 39 | 40 | ACQUIRE-LOCK returns T if the lock was acquired and NIL 41 | otherwise. 42 | 43 | This specification does not define what happens if a thread 44 | attempts to acquire a lock that it already holds. For applications 45 | that require locks to be safe when acquired recursively, see instead 46 | MAKE-RECURSIVE-LOCK and friends." 47 | (check-type timeout (or null (real 0))) 48 | (%acquire-lock (lock-native-lock lock) (bool wait) timeout)) 49 | 50 | (defun release-lock (lock) 51 | "Release LOCK. It is an error to call this unless 52 | the lock has previously been acquired (and not released) by the same 53 | thread. If other threads are waiting for the lock, the 54 | ACQUIRE-LOCK call in one of them will now be able to continue. 55 | 56 | Returns the lock." 57 | (%release-lock (lock-native-lock lock)) 58 | lock) 59 | 60 | (defmacro with-lock-held ((place &key timeout) 61 | &body body &environment env) 62 | "Evaluates BODY with the lock named by PLACE, the value of which 63 | is a lock created by MAKE-LOCK. Before the forms in BODY are 64 | evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the 65 | forms in BODY have been evaluated, or if a non-local control transfer 66 | is caused (e.g. by THROW or SIGNAL), the lock is released as if by 67 | RELEASE-LOCK. 68 | 69 | Note that if the debugger is entered, it is unspecified whether the 70 | lock is released at debugger entry or at debugger exit when execution 71 | is restarted." 72 | (declare (ignorable place timeout)) 73 | (if (fboundp '%with-lock) 74 | (macroexpand-1 75 | `(%with-lock ((lock-native-lock ,place) ,timeout) 76 | ,@body) 77 | env) 78 | `(when (acquire-lock ,place :wait t :timeout ,timeout) 79 | (unwind-protect 80 | (locally ,@body) 81 | (release-lock ,place))))) 82 | 83 | (defun native-recursive-lock-p (object) 84 | (typep object 'native-recursive-lock)) 85 | 86 | (defclass recursive-lock () 87 | ((name :initarg :name :reader lock-name) 88 | (native-lock :initarg :native-lock :reader lock-native-lock)) 89 | (:documentation "Wrapper for a native recursive lock.")) 90 | 91 | (defmethod print-object ((lock recursive-lock) stream) 92 | (print-unreadable-object (lock stream :type t :identity t) 93 | (format stream "~S" (lock-name lock)))) 94 | 95 | (defun recursive-lock-p (object) 96 | "Returns T if OBJECT is a recursive lock; returns NIL otherwise." 97 | (typep object 'recursive-lock)) 98 | 99 | (defun make-recursive-lock (&key name) 100 | "Create and return a recursive lock whose name is NAME. 101 | 102 | A recursive lock differs from an ordinary lock in that a thread that 103 | already holds the recursive lock can acquire it again without 104 | blocking. The thread must then release the lock twice before it 105 | becomes available for another thread (acquire and release operations 106 | must be balanced)." 107 | (check-type name (or null string)) 108 | (make-instance 'recursive-lock 109 | :name name 110 | :native-lock (%make-recursive-lock name))) 111 | 112 | (defun acquire-recursive-lock (lock &key (wait t) timeout) 113 | "Acquire the lock LOCK for the calling thread. 114 | 115 | WAIT governs what happens if the lock is not available: if WAIT is 116 | true, the calling thread will wait until the lock is available and 117 | then acquire it; if WAIT is NIL, ACQUIRE-RECURSIVE-LOCK will return 118 | immediately. 119 | 120 | If WAIT is true, TIMEOUT may specify a maximum amount of seconds to 121 | wait for the lock to become available. 122 | 123 | ACQUIRE-LOCK returns true if the lock was acquired and NIL 124 | otherwise. 125 | 126 | This operation will return immediately if the lock is already owned 127 | by the current thread. Acquire and release operations must be 128 | balanced." 129 | (check-type lock recursive-lock) 130 | (check-type timeout (or null (real 0))) 131 | (%acquire-recursive-lock (lock-native-lock lock) (bool wait) timeout)) 132 | 133 | (defun release-recursive-lock (lock) 134 | "Release LOCK. It is an error to call this unless 135 | the lock has previously been acquired (and not released) by the same 136 | thread. 137 | 138 | Returns the lock." 139 | (%release-recursive-lock (lock-native-lock lock)) 140 | lock) 141 | 142 | (defmacro with-recursive-lock-held ((place &key timeout) 143 | &body body &environment env) 144 | "Evaluates BODY with the recursive lock named by PLACE, which is a 145 | reference to a recursive lock created by MAKE-RECURSIVE-LOCK. 146 | See WITH-LOCK-HELD." 147 | (declare (ignorable place timeout)) 148 | (if (fboundp '%with-recursive-lock) 149 | (macroexpand-1 150 | `(%with-recursive-lock ((lock-native-lock ,place) ,timeout) 151 | ,@body) 152 | env) 153 | `(when (acquire-recursive-lock ,place :wait t :timeout ,timeout) 154 | (unwind-protect 155 | (locally ,@body) 156 | (release-recursive-lock ,place))))) 157 | --------------------------------------------------------------------------------