/[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.7 - (hide annotations)
Fri Feb 8 13:35:36 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.6: +8 -4 lines
New file header with RCS header FILE-COMMENT.
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     "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.7 1991/02/08 13:35:36 ram Exp $")
11     ;;;
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     direction ; Either :input or :output
96     descriptor ; File descriptor this handler is tied to.
97     active ; T iff this handler is running.
98     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     (let (usable
179     (stop-at (if timeout
180     (multiple-value-bind (okay sec usec)
181     (mach:unix-gettimeofday)
182     (declare (ignore okay))
183     (+ (* 1000000 timeout sec) usec)))))
184     (with-fd-handler (fd direction #'(lambda (fd)
185     (declare (ignore fd))
186     (setf usable t)))
187     (loop
188     (serve-event timeout)
189    
190     (when usable
191     (return t))
192    
193     (when timeout
194     (multiple-value-bind (okay sec usec)
195     (mach:unix-gettimeofday)
196     (declare (ignore okay))
197     (let ((now (+ (* sec 1000000) usec)))
198     (if (> now stop-at)
199     (return nil)
200     (setq timeout
201     (/ (- stop-at now)
202     1000000))))))))))
203    
204     ;;; CALC-MASKS -- Internal.
205     ;;;
206     ;;; Return the correct masks to use for UNIX-SELECT. The four return values
207     ;;; are: fd count, read mask, write mask, and exception mask. The exception
208     ;;; mask is currently unused.
209     ;;;
210     (defun calc-masks ()
211     (let ((count 0)
212     (read-mask 0)
213     (write-mask 0)
214     (except-mask 0))
215     (dolist (handler *descriptor-handlers*)
216     (unless (or (handler-active handler)
217     (handler-bogus handler))
218     (let ((fd (handler-descriptor handler)))
219 ram 1.5 (ecase (handler-direction handler)
220 ram 1.1 (:input
221     (setf read-mask (logior read-mask (ash 1 fd))))
222     (:output
223     (setf write-mask (logior write-mask (ash 1 fd)))))
224     (if (> fd count)
225     (setf count fd)))))
226     (values (1+ count)
227     read-mask
228     write-mask
229     except-mask)))
230    
231     ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
232     ;;;
233     ;;; First, get a list and mark bad file descriptors. Then signal an error
234     ;;; offering a few restarts.
235     ;;;
236     (defun handler-descriptors-error ()
237     (let ((bogus-handlers nil))
238     (dolist (handler *descriptor-handlers*)
239     (unless (or (handler-bogus handler)
240     (mach:unix-fstat (handler-descriptor handler)))
241     (setf (handler-bogus handler) t)
242     (push handler bogus-handlers)))
243     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
244     bogus-handlers (length bogus-handlers))
245     (remove-them () :report "Remove bogus handlers."
246     (setf *descriptor-handlers*
247     (delete-if #'handler-bogus *descriptor-handlers*)))
248     (retry-them () :report "Retry bogus handlers."
249     (dolist (handler bogus-handlers)
250     (setf (handler-bogus handler) nil)))
251     (continue () :report "Go on, leaving handlers marked as bogus."))))
252    
253    
254    
255     ;;;; Serve-all-events, serve-event, and friends.
256    
257 ram 1.2 (defvar *display-event-handlers* nil
258     "This is an alist mapping displays to user functions to be called when
259     SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
260     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
261     should be represented here only once.")
262    
263 ram 1.1 ;;; SERVE-ALL-EVENTS -- public
264     ;;;
265     ;;; Wait for up to timeout seconds for an event to happen. Make sure all
266     ;;; pending events are processed before returning.
267     ;;;
268     (defun serve-all-events (&optional timeout)
269     "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
270     SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
271     0 until all events have been served. SERVE-ALL-EVENTS returns T if
272     SERVE-EVENT did something and NIL if not."
273     (do ((res nil)
274     (sval (serve-event timeout) (serve-event 0)))
275     ((null sval) res)
276     (setq res t)))
277    
278 ram 1.2
279 ram 1.1 ;;; SERVE-EVENT -- public
280     ;;;
281     ;;; Serve a single event.
282     ;;;
283     (defun serve-event (&optional timeout)
284     "Receive on all ports and Xevents and dispatch to the appropriate handler
285     function. If timeout is specified, server will wait the specified time (in
286     seconds) and then return, otherwise it will wait until something happens.
287     Server returns T if something happened and NIL otherwise."
288     ;; First, check any X displays for any pending events.
289 ram 1.6 #+clx
290 ram 1.2 (dolist (d/h *display-event-handlers*)
291 ram 1.1 (let ((d (car d/h)))
292     (when (xlib::event-listen d)
293     (handler-bind ((error #'(lambda (condx)
294     (declare (ignore condx))
295     (flush-display-events d))))
296     (funcall (cdr d/h) d))
297     (return-from serve-event t))))
298     ;; Next, wait for something to happen.
299     (multiple-value-bind
300     (value readable writeable)
301     (wait-for-event timeout)
302     ;; Now see what it was (if anything)
303 wlott 1.3 (cond #+nil
304     ((eq value server-unique-object)
305 ram 1.1 ;; The interrupt handler fired.
306     (grab-message-loop)
307     t)
308     ((numberp value)
309     (unless (zerop value)
310     ;; Check the descriptors.
311     (let ((result nil))
312     (dolist (handler *descriptor-handlers*)
313     (when (not (zerop (logand (ash 1 (handler-descriptor handler))
314 ram 1.5 (ecase (handler-direction handler)
315 ram 1.1 (:input readable)
316     (:output writeable)))))
317     (unwind-protect
318     (progn
319     ;; Doesn't work -- ACK
320     ;(setf (handler-active handler) t)
321     (funcall (handler-function handler)
322     (handler-descriptor handler)))
323     (setf (handler-active handler) nil))
324     (macrolet ((frob (var)
325     `(setf ,var
326     (logand (lognot (ash 1
327     (handler-descriptor
328     handler)))
329     ,var))))
330 ram 1.5 (ecase (handler-direction handler)
331 ram 1.1 (:input (frob readable))
332     (:output (frob writeable))))
333     (setf result t)))
334     result)))
335     ((eql readable mach:eintr)
336     ;; We did an interrupt.
337     t)
338     (t
339     ;; One of the file descriptors is bad.
340     (handler-descriptors-error)
341     nil))))
342    
343     ;;; WAIT-FOR-EVENT -- internal
344     ;;;
345     ;;; Wait for something to happen.
346     ;;;
347     (defun wait-for-event (&optional timeout)
348     "Wait for an something to show up on one of the file descriptors or a message
349     interupt to fire. Timeout is in seconds."
350     (let (old-mask)
351     (multiple-value-bind (timeout-sec timeout-usec)
352     (if timeout
353     (truncate (round (* timeout 1000000)) 1000000)
354     (values nil 0))
355     (multiple-value-bind (count read-mask write-mask except-mask)
356     (calc-masks)
357     (catch 'server-catch
358     (unwind-protect
359     (progn
360     ;; Block message interrupts.
361 wlott 1.3 (setf old-mask (mach:unix-sigblock (mach:sigmask :sigmsg)))
362 ram 1.1 ;; Check for any pending messages, because we are only signaled
363     ;; for newly arived messages. This must be done after the
364     ;; unix-sigsetmask.
365 wlott 1.3 #+nil
366 ram 1.1 (when (grab-message-loop)
367     (return-from wait-for-event t))
368     ;; Indicate that we are in the server.
369     (let ((*in-server* t))
370     ;; Establish the interrupt handlers.
371 wlott 1.3 #+nil
372 ram 1.1 (enable-interrupt mach:sigmsg #'ih-sigmsg)
373     ;; Enable all interrupts.
374     (mach:unix-sigsetmask 0)
375     ;; Do the select.
376     (mach:unix-select count read-mask write-mask except-mask
377     timeout-sec timeout-usec)))
378     ;; Restore interrupt handler state.
379 wlott 1.3 #+nil
380     (mach:unix-sigblock (mach:sigmask :sigmsg))
381     #+nil
382 ram 1.1 (default-interrupt mach:sigmsg)
383 wlott 1.4 (when old-mask
384     (mach:unix-sigsetmask old-mask))))))))

  ViewVC Help
Powered by ViewVC 1.1.5