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

  ViewVC Help
Powered by ViewVC 1.1.5