bordeaux-threads.lisp - clic - Clic is an command line interactive client for g… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
bordeaux-threads.lisp (6348B) | |
--- | |
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 implement… | |
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 executio… | |
51 BODY does not complete within `TIMEOUT' seconds. On implementations whic… | |
52 support WITH-TIMEOUT natively and don't support threads either it has no… | |
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 ',timeou… | |
69 :name (format nil "WITH-TIMEOUT thread ser… | |
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 t… | |
79 ;;; it may not be used not to prevent warnings from compiling default fu… | |
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 cod… | |
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-… | |
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 #… | |
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 implement… | |
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)) |