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 #-sbcl
  36 (define-condition timeout (serious-condition)
  37   ((length :initform nil
  38              :initarg :length
  39              :reader timeout-length))
  40   (:report (lambda (c s)
  41              (if (timeout-length c)
  42                  (format s "A timeout set to ~A seconds occurred."
  43                          (timeout-length c))
  44                  (format s "A timeout occurred.")))))
  45
  46 ;;; Semaphores
  47
  48 ;;; We provide this structure definition unconditionally regardless of the fact
  49 ;;; it may not be used not to prevent warnings from compiling default functions
  50 ;;; for semaphore in default-implementations.lisp.
  51 (defstruct %semaphore
  52   lock
  53   condition-variable
  54   counter)
  55
  56 #-(or ccl sbcl)
  57 (deftype semaphore ()
  58   '%semaphore)
  59
  60 ;;; Thread Creation
  61
  62 ;;; See default-implementations.lisp for MAKE-THREAD.
  63
  64 ;; Forms are evaluated in the new thread or in the calling thread?
  65 (defvar *default-special-bindings* nil
  66   "This variable holds an alist associating special variable symbols
  67   to forms to evaluate. Special variables named in this list will
  68   be locally bound in the new thread before it begins executing user code.
  69
  70   This variable may be rebound around calls to MAKE-THREAD to
  71   add/alter default bindings. The effect of mutating this list is
  72   undefined, but earlier forms take precedence over later forms for
  73   the same symbol, so defaults may be overridden by consing to the
  74   head of the list.")
  75
  76 (defmacro defbindings (name docstring &body initforms)
  77   (check-type docstring string)
  78   `(defparameter ,name
  79      (list
  80       ,@(loop for (special form) in initforms
  81               collect `(cons ',special ',form)))
  82      ,docstring))
  83
  84 ;; Forms are evaluated in the new thread or in the calling thread?
  85 (defbindings *standard-io-bindings*
  86   "Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
  87   (*package*                   (find-package :common-lisp-user))
  88   (*print-array*               t)
  89   (*print-base*                10)
  90   (*print-case*                :upcase)
  91   (*print-circle*              nil)
  92   (*print-escape*              t)
  93   (*print-gensym*              t)
  94   (*print-length*              nil)
  95   (*print-level*               nil)
  96   (*print-lines*               nil)
  97   (*print-miser-width*         nil)
  98   (*print-pprint-dispatch*     (copy-pprint-dispatch nil))
  99   (*print-pretty*              nil)
 100   (*print-radix*               nil)
 101   (*print-readably*            t)
 102   (*print-right-margin*        nil)
 103   (*read-base*                 10)
 104   (*read-default-float-format* 'single-float)
 105   (*read-eval*                 t)
 106   (*read-suppress*             nil)
 107   (*readtable*                 (copy-readtable nil)))
 108
 109 (defun binding-default-specials (function special-bindings)
 110   "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
 111 FUNCTION."
 112   (let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
 113     (lambda ()
 114       (progv (mapcar #'car specials)
 115           (loop for (nil . form) in specials collect (eval form))
 116         (funcall function)))))
 117
 118 ;;; FIXME: This test won't work if CURRENT-THREAD
 119 ;;;        conses a new object each time
 120 (defun signal-error-if-current-thread (thread)
 121   (when (eq thread (current-thread))
 122     (error 'bordeaux-mp-condition
 123            :message "Cannot destroy the current thread")))
 124
 125 (defparameter *no-condition-wait-timeout-message*
 126   "CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")
 127
 128 (defun signal-error-if-condition-wait-timeout (timeout)
 129   (when timeout
 130     (error 'bordeaux-mp-condition
 131            :message *no-condition-wait-timeout-message*)))
 132
 133 (defmacro define-condition-wait-compiler-macro ()
 134   `(define-compiler-macro condition-wait
 135        (&whole whole condition-variable lock &key timeout)
 136     (declare (ignore condition-variable lock))
 137     (when timeout
 138       (simple-style-warning *no-condition-wait-timeout-message*))
 139     whole))