Don't DEFINE-CONDITION TIMEOUT on SBCL.
[bordeaux-threads:bordeaux-threads.git] / src / bordeaux-threads.lisp
1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; 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 (defpackage bordeaux-threads
10   (:nicknames #:bt)
11   (:use #:cl)
12   #+sbcl (:import-from #:sb-ext #:timeout)
13   (:export #:make-thread #:current-thread #:threadp #:thread-name
14            #:*default-special-bindings* #:*standard-io-bindings*
15            #:*supports-threads-p*
16
17            #:make-lock #:acquire-lock #:release-lock #:with-lock-held
18            #:make-recursive-lock #:acquire-recursive-lock
19            #:release-recursive-lock #:with-recursive-lock-held
20
21            #:make-condition-variable #:condition-wait #:condition-notify
22            #:thread-yield
23
24            #:with-timeout #:timeout
25
26            #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
27            #:join-thread)
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
69 (in-package #:bordeaux-threads)
70
71 (defvar *supports-threads-p* nil
72   "This should be set to T if the running instance has thread support.")
73
74 (defun mark-supported ()
75   (setf *supports-threads-p* t)
76   (pushnew :bordeaux-threads *features*))
77
78 (define-condition bordeaux-mp-condition (error)
79   ((message :initarg :message :reader message))
80   (:report (lambda (condition stream)
81              (format stream (message condition)))))
82
83 (defgeneric make-threading-support-error ()
84   (:documentation "Creates a BORDEAUX-THREADS condition which specifies
85   whether there is no BORDEAUX-THREADS support for the implementation, no
86   threads enabled for the system, or no support for a particular
87   function.")
88   (:method ()
89     (make-condition
90      'bordeaux-mp-condition
91      :message (if *supports-threads-p*
92                   "There is no support for this method on this implementation."
93                   "There is no thread support in this instance."))))
94
95 #-sbcl
96 (define-condition timeout (serious-condition) ())
97
98 ;;; Thread Creation
99
100 ;;; See default-implementations.lisp for MAKE-THREAD.
101
102 ;; Forms are evaluated in the new thread or in the calling thread?
103 (defvar *default-special-bindings* nil
104   "This variable holds an alist associating special variable symbols
105   to forms to evaluate. Special variables named in this list will
106   be locally bound in the new thread before it begins executing user code.
107
108   This variable may be rebound around calls to MAKE-THREAD to
109   add/alter default bindings. The effect of mutating this list is
110   undefined, but earlier forms take precedence over later forms for
111   the same symbol, so defaults may be overridden by consing to the
112   head of the list.")
113
114 (defmacro defbindings (name docstring &body initforms)
115   (check-type docstring string)
116   `(defparameter ,name
117      (list
118       ,@(loop for (special form) in initforms
119               collect `(cons ',special ',form)))
120      ,docstring))
121
122 ;; Forms are evaluated in the new thread or in the calling thread?
123 (defbindings *standard-io-bindings*
124   "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
125   (*package*                   (find-package :common-lisp-user))
126   (*print-array*               t)
127   (*print-base*                10)
128   (*print-case*                :upcase)
129   (*print-circle*              nil)
130   (*print-escape*              t)
131   (*print-gensym*              t)
132   (*print-length*              nil)
133   (*print-level*               nil)
134   (*print-lines*               nil)
135   (*print-miser-width*         nil)
136   (*print-pprint-dispatch*     (copy-pprint-dispatch nil))
137   (*print-pretty*              nil)
138   (*print-radix*               nil)
139   (*print-readably*            t)
140   (*print-right-margin*        nil)
141   (*read-base*                 10)
142   (*read-default-float-format* 'single-float)
143   (*read-eval*                 t)
144   (*read-suppress*             nil)
145   (*readtable*                 (copy-readtable nil)))
146
147 (defun binding-default-specials (function special-bindings)
148   "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
149 FUNCTION."
150   (let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
151     (lambda ()
152       (progv (mapcar #'car specials)
153           (loop for (nil . form) in specials collect (eval form))
154         (funcall function)))))
155
156 ;;; FIXME: This test won't work if CURRENT-THREAD
157 ;;;        conses a new object each time
158 (defun signal-error-if-current-thread (thread)
159   (when (eq thread (current-thread))
160     (error 'bordeaux-mp-condition
161            :message "Cannot destroy the current thread")))