bordeaux-threads.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 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))