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   (:documentation "BORDEAUX-THREADS is a proposed standard for a minimal
  12   MP/threading interface. It is similar to the CLIM-SYS threading and
  13   lock support, but for the following broad differences:
  14
  15   1) Some behaviours are defined in additional detail: attention has
  16      been given to special variable interaction, whether and when
  17      cleanup forms are run. Some behaviours are defined in less
  18      detail: an implementation that does not support multiple
  19      threads is not required to use a new list (nil) for a lock, for
  20      example.
  21
  22   2) Many functions which would be difficult, dangerous or inefficient
  23      to provide on some implementations have been removed. Chiefly
  24      these are functions such as thread-wait which expect for
  25      efficiency that the thread scheduler is written in Lisp and
  26      'hookable', which can't sensibly be done if the scheduler is
  27      external to the Lisp image, or the system has more than one CPU.
  28
  29   3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been
  30      added.
  31
  32   4) Posix-style condition variables have been added, as it's not
  33      otherwise possible to implement them correctly using the other
  34      operations that are specified.
  35
  36   Threads may be implemented using whatever applicable techniques are
  37   provided by the operating system: user-space scheduling,
  38   kernel-based LWPs or anything else that does the job.
  39
  40   Some parts of this specification can also be implemented in a Lisp
  41   that does not support multiple threads. Thread creation and some
  42   thread inspection operations will not work, but the locking
  43   functions are still present (though they may do nothing) so that
  44   thread-safe code can be compiled on both multithread and
  45   single-thread implementations without need of conditionals.
  46
  47   To avoid conflict with existing MP/threading interfaces in
  48   implementations, these symbols live in the BORDEAUX-THREADS package.
  49   Implementations and/or users may also make them visible or exported
  50   in other more traditionally named packages.")
  51   (:use #:cl)
  52   (:export #:make-thread #:current-thread #:threadp #:thread-name
  53            #:*default-special-bindings* #:*supports-threads-p*
  54
  55            #:make-lock #:acquire-lock #:release-lock #:with-lock-held
  56            #:make-recursive-lock #:acquire-recursive-lock
  57            #:release-recursive-lock #:with-recursive-lock-held
  58
  59            #:make-condition-variable #:condition-wait #:condition-notify
  60            #:thread-yield
  61
  62            #:with-timeout #:timeout
  63
  64            #:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
  65            #:join-thread))
  66
  67 (in-package #:bordeaux-threads)
  68
  69 (defvar *supports-threads-p* nil
  70   "This should be set to T if the running instance has thread support.")
  71
  72 (defun mark-supported ()
  73   (setf *supports-threads-p* t)
  74   (pushnew :bordeaux-threads *features*))
  75
  76 (define-condition bordeaux-mp-condition (error)
  77   ((message :initarg :message :reader message))
  78   (:report (lambda (condition stream)
  79              (format stream (message condition)))))
  80
  81 (defgeneric make-threading-support-error ()
  82   (:documentation "Creates a BORDEAUX-THREADS condition which specifies
  83   whether there is no BORDEAUX-THREADS support for the implementation, no
  84   threads enabled for the system, or no support for a particular
  85   function.")
  86   (:method ()
  87     (make-condition
  88      'bordeaux-mp-condition
  89      :message (if *supports-threads-p*
  90                   "There is no support for this method on this implementation."
  91                   "There is no thread support in this instance."))))
  92
  93 (define-condition timeout (serious-condition) ())
  94
  95 ;;; Thread Creation
  96
  97 ;;; See default-implementations.lisp for MAKE-THREAD.
  98
  99 (defmacro defbindings (name docstring &body initforms)
 100   (check-type docstring string)
 101   `(defvar ,name
 102      (list
 103       ,@(loop for (special form) in initforms
 104               collect `(cons ',special (load-time-value (lambda () ,form)))))
 105      ,docstring))
 106
 107 ;; Forms are evaluated in the new thread or in the calling thread?
 108 (defbindings *default-special-bindings*
 109   "This variable holds an alist associating special variable symbols
 110   with function designators to call for binding values. Special variables
 111   named in this list will be locally bound in the new thread before it
 112   begins executing user code.
 113
 114   This variable may be rebound around calls to MAKE-THREAD to
 115   add/alter default bindings. The effect of mutating this list is
 116   undefined, but earlier forms take precedence over later forms for
 117   the same symbol, so defaults may be overridden by consing to the
 118   head of the list."
 119   (*package*                   (find-package :common-lisp-user))
 120   (*print-array*               t)
 121   (*print-base*                10)
 122   (*print-case*                :upcase)
 123   (*print-circle*              nil)
 124   (*print-escape*              t)
 125   (*print-gensym*              t)
 126   (*print-length*              nil)
 127   (*print-level*               nil)
 128   (*print-lines*               nil)
 129   (*print-miser-width*         nil)
 130   (*print-pprint-dispatch*     (copy-pprint-dispatch nil))
 131   (*print-pretty*              nil)
 132   (*print-radix*               nil)
 133   (*print-readably*            t)
 134   (*print-right-margin*        nil)
 135   (*read-base*                 10)
 136   (*read-default-float-format* 'single-float)
 137   (*read-eval*                 t)
 138   (*read-suppress*             nil)
 139   (*readtable*                 (copy-readtable nil)))
 140
 141 (defun binding-default-specials (function special-bindings)
 142   "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
 143 FUNCTION."
 144   (let ((specials (remove-duplicates special-bindings :from-end t)))
 145     (lambda ()
 146       (progv (mapcar #'car specials)
 147           (loop for (nil . fun) in specials collect (funcall fun))
 148         (funcall function)))))
 149
 150 ;;; FIXME: This test won't work if CURRENT-THREAD
 151 ;;;        conses a new object each time
 152 (defun signal-error-if-current-thread (thread)
 153   (when (eq thread (current-thread))
 154     (error 'bordeaux-mp-condition
 155            :message "Cannot destroy the current thread")))