/[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.10 - (show annotations)
Thu May 23 15:01:57 1991 UTC (22 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.9: +11 -9 lines
Fixed a problem I introduced in WAIT-FOR-EVENT where if the timeout wasn't an
integer, we could pass in a non-integer as the number of timeout microseconds
to select.
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.10 1991/05/23 15:01:57 ram 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 (defvar server-unique-object (cons 1 2)
42 "Object thrown by the message interrupt handler.")
43
44 (defconstant server-message-size 4096)
45 (defalien server-message server-message (bytes server-message-size) 0)
46
47 (define-alien-stack server-message server-message (bytes server-message-size))
48
49 (defrecord server-message
50 (msg mach:msg #.(record-size 'mach:msg)))
51
52 ;;; Grab-message-loop calls the appropiate handler for an IPC message.
53 (defun grab-message-loop ()
54 (let ((done-any nil))
55 (loop
56 (if (eql (server-grab-message)
57 mach:rcv-timed-out)
58 (return done-any)
59 (setf done-any t)))))
60
61
62 (defun server-grab-message ()
63 (with-stack-alien (sm server-message)
64 (alien-bind ((msg (server-message-msg (alien-value sm))))
65 (setf (alien-access (mach:msg-msgsize (alien-value msg)))
66 server-message-size)
67 (setf (alien-access (mach:msg-localport (alien-value msg)))
68 mach::port-enabled)
69 (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))
70 (when (eql gr mach:rcv-timed-out)
71 (return-from server-grab-message gr))
72 (unless (eql gr mach:rcv-success)
73 (gr-error 'mach:msg-receive gr))
74 (let* ((server-message (alien-value sm))
75 (port (alien-access (mach:msg-localport (alien-value msg))))
76 (id (alien-access (mach:msg-id (alien-value msg))))
77 (x (gethash port *port-table*))
78 (set (cdr x)))
79 (unless x
80 (error "~D is not known to server (operation: ~D)." port id))
81 (let ((gr (funcall (gethash id (object-set-table set)
82 (object-set-default-handler set))
83 (car x))))
84 (unless (eql gr mach:kern-success)
85 (gr-error 'server gr)))))))
86 mach:kern-success)
87 |#
88
89
90 ;;;; File descriptor IO noise.
91
92 (defstruct (handler
93 (:print-function %print-handler)
94 (:constructor make-handler (direction descriptor function)))
95 (direction nil :type (member :input :output)) ; Either :input or :output
96 (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.
97 active ; T iff this handler is running.
98 (function nil :type function) ; Function to call.
99 bogus ; T if this descriptor is bogus.
100 )
101
102 (defun %print-handler (handler stream depth)
103 (declare (ignore depth))
104 (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
105 (handler-direction handler)
106 (handler-bogus handler)
107 (handler-descriptor handler)
108 (handler-function handler)))
109
110 (defvar *descriptor-handlers* nil
111 "List of all the currently active handlers for file descriptors")
112
113
114 ;;; ADD-FD-HANDLER -- public
115 ;;;
116 ;;; Add a new handler to *descriptor-handlers*.
117 ;;;
118 (defun add-fd-handler (fd direction function)
119 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
120 either :INPUT or :OUTPUT. The value returned should be passed to
121 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
122 (assert (member direction '(:input :output))
123 (direction)
124 "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
125 (let ((handler (make-handler direction fd function)))
126 (push handler *descriptor-handlers*)
127 handler))
128
129 ;;; REMOVE-FD-HANDLER -- public
130 ;;;
131 ;;; Remove an old handler from *descriptor-handlers*.
132 ;;;
133 (defun remove-fd-handler (handler)
134 "Removes HANDLER from the list of active handlers."
135 (setf *descriptor-handlers*
136 (delete handler *descriptor-handlers*
137 :test #'eq)))
138
139 ;;; INVALIDATE-DESCRIPTOR -- public
140 ;;;
141 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
142 ;;;
143 (defun invalidate-descriptor (fd)
144 "Remove any handers refering to fd. This should only be used when attempting
145 to recover from a detected inconsistancy."
146 (setf *descriptor-handlers*
147 (delete fd *descriptor-handlers*
148 :key #'handler-descriptor)))
149
150 ;;; WITH-FD-HANDLER -- Public.
151 ;;;
152 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
153 ;;;
154 (defmacro with-fd-handler ((fd direction function) &rest body)
155 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
156 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
157 use, and FUNCTION is the function to call whenever FD is usable."
158 (let ((handler (gensym)))
159 `(let (,handler)
160 (unwind-protect
161 (progn
162 (setf ,handler (add-fd-handler ,fd ,direction ,function))
163 ,@body)
164 (when ,handler
165 (remove-fd-handler ,handler))))))
166
167 ;;; WAIT-UNTIL-FD-USABLE -- Public.
168 ;;;
169 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
170 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
171 ;;; timeout at the correct time irrespective of how many events are handled in
172 ;;; the meantime.
173 ;;;
174 (defun wait-until-fd-usable (fd direction &optional timeout)
175 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
176 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
177 up."
178 (declare (type (or index null) timeout))
179 (let (usable)
180 (multiple-value-bind
181 (stop-sec stop-usec)
182 (if timeout
183 (multiple-value-bind (okay sec usec)
184 (mach:unix-gettimeofday)
185 (declare (ignore okay))
186 (values (the (unsigned-byte 32) (+ sec timeout))
187 usec))
188 (values 0 0))
189 (declare (type (unsigned-byte 32) stop-sec stop-usec))
190 (with-fd-handler (fd direction #'(lambda (fd)
191 (declare (ignore fd))
192 (setf usable t)))
193 (loop
194 (serve-event timeout)
195
196 (when usable
197 (return t))
198
199 (when timeout
200 (multiple-value-bind (okay sec usec)
201 (mach:unix-gettimeofday)
202 (declare (ignore okay))
203 (when (or (> sec stop-sec)
204 (and (= sec stop-sec) (>= usec stop-usec)))
205 (return nil))
206 (setq timeout (- stop-sec sec)))))))))
207
208
209 ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
210 ;;;
211 ;;; First, get a list and mark bad file descriptors. Then signal an error
212 ;;; offering a few restarts.
213 ;;;
214 (defun handler-descriptors-error ()
215 (let ((bogus-handlers nil))
216 (dolist (handler *descriptor-handlers*)
217 (unless (or (handler-bogus handler)
218 (mach:unix-fstat (handler-descriptor handler)))
219 (setf (handler-bogus handler) t)
220 (push handler bogus-handlers)))
221 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
222 bogus-handlers (length bogus-handlers))
223 (remove-them () :report "Remove bogus handlers."
224 (setf *descriptor-handlers*
225 (delete-if #'handler-bogus *descriptor-handlers*)))
226 (retry-them () :report "Retry bogus handlers."
227 (dolist (handler bogus-handlers)
228 (setf (handler-bogus handler) nil)))
229 (continue () :report "Go on, leaving handlers marked as bogus."))))
230
231
232
233 ;;;; Serve-all-events, serve-event, and friends.
234
235 (declaim (start-block serve-event serve-all-events))
236
237 (defvar *display-event-handlers* nil
238 "This is an alist mapping displays to user functions to be called when
239 SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
240 this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
241 should be represented here only once.")
242
243 ;;; SERVE-ALL-EVENTS -- public
244 ;;;
245 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
246 ;;; pending events are processed before returning.
247 ;;;
248 (defun serve-all-events (&optional timeout)
249 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
250 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
251 0 until all events have been served. SERVE-ALL-EVENTS returns T if
252 SERVE-EVENT did something and NIL if not."
253 (do ((res nil)
254 (sval (serve-event timeout) (serve-event 0)))
255 ((null sval) res)
256 (setq res t)))
257
258
259 ;;; SERVE-EVENT -- public
260 ;;;
261 ;;; Serve a single event.
262 ;;;
263 (defun serve-event (&optional timeout)
264 "Receive on all ports and Xevents and dispatch to the appropriate handler
265 function. If timeout is specified, server will wait the specified time (in
266 seconds) and then return, otherwise it will wait until something happens.
267 Server returns T if something happened and NIL otherwise."
268 ;; First, check any X displays for any pending events.
269 #+clx
270 (dolist (d/h *display-event-handlers*)
271 (let ((d (car d/h)))
272 (declare (inline member))
273 ;;
274 ;; If in the *descriptor-handlers*, then we are already waiting for input
275 ;; on that display, and we don't want to do it recursively.
276 (when (and (not (member (fd-stream-fd (xlib::display-input-stream d))
277 *descriptor-handlers*
278 :key #'handler-descriptor))
279 (xlib::event-listen d))
280 (handler-bind ((error #'(lambda (condx)
281 (declare (ignore condx))
282 (flush-display-events d))))
283 (funcall (cdr d/h) d))
284 (return-from serve-event t))))
285 ;; Next, wait for something to happen.
286 (multiple-value-bind
287 (value readable writeable)
288 (wait-for-event timeout)
289 (declare (type (unsigned-byte 32) readable writeable))
290 ;; Now see what it was (if anything)
291 (cond #+nil
292 ((eq value server-unique-object)
293 ;; The interrupt handler fired.
294 (grab-message-loop)
295 t)
296 ((fixnump value)
297 (unless (zerop value)
298 ;; Check the descriptors.
299 (let ((result nil))
300 (dolist (handler *descriptor-handlers*)
301 (when (logbitp (handler-descriptor handler)
302 (ecase (handler-direction handler)
303 (:input readable)
304 (:output writeable)))
305 (unwind-protect
306 (progn
307 ;; Doesn't work -- ACK
308 ;(setf (handler-active handler) t)
309 (funcall (handler-function handler)
310 (handler-descriptor handler)))
311 (setf (handler-active handler) nil))
312 (macrolet ((frob (var)
313 `(setf ,var
314 (logand (32bit-logical-not
315 (ash 1
316 (handler-descriptor
317 handler)))
318 ,var))))
319 (ecase (handler-direction handler)
320 (:input (frob readable))
321 (:output (frob writeable))))
322 (setf result t)))
323 result)))
324 ((eql readable mach:eintr)
325 ;; We did an interrupt.
326 t)
327 (t
328 ;; One of the file descriptors is bad.
329 (handler-descriptors-error)
330 nil))))
331
332
333 ;;; CALC-MASKS -- Internal.
334 ;;;
335 ;;; Return the correct masks to use for UNIX-SELECT. The four return values
336 ;;; are: fd count, read mask, write mask, and exception mask. The exception
337 ;;; mask is currently unused.
338 ;;;
339 (defun calc-masks ()
340 (let ((count 0)
341 (read-mask 0)
342 (write-mask 0)
343 (except-mask 0))
344 (declare (type index count)
345 (type (unsigned-byte 32) read-mask write-mask except-mask))
346 (dolist (handler *descriptor-handlers*)
347 (unless (or (handler-active handler)
348 (handler-bogus handler))
349 (let ((fd (handler-descriptor handler)))
350 (ecase (handler-direction handler)
351 (:input
352 (setf read-mask
353 (logior read-mask
354 (the (unsigned-byte 32) (ash 1 fd)))))
355 (:output
356 (setf write-mask
357 (logior write-mask
358 (the (unsigned-byte 32) (ash 1 fd))))))
359 (when (> fd count)
360 (setf count fd)))))
361 (values (1+ count)
362 read-mask
363 write-mask
364 except-mask)))
365
366 ;;; WAIT-FOR-EVENT -- internal
367 ;;;
368 ;;; Wait for something to happen.
369 ;;;
370 (defun wait-for-event (&optional timeout)
371 "Wait for an something to show up on one of the file descriptors or a message
372 interupt to fire. Timeout is in seconds."
373 (multiple-value-bind
374 (timeout-sec timeout-usec)
375 (typecase timeout
376 (integer (values timeout 0))
377 (null (values nil 0))
378 (t
379 (multiple-value-bind (q r)
380 (truncate (coerce timeout 'single-float))
381 (declare (type index q) (single-float r))
382 (values q (truncate (* r 1f6))))))
383 (declare (type index timeout-usec)
384 (type (or index null) timeout-sec))
385 (multiple-value-bind (count read-mask write-mask except-mask)
386 (calc-masks)
387 ;; Do the select.
388 (mach:unix-select count read-mask write-mask except-mask
389 timeout-sec timeout-usec))))

  ViewVC Help
Powered by ViewVC 1.1.5