ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

46
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/.travis.yml Normal file
View file

@ -0,0 +1,46 @@
language: lisp
env:
matrix:
- LISP=allegro
- LISP=ccl
- LISP=ccl32
- LISP=sbcl
- LISP=sbcl32
- LISP=abcl
- LISP=cmucl
- LISP=ecl
matrix:
allow_failures:
- env: LISP=abcl
- env: LISP=cmucl
- env: LISP=ecl
notifications:
email:
on_success: change
on_failure: always
irc:
channels:
- "chat.freenode.net#iolib"
on_success: change
on_failure: always
use_notice: true
skip_join: true
install:
- curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh
- cl -e "(cl:in-package :cl-user)
(dolist (p '(:fiveam))
(ql:quickload p :verbose t))"
script:
- cl -e "(cl:in-package :cl-user)
(prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri)
(ql:quickload :bordeaux-threads/test :verbose t)
(uiop:quit (if (some (lambda (x) (typep x '5am::test-failure))
(5am:run :bordeaux-threads))
1 0))"
sudo: required

19
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/CONTRIBUTORS Normal file
View file

@ -0,0 +1,19 @@
-*- outline -*-
Based on original Bordeaux-MP spec by Dan Barlow <dan@telent.net>
Contributors:
* Attila Lendvai <attila.lendvai@gmail.com>
- better handling of unsupported Lisps
* Vladimir Sekissov <svg@surnet.ru>
- fixes for CMUCL implementation
* Pierre Thierry <nowhere.man@levallois.eu.org>
- added license information
* Stelian Ionescu <sionescu@cddr.org>
- finished conversion from generic functions
- enabled running thread-safe code in unthreaded lisps
* Douglas Crosher <dtc@scieneer.com>
- added Scieneer Common Lisp support
* Daniel Kochmański <daniel@turtleware.eu>
- semaphores implementation

20
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/LICENSE Normal file
View file

@ -0,0 +1,20 @@
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

2
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/README Normal file
View file

@ -0,0 +1,2 @@
You can find API documentation on the project's wiki:
http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation

76
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/bordeaux-threads.asd Normal file
View file

@ -0,0 +1,76 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
#|
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version)))
(error "You need ASDF >= 3.1 to load this system correctly."))
(eval-when (:compile-toplevel :load-toplevel :execute)
#+(or armedbear
(and allegro multiprocessing)
(and clasp threads)
(and clisp mt)
(and openmcl openmcl-native-threads)
(and cmu mp)
corman
(and ecl threads)
genera
mkcl
lispworks
(and digitool ccl-5.1)
(and sbcl sb-thread)
scl)
(pushnew :thread-support *features*))
(defsystem :bordeaux-threads
:author "Greg Pfeil <greg@technomadic.org>"
:licence "MIT"
:description "Bordeaux Threads makes writing portable multi-threaded apps simple."
:version (:read-file-form "version.sexp")
:depends-on (:alexandria
#+(and allegro (version>= 9)) (:require "smputil")
#+(and allegro (not (version>= 9))) (:require "process")
#+corman (:require "threads"))
:components ((:static-file "version.sexp")
(:module "src"
:serial t
:components
((:file "pkgdcl")
(:file "bordeaux-threads")
(:file #+(and thread-support armedbear) "impl-abcl"
#+(and thread-support allegro) "impl-allegro"
#+(and thread-support clasp) "impl-clasp"
#+(and thread-support clisp) "impl-clisp"
#+(and thread-support openmcl) "impl-clozure"
#+(and thread-support cmu) "impl-cmucl"
#+(and thread-support corman) "impl-corman"
#+(and thread-support ecl) "impl-ecl"
#+(and thread-support genera) "impl-genera"
#+(and thread-support mkcl) "impl-mkcl"
#+(and thread-support lispworks) "impl-lispworks"
#+(and thread-support digitool) "impl-mcl"
#+(and thread-support sbcl) "impl-sbcl"
#+(and thread-support scl) "impl-scl"
#-thread-support "impl-null")
#+(and thread-support lispworks (or lispworks4 lispworks5))
(:file "impl-lispworks-condition-variables")
#+(and thread-support digitool)
(:file "condition-variables")
(:file "default-implementations")))))
(defsystem :bordeaux-threads/test
:author "Greg Pfeil <greg@technomadic.org>"
:description "Bordeaux Threads test suite."
:licence "MIT"
:version (:read-file-form "version.sexp")
:depends-on (:bordeaux-threads :fiveam)
:components ((:module "test"
:components ((:file "bordeaux-threads-test")))))
(defmethod perform ((o test-op) (c (eql (find-system :bordeaux-threads))))
(load-system :bordeaux-threads/test)
(symbol-call :5am :run! :bordeaux-threads))

55
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/site/index.html Normal file
View file

@ -0,0 +1,55 @@
<?xml version="1.0"?>
<!--
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
-->
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>Bordeaux Threads project</title>
<link rel="stylesheet" type="text/css" href="style.css"/>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
</head>
<body>
<div class="header">
<h1>Bordeaux Threads</h1>
<h2>Portable shared-state concurrency for Common Lisp</h2>
</div>
<p>Based on an original proposal by Dan Barlow (Bordeaux-MP) this
library is meant to make writing portable multi-threaded apps
simple.</p>
<p>Read the current <a href="http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation">API documentation</a>.</p>
<p>Supports all major Common Lisp implementations: SBCL, CCL,
Lispworks, Allegro, ABCL, ECL, Clisp.<br/> The MKCL, Corman,
MCL and Scieneer backends are not tested frequently(if ever) and
might not work.</p>
<p>For discussion, use the mailing
list <a href="http://www.common-lisp.net/mailman/listinfo/bordeaux-threads-devel">bordeaux-threads-devel</a>
or the #lisp IRC channel on Freenode.</p>
<h3>Source repository</h3>
<p>Bordeaux-threads is developed
at <a href="https://github.com/sionescu/bordeaux-threads">Github</a>. The
repository is also mirrored
to <a href="https://gitlab.com/bordeaux-threads/bordeaux-threads">Gitlab</a>
and <a href="https://bitbucket.org/sionescu/bordeaux-threads">Bitbucket</a>.</p>
<div class="footer">
<a href="mailto:sionescu@cddr.org">Stelian Ionescu</a>. Last modified: <!--#flastmod file="index.shtml" -->
</div>
<div class="check">
<a href="http://validator.w3.org/check/referer">Valid XHTML 1.0 Strict</a>
</div>
</body>
</html>

86
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/site/style.css Normal file
View file

@ -0,0 +1,86 @@
/*
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
*/
tbody {
border-top: thin dotted black;
}
.failure {
background-color: #ff0;
}
.nonexistant {
background-color: #ccc;
}
.perfect {
background-color: #0f0;
}
.error {
background-color: #f00;
}
.header {
font-size: medium;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 5px;
border-color:#002244;
padding: 1mm 1mm 1mm 5mm;
}
.footer {
font-size: small;
font-style: italic;
text-align: right;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 2px;
border-color:#002244;
padding: 1mm 1mm 1mm 1mm;
}
.footer a:link {
font-weight:bold;
color:#ffffff;
background-color: #336699;
text-decoration:underline;
}
.footer a:visited {
font-weight:bold;
color:#ffffff;
background-color: #336699;
text-decoration:underline;
}
.footer a:hover {
font-weight:bold;
color:#002244;
background-color: #336699;
text-decoration:underline; }
.check {font-size: x-small;
text-align:right;}
.check a:link { font-weight:bold;
color:#a0a0ff;
background-color: #FFFFFF;
text-decoration:underline; }
.check a:visited { font-weight:bold;
color:#a0a0ff;
background-color: #FFFFFF;
text-decoration:underline; }
.check a:hover { font-weight:bold;
color:#000000;
background-color: #FFFFFF;
text-decoration:underline; }

170
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/bordeaux-threads.lisp Normal file
View file

@ -0,0 +1,170 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(defvar *supports-threads-p* nil
"This should be set to T if the running instance has thread support.")
(defun mark-supported ()
(setf *supports-threads-p* t)
(pushnew :bordeaux-threads *features*))
(define-condition bordeaux-mp-condition (error)
((message :initarg :message :reader message))
(:report (lambda (condition stream)
(format stream (message condition)))))
(defgeneric make-threading-support-error ()
(:documentation "Creates a BORDEAUX-THREADS condition which specifies
whether there is no BORDEAUX-THREADS support for the implementation, no
threads enabled for the system, or no support for a particular
function.")
(:method ()
(make-condition
'bordeaux-mp-condition
:message (if *supports-threads-p*
"There is no support for this method on this implementation."
"There is no thread support in this instance."))))
;;; Timeouts
#-sbcl
(define-condition timeout (serious-condition)
((length :initform nil
:initarg :length
:reader timeout-length))
(:report (lambda (c s)
(if (timeout-length c)
(format s "A timeout set to ~A seconds occurred."
(timeout-length c))
(format s "A timeout occurred.")))))
#-sbcl
(defmacro with-timeout ((timeout) &body body)
"Execute `BODY' and signal a condition of type TIMEOUT if the execution of
BODY does not complete within `TIMEOUT' seconds. On implementations which do not
support WITH-TIMEOUT natively and don't support threads either it has no effect."
(declare (ignorable timeout body))
#+thread-support
(let ((ok-tag (gensym "OK"))
(timeout-tag (gensym "TIMEOUT"))
(caller (gensym "CALLER")))
(once-only (timeout)
`(multiple-value-prog1
(catch ',ok-tag
(catch ',timeout-tag
(let ((,caller (current-thread)))
(make-thread #'(lambda ()
(sleep ,timeout)
(interrupt-thread ,caller
#'(lambda ()
(ignore-errors
(throw ',timeout-tag nil)))))
:name (format nil "WITH-TIMEOUT thread serving: ~S."
(thread-name ,caller)))
(throw ',ok-tag (progn ,@body))))
(error 'timeout :length ,timeout)))))
#-thread-support
`(error (make-threading-support-error)))
;;; Semaphores
;;; We provide this structure definition unconditionally regardless of the fact
;;; it may not be used not to prevent warnings from compiling default functions
;;; for semaphore in default-implementations.lisp.
(defstruct %semaphore
lock
condition-variable
counter)
#-(or ccl sbcl)
(deftype semaphore ()
'%semaphore)
;;; Thread Creation
;;; See default-implementations.lisp for MAKE-THREAD.
;; Forms are evaluated in the new thread or in the calling thread?
(defvar *default-special-bindings* nil
"This variable holds an alist associating special variable symbols
to forms to evaluate. Special variables named in this list will
be locally bound in the new thread before it begins executing user code.
This variable may be rebound around calls to MAKE-THREAD to
add/alter default bindings. The effect of mutating this list is
undefined, but earlier forms take precedence over later forms for
the same symbol, so defaults may be overridden by consing to the
head of the list.")
(defmacro defbindings (name docstring &body initforms)
(check-type docstring string)
`(defparameter ,name
(list
,@(loop for (special form) in initforms
collect `(cons ',special ',form)))
,docstring))
;; Forms are evaluated in the new thread or in the calling thread?
(defbindings *standard-io-bindings*
"Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
(*package* (find-package :common-lisp-user))
(*print-array* t)
(*print-base* 10)
(*print-case* :upcase)
(*print-circle* nil)
(*print-escape* t)
(*print-gensym* t)
(*print-length* nil)
(*print-level* nil)
(*print-lines* nil)
(*print-miser-width* nil)
(*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-pretty* nil)
(*print-radix* nil)
(*print-readably* t)
(*print-right-margin* nil)
(*random-state* (make-random-state t))
(*read-base* 10)
(*read-default-float-format* 'single-float)
(*read-eval* t)
(*read-suppress* nil)
(*readtable* (copy-readtable nil)))
(defun binding-default-specials (function special-bindings)
"Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
FUNCTION."
(let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
(lambda ()
(progv (mapcar #'car specials)
(loop for (nil . form) in specials collect (eval form))
(funcall function)))))
;;; FIXME: This test won't work if CURRENT-THREAD
;;; conses a new object each time
(defun signal-error-if-current-thread (thread)
(when (eq thread (current-thread))
(error 'bordeaux-mp-condition
:message "Cannot destroy the current thread")))
(defparameter *no-condition-wait-timeout-message*
"CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")
(defun signal-error-if-condition-wait-timeout (timeout)
(when timeout
(error 'bordeaux-mp-condition
:message *no-condition-wait-timeout-message*)))
(defmacro define-condition-wait-compiler-macro ()
`(define-compiler-macro condition-wait
(&whole whole condition-variable lock &key timeout)
(declare (ignore condition-variable lock))
(when timeout
(simple-style-warning *no-condition-wait-timeout-message*))
whole))

38
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/condition-variables.lisp Normal file
View file

@ -0,0 +1,38 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; This file provides a portable implementation of condition
;;; variables (given a working WITH-LOCK-HELD and THREAD-YIELD), and
;;; should be used if there is no condition variable implementation in
;;; the host Lisp.
(defstruct condition-var
name
lock
active)
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(check-type condition-variable condition-var)
(setf (condition-var-active condition-variable) nil)
(release-lock lock)
(do ()
((when (condition-var-active condition-variable)
(acquire-lock lock)
t))
(thread-yield))
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) t)))

361
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/default-implementations.lisp Normal file
View file

@ -0,0 +1,361 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)
;;; Helper macros
(defmacro defdfun (name args doc &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',name)
(defun ,name ,args ,@body))
(setf (documentation ',name 'function)
(or (documentation ',name 'function) ,doc))))
(defmacro defdmacro (name args doc &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',name)
(defmacro ,name ,args ,@body))
(setf (documentation ',name 'function)
(or (documentation ',name 'function) ,doc))))
;;; Thread Creation
(defdfun start-multiprocessing ()
"If the host implementation uses user-level threads, start the
scheduler and multiprocessing, otherwise do nothing.
It is safe to call repeatedly."
nil)
(defdfun make-thread (function &key name
(initial-bindings *default-special-bindings*))
"Creates and returns a thread named NAME, which will call the
function FUNCTION with no arguments: when FUNCTION returns, the
thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied.
On systems that do not support multi-threading, MAKE-THREAD will
signal an error.
The interaction between threads and dynamic variables is in some
cases complex, and depends on whether the variable has only a global
binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
or has been bound locally (e.g. with LET or LET*) in the calling
thread.
- Global bindings are shared between threads: the initial value of a
global variable in the new thread will be the same as in the
parent, and an assignment to such a variable in any thread will be
visible to all threads in which the global binding is visible.
- Local bindings, such as the ones introduced by INITIAL-BINDINGS,
are local to the thread they are introduced in, except that
- Local bindings in the the caller of MAKE-THREAD may or may not be
shared with the new thread that it creates: this is
implementation-defined. Portable code should not depend on
particular behaviour in this case, nor should it assign to such
variables without first rebinding them in the new thread."
(%make-thread (binding-default-specials function initial-bindings)
(or name "Anonymous thread")))
(defdfun %make-thread (function name)
"The actual implementation-dependent function that creates threads."
(declare (ignore function name))
(error (make-threading-support-error)))
(defdfun current-thread ()
"Returns the thread object for the calling
thread. This is the same kind of object as would be returned by
MAKE-THREAD."
nil)
(defdfun threadp (object)
"Returns true if object is a thread, otherwise NIL."
(declare (ignore object))
nil)
(defdfun thread-name (thread)
"Returns the name of the thread, as supplied to MAKE-THREAD."
(declare (ignore thread))
"Main thread")
;;; Resource contention: locks and recursive locks
(defdfun lock-p (object)
"Returns T if OBJECT is a lock; returns NIL otherwise."
(declare (ignore object))
nil)
(defdfun recursive-lock-p (object)
"Returns T if OBJECT is a recursive lock; returns NIL otherwise."
(declare (ignore object))
nil)
(defdfun make-lock (&optional name)
"Creates a lock (a mutex) whose name is NAME. If the system does not
support multiple threads this will still return some object, but it
may not be used for very much."
;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if
;; there's some good reason it should be said structure or that it
;; be freshly consed - EQ comparison of locks?
(declare (ignore name))
(list nil))
(defdfun acquire-lock (lock &optional wait-p)
"Acquire the lock LOCK for the calling thread.
WAIT-P governs what happens if the lock is not available: if WAIT-P
is true, the calling thread will wait until the lock is available
and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return
immediately. ACQUIRE-LOCK returns true if the lock was acquired and
NIL otherwise.
This specification does not define what happens if a thread
attempts to acquire a lock that it already holds. For applications
that require locks to be safe when acquired recursively, see instead
MAKE-RECURSIVE-LOCK and friends."
(declare (ignore lock wait-p))
t)
(defdfun release-lock (lock)
"Release LOCK. It is an error to call this unless
the lock has previously been acquired (and not released) by the same
thread. If other threads are waiting for the lock, the
ACQUIRE-LOCK call in one of them will now be able to continue.
This function has no interesting return value."
(declare (ignore lock))
(values))
(defdmacro with-lock-held ((place) &body body)
"Evaluates BODY with the lock named by PLACE, the value of which
is a lock created by MAKE-LOCK. Before the forms in BODY are
evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
forms in BODY have been evaluated, or if a non-local control transfer
is caused (e.g. by THROW or SIGNAL), the lock is released as if by
RELEASE-LOCK.
Note that if the debugger is entered, it is unspecified whether the
lock is released at debugger entry or at debugger exit when execution
is restarted."
`(when (acquire-lock ,place t)
(unwind-protect
(locally ,@body)
(release-lock ,place))))
(defdfun make-recursive-lock (&optional name)
"Create and return a recursive lock whose name is NAME. A recursive
lock differs from an ordinary lock in that a thread that already
holds the recursive lock can acquire it again without blocking. The
thread must then release the lock twice before it becomes available
for another thread."
(declare (ignore name))
(list nil))
(defdfun acquire-recursive-lock (lock)
"As for ACQUIRE-LOCK, but for recursive locks."
(declare (ignore lock))
t)
(defdfun release-recursive-lock (lock)
"Release the recursive LOCK. The lock will only
become free after as many Release operations as there have been
Acquire operations. See RELEASE-LOCK for other information."
(declare (ignore lock))
(values))
(defdmacro with-recursive-lock-held ((place &key timeout) &body body)
"Evaluates BODY with the recursive lock named by PLACE, which is a
reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See
WITH-LOCK-HELD etc etc"
(declare (ignore timeout))
`(when (acquire-recursive-lock ,place)
(unwind-protect
(locally ,@body)
(release-recursive-lock ,place))))
;;; Resource contention: condition variables
;;; A condition variable provides a mechanism for threads to put
;;; themselves to sleep while waiting for the state of something to
;;; change, then to be subsequently woken by another thread which has
;;; changed the state.
;;;
;;; A condition variable must be used in conjunction with a lock to
;;; protect access to the state of the object of interest. The
;;; procedure is as follows:
;;;
;;; Suppose two threads A and B, and some kind of notional event
;;; channel C. A is consuming events in C, and B is producing them.
;;; CV is a condition-variable
;;;
;;; 1) A acquires the lock that safeguards access to C
;;; 2) A threads and removes all events that are available in C
;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically
;;; releases the lock and puts A to sleep on CV
;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again
;;; before returning
;;; 5) Loop back to step 2, for as long as threading should continue
;;;
;;; When B generates an event E, it
;;; 1) acquires the lock guarding C
;;; 2) adds E to the channel
;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread
;;; 4) releases the lock
;;;
;;; To avoid the "lost wakeup" problem, the implementation must
;;; guarantee that CONDITION-WAIT in thread A atomically releases the
;;; lock and sleeps. If this is not guaranteed there is the
;;; possibility that thread B can add an event and call
;;; CONDITION-NOTIFY between the lock release and the sleep - in this
;;; case the notify call would not see A, which would be left sleeping
;;; despite there being an event available.
(defdfun thread-yield ()
"Allows other threads to run. It may be necessary or desirable to
call this periodically in some implementations; others may schedule
threads automatically. On systems that do not support
multi-threading, this does nothing."
(values))
(defdfun make-condition-variable (&key name)
"Returns a new condition-variable object for use
with CONDITION-WAIT and CONDITION-NOTIFY."
(declare (ignore name))
nil)
(defdfun condition-wait (condition-variable lock &key timeout)
"Atomically release LOCK and enqueue the calling
thread waiting for CONDITION-VARIABLE. The thread will resume when
another thread has notified it using CONDITION-NOTIFY; it may also
resume if interrupted by some external event or in other
implementation-dependent circumstances: the caller must always test
on waking that there is threading to be done, instead of assuming
that it can go ahead.
It is an error to call function this unless from the thread that
holds LOCK.
If TIMEOUT is nil or not provided, the system always reacquires LOCK
before returning to the caller. In this case T is returned.
If TIMEOUT is non-nil, the call will return after at most TIMEOUT
seconds (approximately), whether or not a notification has occurred.
Either NIL or T will be returned. A return of NIL indicates that the
lock is no longer held and that the timeout has expired. A return of
T indicates that the lock is held, in which case the timeout may or
may not have expired.
**NOTE**: The behavior of CONDITION-WAIT with TIMEOUT diverges from
the POSIX function pthread_cond_timedwait. The former may return
without the lock being held while the latter always returns with the
lock held.
In an implementation that does not support multiple threads, this
function signals an error."
(declare (ignore condition-variable lock timeout))
(error (make-threading-support-error)))
(defdfun condition-notify (condition-variable)
"Notify at least one of the threads waiting for
CONDITION-VARIABLE. It is implementation-dependent whether one or
more than one (and possibly all) threads are woken, but if the
implementation is capable of waking only a single thread (not all
are) this is probably preferable for efficiency reasons. The order
of wakeup is unspecified and does not necessarily relate to the
order that the threads went to sleep in.
CONDITION-NOTIFY has no useful return value. In an implementation
that does not support multiple threads, it has no effect."
(declare (ignore condition-variable))
(values))
;;; Resource contention: semaphores
(defdfun make-semaphore (&key name (count 0))
"Create a semaphore with the supplied NAME and initial counter value COUNT."
(make-%semaphore :lock (make-lock name)
:condition-variable (make-condition-variable :name name)
:counter count))
(defdfun signal-semaphore (semaphore &key (count 1))
"Increment SEMAPHORE by COUNT. If there are threads waiting on this
semaphore, then COUNT of them are woken up."
(with-lock-held ((%semaphore-lock semaphore))
(incf (%semaphore-counter semaphore) count)
(dotimes (v count)
(condition-notify (%semaphore-condition-variable semaphore))))
(values))
(defdfun wait-on-semaphore (semaphore &key timeout)
"Decrement the count of SEMAPHORE by 1 if the count would not be negative.
Else blocks until the semaphore can be decremented. Returns generalized boolean
T on success.
If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
cannot be decremented in that time, returns NIL without decrementing the count."
(with-lock-held ((%semaphore-lock semaphore))
(if (>= (%semaphore-counter semaphore) 1)
(decf (%semaphore-counter semaphore))
(let ((deadline (when timeout
(+ (get-internal-real-time)
(* timeout internal-time-units-per-second)))))
;; we need this loop because of a spurious wakeup possibility
(loop until (>= (%semaphore-counter semaphore) 1)
do (cond
((null (condition-wait (%semaphore-condition-variable semaphore)
(%semaphore-lock semaphore)
:timeout timeout))
(return-from wait-on-semaphore))
;; unfortunately cv-wait may return T on timeout too
((and deadline (>= (get-internal-real-time) deadline))
(return-from wait-on-semaphore))
(timeout
(setf timeout (/ (- deadline (get-internal-real-time))
internal-time-units-per-second)))))
(decf (%semaphore-counter semaphore))))))
(defdfun semaphore-p (object)
"Returns T if OBJECT is a semaphore; returns NIL otherwise."
(typep object 'semaphore))
;;; Introspection/debugging
;;; The following functions may be provided for debugging purposes,
;;; but are not advised to be called from normal user code.
(defdfun all-threads ()
"Returns a sequence of all of the threads. This may not
be freshly-allocated, so the caller should not modify it."
(error (make-threading-support-error)))
(defdfun interrupt-thread (thread function)
"Interrupt THREAD and cause it to evaluate FUNCTION
before continuing with the interrupted path of execution. This may
not be a good idea if THREAD is holding locks or doing anything
important. On systems that do not support multiple threads, this
function signals an error."
(declare (ignore thread function))
(error (make-threading-support-error)))
(defdfun destroy-thread (thread)
"Terminates the thread THREAD, which is an object
as returned by MAKE-THREAD. This should be used with caution: it is
implementation-defined whether the thread runs cleanup forms or
releases its locks first.
Destroying the calling thread is an error."
(declare (ignore thread))
(error (make-threading-support-error)))
(defdfun thread-alive-p (thread)
"Returns true if THREAD is alive, that is, if
DESTROY-THREAD has not been called on it."
(declare (ignore thread))
(error (make-threading-support-error)))
(defdfun join-thread (thread)
"Wait until THREAD terminates. If THREAD has already terminated,
return immediately. The return values of the thread function are
returned."
(declare (ignore thread))
(error (make-threading-support-error)))

150
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-abcl.lisp Normal file
View file

@ -0,0 +1,150 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; the implementation of the Armed Bear thread interface can be found in
;;; src/org/armedbear/lisp/LispThread.java
(deftype thread ()
'threads:thread)
;;; Thread Creation
(defun %make-thread (function name)
(threads:make-thread function :name name))
(defun current-thread ()
(threads:current-thread))
(defun thread-name (thread)
(threads:thread-name thread))
(defun threadp (object)
(typep object 'thread))
;;; Resource contention: locks and recursive locks
(defstruct mutex name lock)
(defstruct (mutex-recursive (:include mutex)))
;; Making methods constants in this manner avoids the runtime expense of
;; introspection involved in JCALL with string arguments.
(defconstant +lock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
(defconstant +try-lock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
(defconstant +is-held-by-current-thread+
(jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
(defconstant +unlock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
(defconstant +get-hold-count+
(jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
(deftype lock () 'mutex)
(deftype recursive-lock () 'mutex-recursive)
(defun lock-p (object)
(typep object 'mutex))
(defun recursive-lock-p (object)
(typep object 'mutex-recursive))
(defun make-lock (&optional name)
(make-mutex
:name (or name "Anonymous lock")
:lock (jnew "java.util.concurrent.locks.ReentrantLock")))
(defun acquire-lock (lock &optional (wait-p t))
(check-type lock mutex)
(when (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Non-recursive lock being reacquired by owner."))
(cond
(wait-p
(jcall +lock+ (mutex-lock lock))
t)
(t (jcall +try-lock+ (mutex-lock lock)))))
(defun release-lock (lock)
(check-type lock mutex)
(unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Attempt to release lock not held by calling thread."))
(jcall +unlock+ (mutex-lock lock))
(values))
(defun make-recursive-lock (&optional name)
(make-mutex-recursive
:name (or name "Anonymous lock")
:lock (jnew "java.util.concurrent.locks.ReentrantLock")))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(check-type lock mutex-recursive)
(cond
(wait-p
(jcall +lock+ (mutex-recursive-lock lock))
t)
(t (jcall +try-lock+ (mutex-recursive-lock lock)))))
(defun release-recursive-lock (lock)
(check-type lock mutex-recursive)
(unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Attempt to release lock not held by calling thread."))
(jcall +unlock+ (mutex-lock lock))
(values))
;;; Resource contention: condition variables
(defun thread-yield ()
(java:jstatic "yield" "java.lang.Thread"))
(defstruct condition-variable
(name "Anonymous condition variable"))
(defun condition-wait (condition lock &key timeout)
(threads:synchronized-on condition
(release-lock lock)
(if timeout
;; Since giving a zero time value to threads:object-wait means
;; an indefinite wait, use some arbitrary small number.
(threads:object-wait condition
(if (zerop timeout)
least-positive-single-float
timeout))
(threads:object-wait condition)))
(acquire-lock lock)
t)
(defun condition-notify (condition)
(threads:synchronized-on condition
(threads:object-notify condition)))
;;; Introspection/debugging
(defun all-threads ()
(let ((threads ()))
(threads:mapcar-threads (lambda (thread)
(push thread threads)))
(reverse threads)))
(defun interrupt-thread (thread function &rest args)
(apply #'threads:interrupt-thread thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(threads:destroy-thread thread))
(defun thread-alive-p (thread)
(threads:thread-alive-p thread))
(defun join-thread (thread)
(threads:thread-join thread))
(mark-supported)

143
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-allegro.lisp Normal file
View file

@ -0,0 +1,143 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the Allegro Multiprocessing interface can be found at
;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:process-lock)
(deftype recursive-lock () 'mp:process-lock)
(defun lock-p (object)
(typep object 'mp:process-lock))
(defun recursive-lock-p (object)
(typep object 'mp:process-lock))
(defun make-lock (&optional name)
(mp:make-process-lock :name (or name "Anonymous lock")))
(defun make-recursive-lock (&optional name)
(mp:make-process-lock :name (or name "Anonymous recursive lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0)))
(defun release-lock (lock)
(mp:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-process-lock (,place :norecursive t)
,@body))
(defmacro with-recursive-lock-held ((place &key timeout) &body body)
`(mp:with-process-lock (,place :timeout ,timeout)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignorable name))
#-(version>= 9)
(mp:make-gate nil)
#+(version>= 9)
(mp:make-condition-variable :name name))
(defun condition-wait (condition-variable lock &key timeout)
#-(version>= 9)
(progn
(release-lock lock)
(if timeout
(mp:process-wait-with-timeout "wait for message" timeout
#'mp:gate-open-p condition-variable)
(mp:process-wait "wait for message" #'mp:gate-open-p condition-variable))
(acquire-lock lock)
(mp:close-gate condition-variable))
#+(version>= 9)
(mp:condition-variable-wait condition-variable lock :timeout timeout)
t)
(defun condition-notify (condition-variable)
#-(version>= 9)
(mp:open-gate condition-variable)
#+(version>= 9)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-allow-schedule))
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp:start-scheduler))
(defun %make-thread (function name)
#+smp
(mp:process-run-function name function)
#-smp
(mp:process-run-function
name
(lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (getf (mp:process-property-list mp:*current-process*)
'return-values)
return-values)
(values-list return-values)))))
(defun current-thread ()
mp:*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
(defun all-threads ()
mp:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(apply #'mp:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(defun join-thread (thread)
#+smp
(values-list (mp:process-join thread))
#-smp
(progn
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(complement #'mp:process-alive-p)
thread)
(let ((return-values
(getf (mp:process-property-list thread) 'return-values)))
(values-list return-values))))
(mark-supported)

111
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clasp.lisp Normal file
View file

@ -0,0 +1,111 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the ECL Multiprocessing interface can be found at
;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun %make-thread (function name)
(mp:process-run-function name function bordeaux-threads:*default-special-bindings*))
(defun current-thread ()
mp:*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:mutex)
(deftype recursive-lock ()
'(and mp:mutex (satisfies mp:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mp:mutex))
(defun recursive-lock-p (object)
(and (typep object 'mp:lock)
(mp:recursive-lock-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name :anonymous)))
(defun acquire-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-lock (lock)
(mp:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-recursive-mutex (or name :anonymous-recursive-lock)))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mp:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mp:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(mp:condition-variable-timedwait condition-variable lock timeout)
(mp:condition-variable-wait condition-variable lock))
t)
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:interrupt-process thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
(mp:process-join thread))
(mark-supported)

105
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clisp.lisp Normal file
View file

@ -0,0 +1,105 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mt:thread)
;;; Thread Creation
(defun %make-thread (function name)
(mt:make-thread function
:name name
:initial-bindings mt:*default-special-bindings*))
(defun current-thread ()
(mt:current-thread))
(defun threadp (object)
(mt:threadp object))
(defun thread-name (thread)
(mt:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mt:mutex)
(deftype recursive-lock ()
'(and mt:mutex (satisfies mt:mutex-recursive-p)))
(defun lock-p (object)
(typep object 'mt:mutex))
(defun recursive-lock-p (object)
(and (typep object 'mt:mutex)
(mt:mutex-recursive-p object)))
(defun make-lock (&optional name)
(mt:make-mutex :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mt:mutex-lock lock :timeout (if wait-p nil 0)))
(defun release-lock (lock)
(mt:mutex-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mt:with-mutex-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mt:make-mutex :name (or name "Anonymous recursive lock")
:recursive-p t))
(defmacro with-recursive-lock-held ((place) &body body)
`(mt:with-mutex-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(mt:make-exemption :name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(mt:exemption-wait condition-variable lock :timeout timeout)
t)
(defun condition-notify (condition-variable)
(mt:exemption-signal condition-variable))
(defun thread-yield ()
(mt:thread-yield))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
(defun all-threads ()
(delete-if-not #'mt:thread-active-p (mt:list-threads)))
(defun interrupt-thread (thread function &rest args)
(mt:thread-interrupt thread :function function :arguments args))
(defun destroy-thread (thread)
;;; VTZ: actually we can kill ourselelf.
;;; suicide is part of our contemporary life :)
(signal-error-if-current-thread thread)
(mt:thread-interrupt thread :function t))
(defun thread-alive-p (thread)
(mt:thread-active-p thread))
(defun join-thread (thread)
(mt:thread-join thread))
(mark-supported)

130
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clozure.lisp Normal file
View file

@ -0,0 +1,130 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the OpenMCL Threads interface can be found at
;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html
(deftype thread ()
'ccl:process)
;;; Thread Creation
(defun %make-thread (function name)
(ccl:process-run-function name function))
(defun current-thread ()
ccl:*current-process*)
(defun threadp (object)
(typep object 'ccl:process))
(defun thread-name (thread)
(ccl:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'ccl:lock)
(deftype recursive-lock () 'ccl:lock)
(defun lock-p (object)
(typep object 'ccl:lock))
(defun recursive-lock-p (object)
(typep object 'ccl:lock))
(defun make-lock (&optional name)
(ccl:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(ccl:grab-lock lock)
(ccl:try-lock lock)))
(defun release-lock (lock)
(ccl:release-lock lock))
(defmacro with-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place)
,@body))
(defun make-recursive-lock (&optional name)
(ccl:make-lock (or name "Anonymous recursive lock")))
(defun acquire-recursive-lock (lock)
(ccl:grab-lock lock))
(defun release-recursive-lock (lock)
(ccl:release-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(ccl:make-semaphore))
(defun condition-wait (condition-variable lock &key timeout)
(release-lock lock)
(unwind-protect
(if timeout
(ccl:timed-wait-on-semaphore condition-variable timeout)
(ccl:wait-on-semaphore condition-variable))
(acquire-lock lock t))
t)
(defun condition-notify (condition-variable)
(ccl:signal-semaphore condition-variable))
(defun thread-yield ()
(ccl:process-allow-schedule))
;;; Semaphores
(deftype semaphore ()
'ccl:semaphore)
(defun make-semaphore (&key name (count 0))
(declare (ignore name))
(let ((semaphore (ccl:make-semaphore)))
(dotimes (c count) (ccl:signal-semaphore semaphore))
semaphore))
(defun signal-semaphore (semaphore &key (count 1))
(dotimes (c count) (ccl:signal-semaphore semaphore)))
(defun wait-on-semaphore (semaphore &key timeout)
(if timeout
(ccl:timed-wait-on-semaphore semaphore timeout)
(ccl:wait-on-semaphore semaphore)))
;;; Introspection/debugging
(defun all-threads ()
(ccl:all-processes))
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'ccl:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(ccl:process-kill thread))
(defun thread-alive-p (thread)
(not (ccl:process-exhausted-p thread)))
(defun join-thread (thread)
(ccl:join-process thread))
(mark-supported)

161
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-cmucl.lisp Normal file
View file

@ -0,0 +1,161 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mp::process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp::startup-idle-and-top-level-loops))
(defun %make-thread (function name)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:make-process function :name name)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:make-process (lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (getf (mp:process-property-list mp:*current-process*)
'return-values)
return-values)
(values-list return-values)))
:name name))
(defun current-thread ()
mp:*current-process*)
(defmethod threadp (object)
(mp:processp object))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp::error-check-lock)
(deftype recursive-lock () 'mp::recursive-lock)
(defun lock-p (object)
(typep object 'mp::error-check-lock))
(defun recursive-lock-p (object)
(typep object 'mp::recursive-lock))
(defun make-lock (&optional name)
(mp:make-lock (or name "Anonymous lock")
:kind :error-check))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(mp::lock-wait lock "Lock wait")
(mp::lock-wait-with-timeout lock "Lock wait" 0)))
(defun release-lock (lock)
(setf (mp::lock-process lock) nil))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock-held (,place "Lock wait") ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock (or name "Anonymous recursive lock")
:kind :recursive))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(acquire-lock lock))
(defun release-recursive-lock (lock)
(release-lock lock))
(defmacro with-recursive-lock-held ((place &key timeout) &body body)
`(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body))
;;; Note that the locks _are_ recursive, but not "balanced", and only
;;; checked if they are being held by the same process by with-lock-held.
;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
;;; it will wait for recursive locks by the same process as well.
;;; Resource contention: condition variables
;;; There's some stuff in x86-vm.lisp that might be worth investigating
;;; whether to build on. There's also process-wait and friends.
(defstruct condition-var
"CMUCL doesn't have conditions, so we need to create our own type."
name
lock
active)
(defun make-condition-variable (&key name)
(make-condition-var :lock (make-lock)
:name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) nil))
(release-lock lock)
(mp:process-wait "Condition Wait"
#'(lambda () (condition-var-active condition-variable)))
(acquire-lock lock)
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) t))
(thread-yield))
(defun thread-yield ()
(mp:process-yield))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:process-interrupt thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:destroy-process thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-join thread)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(progn
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(lambda () (not (mp:process-alive-p thread))))
(let ((return-values
(getf (mp:process-property-list thread) 'return-values)))
(values-list return-values))))
(mark-supported)

26
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-corman.lisp Normal file
View file

@ -0,0 +1,26 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; Thread Creation
(defun %make-thread (function name)
(declare (ignore name))
(threads:create-thread function))
(defun current-thread ()
threads:*current-thread*)
;;; Introspection/debugging
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(threads:terminate-thread thread))
(mark-supported)

111
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-ecl.lisp Normal file
View file

@ -0,0 +1,111 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the ECL Multiprocessing interface can be found at
;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun %make-thread (function name)
(mp:process-run-function name function))
(defun current-thread ()
mp::*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:lock)
(deftype recursive-lock ()
'(and mp:lock (satisfies mp:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mp:lock))
(defun recursive-lock-p (object)
(and (typep object 'mp:lock)
(mp:recursive-lock-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-lock (lock)
(mp:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock :name (or name "Anonymous recursive lock") :recursive t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mp:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mp:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(handler-case (with-timeout (timeout)
(mp:condition-variable-wait condition-variable lock))
(timeout () nil))
(mp:condition-variable-wait condition-variable lock)))
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:interrupt-process thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
(mp:process-join thread))
(mark-supported)

136
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-genera.lisp Normal file
View file

@ -0,0 +1,136 @@
;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*-
#|
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'process:process)
;;; Thread Creation
(defun %make-thread (function name)
(process:process-run-function name function))
(defun current-thread ()
scl:*current-process*)
(defun threadp (object)
(process:process-p object))
(defun thread-name (thread)
(process:process-name thread))
;;; Resource contention: locks and recursive locks
(defstruct (lock (:constructor make-lock-internal))
lock
lock-argument)
(defun make-lock (&optional name)
(let ((lock (process:make-lock (or name "Anonymous lock"))))
(make-lock-internal :lock lock
:lock-argument nil)))
(defun acquire-lock (lock &optional (wait-p t))
(check-type lock lock)
(setf (lock-lock-argument lock) (process:make-lock-argument (lock-lock lock)))
(if wait-p
(process:lock (lock-lock lock) (lock-lock-argument lock))
(process:with-no-other-processes
(when (process:lock-lockable-p (lock-lock lock))
(process:lock (lock-lock lock) (lock-lock-argument lock))))))
(defun release-lock (lock)
(check-type lock lock)
(process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil)))
(defmacro with-lock-held ((place) &body body)
`(process:with-lock ((lock-lock ,place))
,@body))
(defstruct (recursive-lock (:constructor make-recursive-lock-internal))
lock
lock-arguments)
(defun make-recursive-lock (&optional name)
(make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock")
:recursive t)
:lock-arguments nil))
(defun acquire-recursive-lock (lock)
(check-type lock recursive-lock)
(process:lock (recursive-lock-lock lock)
(car (push (process:make-lock-argument (recursive-lock-lock lock))
(recursive-lock-lock-arguments lock)))))
(defun release-recursive-lock (lock)
(check-type lock recursive-lock)
(process:unlock (recursive-lock-lock lock) (pop (recursive-lock-lock-arguments lock))))
(defmacro with-recursive-lock-held ((place) &body body)
`(process:with-lock ((recursive-lock-lock ,place))
,@body))
;;; Resource contention: condition variables
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (condition-variable (:constructor %make-condition-variable))
name
(waiters nil))
)
(defun make-condition-variable (&key name)
(%make-condition-variable :name name))
(defun condition-wait (condition-variable lock)
(check-type condition-variable condition-variable)
(check-type lock lock)
(process:with-no-other-processes
(let ((waiter (cons scl:*current-process* nil)))
(process:atomic-updatef (condition-variable-waiters condition-variable)
#'(lambda (waiters)
(append waiters (scl:ncons waiter))))
(process:without-lock ((lock-lock lock))
(process:process-block (format nil "Waiting~@[ on ~A~]"
(condition-variable-name condition-variable))
#'(lambda (waiter)
(not (null (cdr waiter))))
waiter)))))
(defun condition-notify (condition-variable)
(check-type condition-variable condition-variable)
(let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable))))
(when waiter
(setf (cdr waiter) t)
(process:wakeup (car waiter))))
(values))
(defun thread-yield ()
(scl:process-allow-schedule))
;;; Introspection/debugging
(defun all-threads ()
process:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'process:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(process:process-kill thread :without-aborts :force))
(defun thread-alive-p (thread)
(process:process-active-p thread))
(defun join-thread (thread)
(process:process-wait (format nil "Join ~S" thread)
#'(lambda (thread)
(not (process:process-active-p thread)))
thread))
(mark-supported)

144
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-lispworks-condition-variables.lisp Normal file
View file

@ -0,0 +1,144 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)
;; Lispworks condition support is simulated, albeit via a lightweight wrapper over
;; its own polling-based wait primitive. Waiters register with the condition variable,
;; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval.
;; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm
;; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup
;; on every poll (or have to serialize on the condition variable) and a mechanism is put
;; in place to unregister any waiter that exits wait for other reasons,
;; and to resend any (single) notification that may have been consumed before this (corner
;; case). Much of the complexity present is to support single notification (as recommended in
;; the spec); but a distinct condition-notify-all is provided for reference.
;; Single-notification follows a first-in first-out ordering
;;
;; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least
;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager.
;; While not true zero like a true native solution, the use of the Lispworks native checks appear
;; fast enough to be an equivalent substitute (thread count will cause issue before the
;; waiting overhead becomes significant)
(defstruct (condition-variable (:constructor make-lw-condition (name)))
name
(lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t)
(wait-tlist (cons nil nil) :type cons :read-only t)
(wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t)
;; unconsumed-notifications is to track :remove-from-consideration
;; for entries that may have exited prematurely - notification is sent through
;; to someone else, and offender is removed from hash and list
(unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t))
(defun make-condition-variable (&key name)
(make-lw-condition name))
(defmacro with-cv-access (condition-variable &body body)
(let ((cv-sym (gensym))
(slots '(lock wait-tlist wait-hash unconsumed-notifications)))
`(let ((,cv-sym ,condition-variable))
(with-slots ,slots
,cv-sym
(macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body)))
(labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore
,@body)))))
(defmacro defcvfun (function-name (condition-variable &rest args) &body body)
`(defun ,function-name (,condition-variable ,@args)
(with-cv-access ,condition-variable
,@body)))
#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun
; utility function thath assumes process is locked on condition-variable's lock.
(defcvfun do-notify-single (condition-variable) ; assumes already locked
(let ((id (caar wait-tlist)))
(when id
(pop (car wait-tlist))
(unless (car wait-tlist) ; check for empty
(setf (cdr wait-tlist) nil))
(funcall (gethash id wait-hash)) ; call waiter-wakeup
(remhash id wait-hash) ; absence of entry = permission to proceed
(setf (gethash id unconsumed-notifications) t))))
;; Added for completeness/to show how it's done in this paradigm; but
;; The symbol for this call is not exposed in the api
(defcvfun condition-notify-all (condition-variable)
(locked
(loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup))
(clrhash wait-hash)
(clrhash unconsumed-notifications) ; don't care as everyone just got notified
(setf (car wait-tlist) nil)
(setf (cdr wait-tlist) nil)))
;; Currently implemented so as to notify only one waiting thread
(defcvfun condition-notify (condition-variable)
(locked (do-notify-single condition-variable)))
(defun delete-from-tlist (tlist element)
(let ((deleter
(lambda ()
(setf (car tlist) (cdar tlist))
(unless (car tlist)
(setf (cdr tlist) nil)))))
(loop for cons in (car tlist) do
(if (eq element (car cons))
(progn
(funcall deleter)
(return nil))
(let ((cons cons))
(setq deleter
(lambda ()
(setf (cdr cons) (cddr cons))
(unless (cdr cons)
(setf (cdr tlist) cons)))))))))
(defun add-to-tlist-tail (tlist element)
(let ((new-link (cons element nil)))
(cond
((car tlist)
(setf (cddr tlist) new-link)
(setf (cdr tlist) new-link))
(t
(setf (car tlist) new-link)
(setf (cdr tlist) new-link)))))
(defcvfun condition-wait (condition-variable lock- &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(mp:process-unlock lock-)
(unwind-protect ; for the re-taking of the lock. Guarding all of the code
(let ((wakeup-allowed-to-proceed nil)
(wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait")))
;; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and
;; search the hashtable. That it is locked is for safety/completeness, although
;; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is
;; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became
;; non-atomic in its assigments
(let ((id (cons nil nil))
(clean-exit nil))
(locked
(add-to-tlist-tail wait-tlist id)
(setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t)))))
(unwind-protect
(progn
(mp:process-wait
"Waiting for notification"
(lambda ()
(when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed)
(locked (not (gethash id wait-hash))))))
(locked (remhash id unconsumed-notifications))
(setq clean-exit t)) ; Notification was consumed
;; Have to call remove-from-consideration just in case process was interrupted
;; rather than having condition met
(unless clean-exit ; clean-exit is just an optimization
(locked
(when (gethash id wait-hash) ; not notified - must have been interrupted
;; Have to unsubscribe
(remhash id wait-hash)
(delete-from-tlist wait-tlist id))
;; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification!
(when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification
(remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter
(do-notify-single condition-variable)))))))
(mp:process-lock lock-))
t)
(define-condition-wait-compiler-macro)

143
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-lispworks.lisp Normal file
View file

@ -0,0 +1,143 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the LispWorks Multiprocessing interface can be found at
;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp:initialize-multiprocessing))
(defun %make-thread (function name)
(mp:process-run-function
name nil
(lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (mp:process-property 'return-values)
return-values)
(values-list return-values)))))
(defun current-thread ()
#-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
mp:*current-process*
;; introduced in LispWorks 5.1
#+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
(mp:get-current-process))
(defun threadp (object)
(mp:process-p object))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:lock)
#-(or lispworks4 lispworks5)
(deftype recursive-lock ()
'(and mp:lock (satisfies mp:lock-recursive-p)))
(defun lock-p (object)
(typep object 'mp:lock))
(defun recursive-lock-p (object)
#+(or lispworks4 lispworks5)
nil
#-(or lispworks4 lispworks5) ; version 6+
(and (typep object 'mp:lock)
(mp:lock-recursive-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name "Anonymous lock")
#-(or lispworks4 lispworks5) :recursivep
#-(or lispworks4 lispworks5) nil))
(defun acquire-lock (lock &optional (wait-p t))
(mp:process-lock lock nil
(cond ((null wait-p) 0)
((numberp wait-p) wait-p)
(t nil))))
(defun release-lock (lock)
(mp:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock :name (or name "Anonymous recursive lock")
#-(or lispworks4 lispworks5) :recursivep
#-(or lispworks4 lispworks5) t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(acquire-lock lock wait-p))
(defun release-recursive-lock (lock)
(release-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
#+(or lispworks6 lispworks7)
(defun make-condition-variable (&key name)
(mp:make-condition-variable :name (or name "Anonymous condition variable")))
#+(or lispworks6 lispworks7)
(defun condition-wait (condition-variable lock &key timeout)
(mp:condition-variable-wait condition-variable lock :timeout timeout)
t)
#+(or lispworks6 lispworks7)
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-allow-scheduling))
;;; Introspection/debugging
(defun all-threads ()
(mp:list-all-processes))
(defun interrupt-thread (thread function &rest args)
(apply #'mp:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(declaim (inline %join-thread))
(defun %join-thread (thread)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(complement #'mp:process-alive-p)
thread)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-join thread))
(defun join-thread (thread)
(%join-thread thread)
(let ((return-values
(mp:process-property 'return-values thread)))
(values-list return-values)))
(mark-supported)

68
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-mcl.lisp Normal file
View file

@ -0,0 +1,68 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'ccl::process)
;;; Thread Creation
(defun %make-thread (function name)
(ccl:process-run-function name function))
(defun current-thread ()
ccl:*current-process*)
(defun threadp (object)
(ccl::processp object))
(defun thread-name (thread)
(ccl:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'ccl:lock)
(defun lock-p (object)
(typep object 'ccl:lock))
(defun make-lock (&optional name)
(ccl:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(ccl:process-lock lock ccl:*current-process*)
;; this is broken, but it's better than a no-op
(ccl:without-interrupts
(when (null (ccl::lock.value lock))
(ccl:process-lock lock ccl:*current-process*)))))
(defun release-lock (lock)
(ccl:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place) ,@body))
(defun thread-yield ()
(ccl:process-allow-schedule))
;;; Introspection/debugging
(defun all-threads ()
ccl:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'ccl:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(ccl:process-kill thread))
(mark-supported)

109
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-mkcl.lisp Normal file
View file

@ -0,0 +1,109 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Copyright 2010 Jean-Claude Beaudoin.
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mt:thread)
;;; Thread Creation
(defun %make-thread (function name)
(mt:thread-run-function name function))
(defun current-thread ()
mt::*thread*)
(defun threadp (object)
(typep object 'mt:thread))
(defun thread-name (thread)
(mt:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mt:lock)
(deftype recursive-lock ()
'(and mt:lock (satisfies mt:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mt:lock))
(defun recursive-lock-p (object)
(and (typep object 'mt:lock)
(mt:recursive-lock-p object)))
(defun make-lock (&optional name)
(mt:make-lock :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mt:get-lock lock wait-p))
(defun release-lock (lock)
(mt:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mt:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mt:make-lock :name (or name "Anonymous recursive lock") :recursive t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mt:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mt:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mt:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mt:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(mt:condition-wait condition-variable lock)
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(mt:condition-signal condition-variable))
(defun thread-yield ()
(mt:thread-yield))
;;; Introspection/debugging
(defun all-threads ()
(mt:all-threads))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mt:interrupt-thread thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mt:thread-kill thread))
(defun thread-alive-p (thread)
(mt:thread-active-p thread))
(defun join-thread (thread)
(mt:thread-join thread))
(mark-supported)

3
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-null.lisp Normal file
View file

@ -0,0 +1,3 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)

130
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-sbcl.lisp Normal file
View file

@ -0,0 +1,130 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the SBCL Threads interface can be found at
;;; http://www.sbcl.org/manual/Threading.html
(deftype thread ()
'sb-thread:thread)
;;; Thread Creation
(defun %make-thread (function name)
(sb-thread:make-thread function :name name))
(defun current-thread ()
sb-thread:*current-thread*)
(defun threadp (object)
(typep object 'sb-thread:thread))
(defun thread-name (thread)
(sb-thread:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'sb-thread:mutex)
(deftype recursive-lock () 'sb-thread:mutex)
(defun lock-p (object)
(typep object 'sb-thread:mutex))
(defun recursive-lock-p (object)
(typep object 'sb-thread:mutex))
(defun make-lock (&optional name)
(sb-thread:make-mutex :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
#+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
(sb-thread:grab-mutex lock :waitp wait-p)
#-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
(sb-thread:get-mutex lock nil wait-p))
(defun release-lock (lock)
(sb-thread:release-mutex lock))
(defmacro with-lock-held ((place) &body body)
`(sb-thread:with-mutex (,place) ,@body))
(defun make-recursive-lock (&optional name)
(sb-thread:make-mutex :name (or name "Anonymous recursive lock")))
;;; XXX acquire-recursive-lock and release-recursive-lock are actually
;;; complicated because we can't use control stack tricks. We need to
;;; actually count something to check that the acquire/releases are
;;; balanced
(defmacro with-recursive-lock-held ((place) &body body)
`(sb-thread:with-recursive-lock (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(sb-thread:make-waitqueue :name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(sb-thread:condition-wait condition-variable lock :timeout timeout))
(defun condition-notify (condition-variable)
(sb-thread:condition-notify condition-variable))
(defun thread-yield ()
(sb-thread:release-foreground))
;;; Timeouts
(deftype timeout ()
'sb-ext:timeout)
(defmacro with-timeout ((timeout) &body body)
`(sb-ext:with-timeout ,timeout
,@body))
;;; Semaphores
(deftype semaphore ()
'sb-thread:semaphore)
(defun make-semaphore (&key name (count 0))
(sb-thread:make-semaphore :name name :count count))
(defun signal-semaphore (semaphore &key (count 1))
(sb-thread:signal-semaphore semaphore count))
(defun wait-on-semaphore (semaphore &key timeout)
(sb-thread:wait-on-semaphore semaphore :timeout timeout))
;;; Introspection/debugging
(defun all-threads ()
(sb-thread:list-all-threads))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(sb-thread:interrupt-thread thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(sb-thread:terminate-thread thread))
(defun thread-alive-p (thread)
(sb-thread:thread-alive-p thread))
(defun join-thread (thread)
(sb-thread:join-thread thread))
(mark-supported)

103
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-scl.lisp Normal file
View file

@ -0,0 +1,103 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2008 Scieneer Pty Ltd
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'thread:thread)
(defun %make-thread (function name)
(thread:thread-create function :name name))
(defun current-thread ()
thread:*thread*)
(defun threadp (object)
(typep object 'thread:thread))
(defun thread-name (thread)
(thread:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'thread:lock)
(deftype recursive-lock () 'thread:recursive-lock)
(defun lock-p (object)
(typep object 'thread:lock))
(defun recursive-lock-p (object)
(typep object 'thread:recursive-lock))
(defun make-lock (&optional name)
(thread:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(thread::acquire-lock lock nil wait-p))
(defun release-lock (lock)
(thread::release-lock lock))
(defmacro with-lock-held ((place) &body body)
`(thread:with-lock-held (,place) ,@body))
(defun make-recursive-lock (&optional name)
(thread:make-lock (or name "Anonymous recursive lock")
:type :recursive))
;;; XXX acquire-recursive-lock and release-recursive-lock are actually
;;; complicated because we can't use control stack tricks. We need to
;;; actually count something to check that the acquire/releases are
;;; balanced
(defmacro with-recursive-lock-held ((place) &body body)
`(thread:with-lock-held (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(thread:make-cond-var (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(thread:cond-var-timedwait condition-variable lock timeout)
(thread:cond-var-wait condition-variable lock))
t)
(defun condition-notify (condition-variable)
(thread:cond-var-broadcast condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(thread:thread-interrupt thread (apply-function))))
(defun destroy-thread (thread)
(thread:destroy-thread thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(defun join-thread (thread)
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(lambda () (not (mp:process-alive-p thread)))))
(mark-supported)

66
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/pkgdcl.lisp Normal file
View file

@ -0,0 +1,66 @@
;;;; -*- indent-tabs-mode: nil -*-
(cl:defpackage :bordeaux-threads
(:nicknames #:bt)
(:use #:cl #:alexandria)
#+abcl
(:import-from :java #:jnew #:jcall #:jmethod)
(:export #:thread #:make-thread #:current-thread #:threadp #:thread-name
#:start-multiprocessing
#:*default-special-bindings* #:*standard-io-bindings*
#:*supports-threads-p*
#:lock #:make-lock #:lock-p
#:acquire-lock #:release-lock #:with-lock-held
#:recursive-lock #:make-recursive-lock #:recursive-lock-p
#:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held
#:make-condition-variable #:condition-wait #:condition-notify
#:make-semaphore #:signal-semaphore #:wait-on-semaphore #:semaphore #:semaphore-p
#:with-timeout #:timeout
#:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
#:join-thread #:thread-yield)
(:documentation "BORDEAUX-THREADS is a proposed standard for a minimal
MP/threading interface. It is similar to the CLIM-SYS threading and
lock support, but for the following broad differences:
1) Some behaviours are defined in additional detail: attention has
been given to special variable interaction, whether and when
cleanup forms are run. Some behaviours are defined in less
detail: an implementation that does not support multiple
threads is not required to use a new list (nil) for a lock, for
example.
2) Many functions which would be difficult, dangerous or inefficient
to provide on some implementations have been removed. Chiefly
these are functions such as thread-wait which expect for
efficiency that the thread scheduler is written in Lisp and
'hookable', which can't sensibly be done if the scheduler is
external to the Lisp image, or the system has more than one CPU.
3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been
added.
4) Posix-style condition variables have been added, as it's not
otherwise possible to implement them correctly using the other
operations that are specified.
Threads may be implemented using whatever applicable techniques are
provided by the operating system: user-space scheduling,
kernel-based LWPs or anything else that does the job.
Some parts of this specification can also be implemented in a Lisp
that does not support multiple threads. Thread creation and some
thread inspection operations will not work, but the locking
functions are still present (though they may do nothing) so that
thread-safe code can be compiled on both multithread and
single-thread implementations without need of conditionals.
To avoid conflict with existing MP/threading interfaces in
implementations, these symbols live in the BORDEAUX-THREADS package.
Implementations and/or users may also make them visible or exported
in other more traditionally named packages."))

251
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/test/bordeaux-threads-test.lisp Normal file
View file

@ -0,0 +1,251 @@
#|
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(defpackage bordeaux-threads/test
(:use #:cl #:bordeaux-threads #:fiveam)
(:shadow #:with-timeout))
(in-package #:bordeaux-threads/test)
(def-suite :bordeaux-threads)
(def-fixture using-lock ()
(let ((lock (make-lock)))
(&body)))
(in-suite :bordeaux-threads)
(test should-have-current-thread
(is (current-thread)))
(test current-thread-identity
(let* ((box (list nil))
(thread (make-thread (lambda ()
(setf (car box) (current-thread))))))
(join-thread thread)
(is (eql (car box) thread))))
(test join-thread-return-value
(is (eql 0 (join-thread (make-thread (lambda () 0))))))
(test should-identify-threads-correctly
(is (threadp (current-thread)))
(is (threadp (make-thread (lambda () t) :name "foo")))
(is (not (threadp (make-lock)))))
(test should-retrieve-thread-name
(is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo")))))
(test interrupt-thread
(let* ((box (list nil))
(thread (make-thread (lambda ()
(setf (car box)
(catch 'new-thread
(sleep 60)
'not-interrupted))))))
(sleep 1)
(interrupt-thread thread (lambda ()
(throw 'new-thread 'interrupted)))
(join-thread thread)
(is (eql 'interrupted (car box)))))
(test should-lock-without-contention
(with-fixture using-lock ()
(is (acquire-lock lock t))
(release-lock lock)
(is (acquire-lock lock nil))
(release-lock lock)))
(defun set-equal (set-a set-b)
(and (null (set-difference set-a set-b))
(null (set-difference set-b set-a))))
(test default-special-bindings
(locally (declare (special *a* *c*))
(let* ((the-as 50) (the-bs 150) (*b* 42)
some-a some-b some-other-a some-other-b
(*default-special-bindings*
`((*a* . (funcall ,(lambda () (incf the-as))))
(*b* . (funcall ,(lambda () (incf the-bs))))
,@*default-special-bindings*))
(threads (list (make-thread
(lambda ()
(setf some-a *a* some-b *b*)))
(make-thread
(lambda ()
(setf some-other-a *a*
some-other-b *b*))))))
(declare (special *b*))
(thread-yield)
(is (not (boundp '*a*)))
(loop while (some #'thread-alive-p threads)
do (thread-yield))
(is (set-equal (list some-a some-other-a) '(51 52)))
(is (set-equal (list some-b some-other-b) '(151 152)))
(is (not (boundp '*a*))))))
(defparameter *shared* 0)
(defparameter *lock* (make-lock))
(test should-have-thread-interaction
;; this simple test generates N process. Each process grabs and
;; releases the lock until SHARED has some value, it then
;; increments SHARED. the outer code first sets shared 1 which
;; gets the thing running and then waits for SHARED to reach some
;; value. this should, i think, stress test locks.
(setf *shared* 0)
(flet ((worker (i)
(loop
do (with-lock-held (*lock*)
(when (= i *shared*)
(incf *shared*)
(return)))
(thread-yield)
(sleep 0.001))))
(let* ((procs (loop
for i from 1 upto 2
;; create a new binding to protect against implementations that
;; mutate instead of binding the loop variable
collect (let ((i i))
(make-thread (lambda ()
(funcall #'worker i))
:name (format nil "Proc #~D" i))))))
(with-lock-held (*lock*)
(incf *shared*))
(block test
(loop
until (with-lock-held (*lock*)
(= (1+ (length procs)) *shared*))
do (with-lock-held (*lock*)
(is (>= (1+ (length procs)) *shared*)))
(thread-yield)
(sleep 0.001))))))
(defparameter *condition-variable* (make-condition-variable))
(test condition-variable
(setf *shared* 0)
(flet ((worker (i)
(with-lock-held (*lock*)
(loop
until (= i *shared*)
do (condition-wait *condition-variable* *lock*))
(incf *shared*))
(condition-notify *condition-variable*)))
(let ((num-procs 100))
(dotimes (i num-procs)
;; create a new binding to protect against implementations that
;; mutate instead of binding the loop variable
(let ((i i))
(make-thread (lambda ()
(funcall #'worker i))
:name (format nil "Proc #~D" i))))
(with-lock-held (*lock*)
(loop
until (= num-procs *shared*)
do (condition-wait *condition-variable* *lock*)))
(is (equal num-procs *shared*)))))
;; Generally safe sanity check for the locks and single-notify
#+(and lispworks (not lispworks6))
(test condition-variable-lw
(let ((condition-variable (make-condition-variable :name "Test"))
(test-lock (make-lock))
(completed nil))
(dotimes (id 6)
(let ((id id))
(make-thread (lambda ()
(with-lock-held (test-lock)
(condition-wait condition-variable test-lock)
(push id completed)
(condition-notify condition-variable))))))
(sleep 2)
(if completed
(print "Failed: Premature passage through condition-wait")
(print "Successfully waited on condition"))
(condition-notify condition-variable)
(sleep 2)
(if (and completed
(eql (length completed) 6)
(equal (sort completed #'<)
(loop for id from 0 to 5 collect id)))
(print "Success: All elements notified")
(print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed)))
(bt::with-cv-access condition-variable
(if (and
(not (or (car wait-tlist) (cdr wait-tlist)))
(zerop (hash-table-count wait-hash))
(zerop (hash-table-count unconsumed-notifications)))
(print "Success: condition variable restored to initial state")
(print "Error: condition variable retains residue from completed waiters")))
(setq completed nil)
(dotimes (id 6)
(let ((id id))
(make-thread (lambda ()
(with-lock-held (test-lock)
(condition-wait condition-variable test-lock)
(push id completed))))))
(sleep 2)
(condition-notify condition-variable)
(sleep 2)
(if (= (length completed) 1)
(print "Success: Notify-single only notified a single waiter to restart")
(format t "Failure: Notify-single restarted ~A items" (length completed)))
(condition-notify condition-variable)
(sleep 2)
(if (= (length completed) 2)
(print "Success: second Notify-single only notified a single waiter to restart")
(format t "Failure: Two Notify-singles restarted ~A items" (length completed)))
(loop for i from 0 to 5 do (condition-notify condition-variable))
(print "Note: In the case of any failures, assume there are outstanding waiting threads")
(values)))
#+(or abcl allegro clisp clozure ecl lispworks6 sbcl scl)
(test condition-wait-timeout
(let ((lock (make-lock))
(cvar (make-condition-variable))
(flag nil))
(make-thread (lambda () (sleep 0.4) (setf flag t)))
(with-lock-held (lock)
(condition-wait cvar lock :timeout 0.2)
(is (null flag))
(sleep 0.4)
(is (eq t flag)))))
(test semaphore-signal
(let ((sem (make-semaphore)))
(make-thread (lambda () (sleep 0.4) (signal-semaphore sem)))
(is (not (null (wait-on-semaphore sem))))))
(test semaphore-signal-n-of-m
(let* ((sem (make-semaphore :count 1))
(lock (make-lock))
(count 0)
(waiter (lambda ()
(wait-on-semaphore sem)
(with-lock-held (lock) (incf count)))))
(make-thread (lambda () (sleep 0.2) (signal-semaphore sem :count 3)))
(dotimes (v 5) (make-thread waiter))
(sleep 0.3)
(is (= count 4))
;; release other waiters
(signal-semaphore sem :count 10)
(sleep 0.1)
(is (= count 5))))
(test semaphore-wait-timeout
(let ((sem (make-semaphore))
(flag nil))
(make-thread (lambda () (sleep 0.4) (setf flag t)))
(is (null (wait-on-semaphore sem :timeout 0.2)))
(is (null flag))
(sleep 0.4)
(is (eq t flag))))
(test semaphore-typed
(is (typep (bt:make-semaphore) 'bt:semaphore))
(is (bt:semaphore-p (bt:make-semaphore)))
(is (null (bt:semaphore-p (bt:make-lock)))))

2
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/version.sexp Normal file
View file

@ -0,0 +1,2 @@
;; -*- lisp -*-
"0.8.7"