src/bordeaux-threads.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 #|
   4 Copyright 2006, 2007 Greg Pfeil
   5
   6 Distributed under the MIT license (see LICENSE file)
   7 |#
   8
   9 (in-package #:bordeaux-threads)
  10
  11 (defvar *supports-threads-p* nil
  12   "This should be set to T if the running instance has thread support.")
  13
  14 (defun mark-supported ()
  15   (setf *supports-threads-p* t)
  16   (pushnew :bordeaux-threads *features*))
  17
  18 (define-condition bordeaux-mp-condition (error)
  19   ((message :initarg :message :reader message))
  20   (:report (lambda (condition stream)
  21              (format stream (message condition)))))
  22
  23 (defgeneric make-threading-support-error ()
  24   (:documentation "Creates a BORDEAUX-THREADS condition which specifies
  25   whether there is no BORDEAUX-THREADS support for the implementation, no
  26   threads enabled for the system, or no support for a particular
  27   function.")
  28   (:method ()
  29     (make-condition
  30      'bordeaux-mp-condition
  31      :message (if *supports-threads-p*
  32                   "There is no support for this method on this implementation."
  33                   "There is no thread support in this instance."))))
  34
  35 ;;; Timeouts
  36
  37 #-sbcl
  38 (define-condition timeout (serious-condition)
  39   ((length :initform nil
  40              :initarg :length
  41              :reader timeout-length))
  42   (:report (lambda (c s)
  43              (if (timeout-length c)
  44                  (format s "A timeout set to ~A seconds occurred."
  45                          (timeout-length c))
  46                  (format s "A timeout occurred.")))))
  47
  48 #-sbcl
  49 (defmacro with-timeout ((timeout) &body body)
  50   "Execute `BODY' and signal a condition of type TIMEOUT if the execution of
  51 BODY does not complete within `TIMEOUT' seconds. On implementations which do not
  52 support WITH-TIMEOUT natively and don't support threads either it has no effect."
  53   (declare (ignorable timeout body))
  54   #+thread-support
  55   (let ((ok-tag (gensym "OK"))
  56         (timeout-tag (gensym "TIMEOUT"))
  57         (caller (gensym "CALLER")))
  58     (once-only (timeout)
  59       `(multiple-value-prog1
  60            (catch ',ok-tag
  61              (catch ',timeout-tag
  62                (let ((,caller (current-thread)))
  63                  (make-thread #'(lambda ()
  64                                   (sleep ,timeout)
  65                                   (interrupt-thread ,caller
  66                                                     #'(lambda ()
  67                                                         (ignore-errors
  68                                                          (throw ',timeout-tag nil)))))
  69                               :name (format nil "WITH-TIMEOUT thread serving: ~S."
  70                                             (thread-name ,caller)))
  71                  (throw ',ok-tag (progn ,@body))))
  72              (error 'timeout :length ,timeout)))))
  73   #-thread-support
  74   `(error (make-threading-support-error)))
  75
  76 ;;; Semaphores
  77
  78 ;;; We provide this structure definition unconditionally regardless of the fact
  79 ;;; it may not be used not to prevent warnings from compiling default functions
  80 ;;; for semaphore in default-implementations.lisp.
  81 (defstruct %semaphore
  82   lock
  83   condition-variable
  84   counter)
  85
  86 #-(or ccl sbcl)
  87 (deftype semaphore ()
  88   '%semaphore)
  89
  90 ;;; Thread Creation
  91
  92 ;;; See default-implementations.lisp for MAKE-THREAD.
  93
  94 ;; Forms are evaluated in the new thread or in the calling thread?
  95 (defvar *default-special-bindings* nil
  96   "This variable holds an alist associating special variable symbols
  97   to forms to evaluate. Special variables named in this list will
  98   be locally bound in the new thread before it begins executing user code.
  99
 100   This variable may be rebound around calls to MAKE-THREAD to
 101   add/alter default bindings. The effect of mutating this list is
 102   undefined, but earlier forms take precedence over later forms for
 103   the same symbol, so defaults may be overridden by consing to the
 104   head of the list.")
 105
 106 (defmacro defbindings (name docstring &body initforms)
 107   (check-type docstring string)
 108   `(defparameter ,name
 109      (list
 110       ,@(loop for (special form) in initforms
 111               collect `(cons ',special ',form)))
 112      ,docstring))
 113
 114 ;; Forms are evaluated in the new thread or in the calling thread?
 115 (defbindings *standard-io-bindings*
 116   "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
 117   (*package*                   (find-package :common-lisp-user))
 118   (*print-array*               t)
 119   (*print-base*                10)
 120   (*print-case*                :upcase)
 121   (*print-circle*              nil)
 122   (*print-escape*              t)
 123   (*print-gensym*              t)
 124   (*print-length*              nil)
 125   (*print-level*               nil)
 126   (*print-lines*               nil)
 127   (*print-miser-width*         nil)
 128   (*print-pprint-dispatch*     (copy-pprint-dispatch nil))
 129   (*print-pretty*              nil)
 130   (*print-radix*               nil)
 131   (*print-readably*            t)
 132   (*print-right-margin*        nil)
 133   (*random-state*              (make-random-state t))
 134   (*read-base*                 10)
 135   (*read-default-float-format* 'single-float)
 136   (*read-eval*                 t)
 137   (*read-suppress*             nil)
 138   (*readtable*                 (copy-readtable nil)))
 139
 140 (defun binding-default-specials (function special-bindings)
 141   "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
 142 FUNCTION."
 143   (let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
 144     (lambda ()
 145       (progv (mapcar #'car specials)
 146           (loop for (nil . form) in specials collect (eval form))
 147         (funcall function)))))
 148
 149 ;;; FIXME: This test won't work if CURRENT-THREAD
 150 ;;;        conses a new object each time
 151 (defun signal-error-if-current-thread (thread)
 152   (when (eq thread (current-thread))
 153     (error 'bordeaux-mp-condition
 154            :message "Cannot destroy the current thread")))
 155
 156 (defparameter *no-condition-wait-timeout-message*
 157   "CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")
 158
 159 (defun signal-error-if-condition-wait-timeout (timeout)
 160   (when timeout
 161     (error 'bordeaux-mp-condition
 162            :message *no-condition-wait-timeout-message*)))
 163
 164 (defmacro define-condition-wait-compiler-macro ()
 165   `(define-compiler-macro condition-wait
 166        (&whole whole condition-variable lock &key timeout)
 167     (declare (ignore condition-variable lock))
 168     (when timeout
 169       (simple-style-warning *no-condition-wait-timeout-message*))
 170     whole))