/[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.8 - (hide annotations)
Wed May 22 00:19:39 1991 UTC (22 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.7: +94 -98 lines
Added declarations & used block compilation to reduce the amount of number
consing and generic arithmetic.  Ripped out the vestigial sigmask hackery in
serve-event.
1 ram 1.1 ;;; -*- Log: code.log; Package: LISP -*-
2    
3     ;;; **********************************************************************
4 ram 1.7 ;;; 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 ram 1.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.8 1991/05/22 00:19:39 ram Exp $")
11 ram 1.7 ;;;
12 ram 1.1 ;;; **********************************************************************
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 ram 1.2 (in-package "EXTENSIONS")
26    
27     (export '(*display-event-handlers*))
28    
29 ram 1.1 (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 wlott 1.3 #|
40    
41 ram 1.1 (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 wlott 1.3 |#
88 ram 1.1
89    
90     ;;;; File descriptor IO noise.
91    
92     (defstruct (handler
93     (:print-function %print-handler)
94     (:constructor make-handler (direction descriptor function)))
95 ram 1.8 (direction nil :type (member :input :output)) ; Either :input or :output
96     (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.
97 ram 1.1 active ; T iff this handler is running.
98 ram 1.8 (function nil :type function) ; Function to call.
99 ram 1.1 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 ram 1.8 (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 ram 1.1
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 ram 1.8 (declaim (start-block serve-event serve-all-events))
236    
237 ram 1.2 (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 ram 1.1 ;;; 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 ram 1.2
259 ram 1.1 ;;; 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 ram 1.6 #+clx
270 ram 1.2 (dolist (d/h *display-event-handlers*)
271 ram 1.1 (let ((d (car d/h)))
272     (when (xlib::event-listen d)
273     (handler-bind ((error #'(lambda (condx)
274     (declare (ignore condx))
275     (flush-display-events d))))
276     (funcall (cdr d/h) d))
277     (return-from serve-event t))))
278     ;; Next, wait for something to happen.
279     (multiple-value-bind
280     (value readable writeable)
281     (wait-for-event timeout)
282 ram 1.8 (declare (type (unsigned-byte 32) readable writeable))
283 ram 1.1 ;; Now see what it was (if anything)
284 wlott 1.3 (cond #+nil
285     ((eq value server-unique-object)
286 ram 1.1 ;; The interrupt handler fired.
287     (grab-message-loop)
288     t)
289 ram 1.8 ((fixnump value)
290 ram 1.1 (unless (zerop value)
291     ;; Check the descriptors.
292     (let ((result nil))
293     (dolist (handler *descriptor-handlers*)
294 ram 1.8 (when (logbitp (handler-descriptor handler)
295     (ecase (handler-direction handler)
296     (:input readable)
297     (:output writeable)))
298 ram 1.1 (unwind-protect
299     (progn
300     ;; Doesn't work -- ACK
301     ;(setf (handler-active handler) t)
302     (funcall (handler-function handler)
303     (handler-descriptor handler)))
304     (setf (handler-active handler) nil))
305     (macrolet ((frob (var)
306     `(setf ,var
307 ram 1.8 (logand (32bit-logical-not
308     (ash 1
309     (handler-descriptor
310     handler)))
311 ram 1.1 ,var))))
312 ram 1.5 (ecase (handler-direction handler)
313 ram 1.1 (:input (frob readable))
314     (:output (frob writeable))))
315     (setf result t)))
316     result)))
317     ((eql readable mach:eintr)
318     ;; We did an interrupt.
319     t)
320     (t
321     ;; One of the file descriptors is bad.
322     (handler-descriptors-error)
323     nil))))
324    
325 ram 1.8
326     ;;; CALC-MASKS -- Internal.
327     ;;;
328     ;;; Return the correct masks to use for UNIX-SELECT. The four return values
329     ;;; are: fd count, read mask, write mask, and exception mask. The exception
330     ;;; mask is currently unused.
331     ;;;
332     (defun calc-masks ()
333     (let ((count 0)
334     (read-mask 0)
335     (write-mask 0)
336     (except-mask 0))
337     (declare (type index count)
338     (type (unsigned-byte 32) read-mask write-mask except-mask))
339     (dolist (handler *descriptor-handlers*)
340     (unless (or (handler-active handler)
341     (handler-bogus handler))
342     (let ((fd (handler-descriptor handler)))
343     (ecase (handler-direction handler)
344     (:input
345     (setf read-mask
346     (logior read-mask
347     (the (unsigned-byte 32) (ash 1 fd)))))
348     (:output
349     (setf write-mask
350     (logior write-mask
351     (the (unsigned-byte 32) (ash 1 fd))))))
352     (when (> fd count)
353     (setf count fd)))))
354     (values (1+ count)
355     read-mask
356     write-mask
357     except-mask)))
358    
359 ram 1.1 ;;; WAIT-FOR-EVENT -- internal
360     ;;;
361     ;;; Wait for something to happen.
362     ;;;
363     (defun wait-for-event (&optional timeout)
364     "Wait for an something to show up on one of the file descriptors or a message
365     interupt to fire. Timeout is in seconds."
366 ram 1.8 (multiple-value-bind (timeout-sec timeout-usec)
367     (typecase timeout
368     (integer (values timeout 0))
369     (null (values nil 0))
370     (t
371     (multiple-value-bind (q r)
372     (truncate timeout)
373     (values q (* r 1000000)))))
374     (declare (type index timeout-usec)
375     (type (or index null) timeout-sec))
376     (multiple-value-bind (count read-mask write-mask except-mask)
377     (calc-masks)
378     ;; Do the select.
379     (mach:unix-select count read-mask write-mask except-mask
380     timeout-sec timeout-usec))))

  ViewVC Help
Powered by ViewVC 1.1.5