3rdparties/software/bordeaux-threads-v0.8.7/src/bordeaux-threads.lisp (6348 bytes)
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))