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

  ViewVC Help
Powered by ViewVC 1.1.5