/[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.6 - (hide annotations)
Thu Jan 31 18:16:29 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.5: +1 -1 lines
Unconditionalized out some CLX stuff in SERVE-EVENT.
1 ram 1.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 ram 1.2 (in-package "EXTENSIONS")
22    
23     (export '(*display-event-handlers*))
24    
25 ram 1.1 (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 wlott 1.3 #|
36    
37 ram 1.1 (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 wlott 1.3 |#
84 ram 1.1
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 ram 1.5 (ecase (handler-direction handler)
216 ram 1.1 (: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 ram 1.2 (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 ram 1.1 ;;; 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 ram 1.2
275 ram 1.1 ;;; 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 ram 1.6 #+clx
286 ram 1.2 (dolist (d/h *display-event-handlers*)
287 ram 1.1 (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 wlott 1.3 (cond #+nil
300     ((eq value server-unique-object)
301 ram 1.1 ;; 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 ram 1.5 (ecase (handler-direction handler)
311 ram 1.1 (: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 ram 1.5 (ecase (handler-direction handler)
327 ram 1.1 (: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 wlott 1.3 (setf old-mask (mach:unix-sigblock (mach:sigmask :sigmsg)))
358 ram 1.1 ;; 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 wlott 1.3 #+nil
362 ram 1.1 (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 wlott 1.3 #+nil
368 ram 1.1 (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 wlott 1.3 #+nil
376     (mach:unix-sigblock (mach:sigmask :sigmsg))
377     #+nil
378 ram 1.1 (default-interrupt mach:sigmsg)
379 wlott 1.4 (when old-mask
380     (mach:unix-sigsetmask old-mask))))))))

  ViewVC Help
Powered by ViewVC 1.1.5