/[cmucl]/src/code/serve-event.lisp
ViewVC logotype

Contents of /src/code/serve-event.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14.1.1 - (show annotations) (vendor branch)
Mon Feb 24 02:38:03 1992 UTC (22 years, 1 month ago) by wlott
Branch: fast_select
Changes since 1.14: +71 -100 lines
Start of unix-fast-select changes.
1 ;;; -*- Log: code.log; Package: LISP -*-
2
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.14.1.1 1992/02/24 02:38:03 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; SYSTEM:SERVE-EVENT, now in it's own file.
15 ;;;
16 ;;; Re-written by William Lott, July 1989 - January 1990.
17 ;;;
18 ;;; **********************************************************************
19
20 (in-package "SYSTEM")
21
22 (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23 serve-event serve-all-events wait-until-fd-usable))
24
25 (in-package "EXTENSIONS")
26
27 (export '(*display-event-handlers*))
28
29 (in-package "LISP")
30
31
32
33 ;;;; MACH Message receiving noise.
34
35 (defvar *in-server* NIL
36 "*In-server* is set to T when the SIGMSG interrupt has been enabled
37 in Server.")
38
39
40
41 ;;;; File descriptor IO noise.
42
43 (defstruct (handler
44 (:print-function %print-handler)
45 (:constructor make-handler (direction descriptor function)))
46 ;;
47 ;; :Input if we are going to read from it, :Output if we are going to
48 ;; write to it.
49 (direction nil :type (member :input :output))
50 ;;
51 ;; The file descriptor.
52 (descriptor 0 :type (mod #.unix:fd-setsize))
53 ;;
54 ;; Unused.
55 active
56 ;;
57 ;; The function to invoke when there is activity on this descriptor.
58 (function nil :type function)
59 ;;
60 ;; Gets set to NIL when we get an error on the descriptor. Used to prevent
61 ;; requisive errors.
62 (bogus nil :type (member t nil)))
63
64 (defun %print-handler (handler stream depth)
65 (declare (ignore depth))
66 (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
67 (handler-direction handler)
68 (handler-bogus handler)
69 (handler-descriptor handler)
70 (handler-function handler)))
71
72 (defvar *descriptor-handlers* nil
73 "List of all the currently active handlers for file descriptors")
74
75
76 ;;; ADD-FD-HANDLER -- public
77 ;;;
78 ;;; Add a new handler to *descriptor-handlers*.
79 ;;;
80 (defun add-fd-handler (fd direction function)
81 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
82 either :INPUT or :OUTPUT. The value returned should be passed to
83 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
84 (assert (member direction '(:input :output))
85 (direction)
86 "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
87 (let ((handler (make-handler direction fd function)))
88 (push handler *descriptor-handlers*)
89 handler))
90
91 ;;; REMOVE-FD-HANDLER -- public
92 ;;;
93 ;;; Remove an old handler from *descriptor-handlers*.
94 ;;;
95 (defun remove-fd-handler (handler)
96 "Removes HANDLER from the list of active handlers."
97 (setf *descriptor-handlers*
98 (delete handler *descriptor-handlers*
99 :test #'eq)))
100
101 ;;; INVALIDATE-DESCRIPTOR -- public
102 ;;;
103 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
104 ;;;
105 (defun invalidate-descriptor (fd)
106 "Remove any handers refering to fd. This should only be used when attempting
107 to recover from a detected inconsistancy."
108 (setf *descriptor-handlers*
109 (delete fd *descriptor-handlers*
110 :key #'handler-descriptor)))
111
112 ;;; WITH-FD-HANDLER -- Public.
113 ;;;
114 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
115 ;;;
116 (defmacro with-fd-handler ((fd direction function) &rest body)
117 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
118 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
119 use, and FUNCTION is the function to call whenever FD is usable."
120 (let ((handler (gensym)))
121 `(let (,handler)
122 (unwind-protect
123 (progn
124 (setf ,handler (add-fd-handler ,fd ,direction ,function))
125 ,@body)
126 (when ,handler
127 (remove-fd-handler ,handler))))))
128
129 ;;; WAIT-UNTIL-FD-USABLE -- Public.
130 ;;;
131 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
132 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
133 ;;; timeout at the correct time irrespective of how many events are handled in
134 ;;; the meantime.
135 ;;;
136 (defun wait-until-fd-usable (fd direction &optional timeout)
137 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
138 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
139 up."
140 (declare (type (or index null) timeout))
141 (let (usable)
142 (multiple-value-bind
143 (stop-sec stop-usec)
144 (if timeout
145 (multiple-value-bind (okay sec usec)
146 (unix:unix-gettimeofday)
147 (declare (ignore okay))
148 (values (the (unsigned-byte 32) (+ sec timeout))
149 usec))
150 (values 0 0))
151 (declare (type (unsigned-byte 32) stop-sec stop-usec))
152 (with-fd-handler (fd direction #'(lambda (fd)
153 (declare (ignore fd))
154 (setf usable t)))
155 (loop
156 (serve-event timeout)
157
158 (when usable
159 (return t))
160
161 (when timeout
162 (multiple-value-bind (okay sec usec)
163 (unix:unix-gettimeofday)
164 (declare (ignore okay))
165 (when (or (> sec stop-sec)
166 (and (= sec stop-sec) (>= usec stop-usec)))
167 (return nil))
168 (setq timeout (- stop-sec sec)))))))))
169
170
171 ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
172 ;;;
173 ;;; First, get a list and mark bad file descriptors. Then signal an error
174 ;;; offering a few restarts.
175 ;;;
176 (defun handler-descriptors-error ()
177 (let ((bogus-handlers nil))
178 (dolist (handler *descriptor-handlers*)
179 (unless (or (handler-bogus handler)
180 (unix:unix-fstat (handler-descriptor handler)))
181 (setf (handler-bogus handler) t)
182 (push handler bogus-handlers)))
183 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
184 bogus-handlers (length bogus-handlers))
185 (remove-them () :report "Remove bogus handlers."
186 (setf *descriptor-handlers*
187 (delete-if #'handler-bogus *descriptor-handlers*)))
188 (retry-them () :report "Retry bogus handlers."
189 (dolist (handler bogus-handlers)
190 (setf (handler-bogus handler) nil)))
191 (continue () :report "Go on, leaving handlers marked as bogus."))))
192
193
194
195 ;;;; Serve-all-events, serve-event, and friends.
196
197 (defvar *display-event-handlers* nil
198 "This is an alist mapping displays to user functions to be called when
199 SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
200 this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
201 should be represented here only once.")
202
203 ;;; SERVE-ALL-EVENTS -- public
204 ;;;
205 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
206 ;;; pending events are processed before returning.
207 ;;;
208 (defun serve-all-events (&optional timeout)
209 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
210 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
211 0 until all events have been served. SERVE-ALL-EVENTS returns T if
212 SERVE-EVENT did something and NIL if not."
213 (do ((res nil)
214 (sval (serve-event timeout) (serve-event 0)))
215 ((null sval) res)
216 (setq res t)))
217
218
219 ;;; SERVE-EVENT -- public
220 ;;;
221 ;;; Serve a single event.
222 ;;;
223 (defun serve-event (&optional timeout)
224 "Receive on all ports and Xevents and dispatch to the appropriate handler
225 function. If timeout is specified, server will wait the specified time (in
226 seconds) and then return, otherwise it will wait until something happens.
227 Server returns T if something happened and NIL otherwise."
228 ;; First, check any X displays for any pending events.
229 #+clx
230 (dolist (d/h *display-event-handlers*)
231 (let* ((d (car d/h))
232 (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
233 (declare (inline member))
234 ;;
235 ;; If in the *descriptor-handlers*, then we are already waiting for input
236 ;; on that display, and we don't want to do it recursively.
237 (when (and (dolist (hand *descriptor-handlers* t)
238 (when (and (eql (handler-descriptor hand) disp-fd)
239 (not (eq (handler-function hand)
240 #'ext::call-display-event-handler)))
241 (return nil)))
242 (xlib::event-listen d))
243 (handler-bind ((error #'(lambda (condx)
244 (declare (ignore condx))
245 (flush-display-events d))))
246 (unless (funcall (cdr d/h) d)
247 (disable-clx-event-handling d)
248 (error "Event-listen was true, but handler didn't handle: ~%~S"
249 d/h)))
250 (return-from serve-event t))))
251 (multiple-value-bind
252 (timeout-sec timeout-usec)
253 (typecase timeout
254 (integer (values timeout 0))
255 (null (values nil 0))
256 (t
257 (multiple-value-bind
258 (q r)
259 (truncate (coerce timeout 'single-float))
260 (declare (type index q) (single-float r))
261 (values q (truncate (* r 1f6))))))
262 (declare (type (integer 0 (1000000)) timeout-usec)
263 (type (or index null) timeout-sec))
264 (let ((max-fd -1))
265 (declare (type (integer -1 #.unix:fd-setsize) max-fd))
266 (alien:with-alien ((read-fds (alien:struct unix:fd-set))
267 (write-fds (alien:struct unix:fd-set)))
268 ;; Compute the masks.
269 (unix:fd-zero read-fds)
270 (unix:fd-zero write-fds)
271 (dolist (handler *descriptor-handlers*)
272 (unless (or (handler-active handler)
273 (handler-bogus handler))
274 (let ((fd (handler-descriptor handler)))
275 (ecase (handler-direction handler)
276 (:input
277 (unix:fd-set fd read-fds))
278 (:output
279 (unix:fd-set fd write-fds)))
280 (when (> fd max-fd)
281 (setf max-fd fd)))))
282 ;; Next, wait for something to happen.
283 (multiple-value-bind
284 (count errno)
285 (unix:unix-fast-select (1+ max-fd)
286 (alien:addr read-fds)
287 (alien:addr write-fds)
288 nil timeout-sec timeout-usec)
289 (cond (count
290 (unless (zerop count)
291 ;; Check the descriptors.
292 (let ((result nil))
293 (dolist (handler *descriptor-handlers*)
294 (unless (handler-bogus handler)
295 (when (ecase (handler-direction handler)
296 (:input
297 (unix:fd-isset (handler-descriptor handler)
298 read-fds))
299 (:output
300 (unix:fd-isset (handler-descriptor handler)
301 write-fds)))
302 (funcall (handler-function handler)
303 (handler-descriptor handler))
304 (setf result t))))
305 result)))
306 ((eql errno unix:eintr)
307 ;; We did an interrupt.
308 t)
309 (t
310 ;; One of the file descriptors is bad.
311 (handler-descriptors-error)
312 nil)))))))

  ViewVC Help
Powered by ViewVC 1.1.5