From a58d9330f21749a3322cb3f0c3f36882e074544b Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 17 Jul 1992 18:16:26 +0000 Subject: [PATCH] Changed timeout handling to work for non-integer timeouts. Moved wait-until-fd-usable into the serve-event block so that it could share timeout hackery. Compiled with efficiency notes & tweaked declarations. Broke serve-event into a couple of functions for readability. --- code/serve-event.lisp | 226 ++++++++++++++++++++++++------------------ 1 file changed, 128 insertions(+), 98 deletions(-) diff --git a/code/serve-event.lisp b/code/serve-event.lisp index 918ec4a73..1bec1aa73 100644 --- a/code/serve-event.lisp +++ b/code/serve-event.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.15 1992/03/26 03:17:26 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.16 1992/07/17 18:16:26 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -222,47 +222,6 @@ (when ,handler (remove-fd-handler ,handler)))))) -;;; WAIT-UNTIL-FD-USABLE -- Public. -;;; -;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is -;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will -;;; timeout at the correct time irrespective of how many events are handled in -;;; the meantime. -;;; -(defun wait-until-fd-usable (fd direction &optional timeout) - "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or - :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving - up." - (declare (type (or index null) timeout)) - (let (usable) - (multiple-value-bind - (stop-sec stop-usec) - (if timeout - (multiple-value-bind (okay sec usec) - (unix:unix-gettimeofday) - (declare (ignore okay)) - (values (the (unsigned-byte 32) (+ sec timeout)) - usec)) - (values 0 0)) - (declare (type (unsigned-byte 32) stop-sec stop-usec)) - (with-fd-handler (fd direction #'(lambda (fd) - (declare (ignore fd)) - (setf usable t))) - (loop - (serve-event timeout) - - (when usable - (return t)) - - (when timeout - (multiple-value-bind (okay sec usec) - (unix:unix-gettimeofday) - (declare (ignore okay)) - (when (or (> sec stop-sec) - (and (= sec stop-sec) (>= usec stop-usec))) - (return nil)) - (setq timeout (- stop-sec sec))))))))) - ;;; HANDLER-DESCRIPTORS-ERROR -- Internal. ;;; @@ -290,7 +249,76 @@ ;;;; Serve-all-events, serve-event, and friends. -(declaim (start-block serve-event serve-all-events)) +(declaim (start-block wait-until-fd-usable start-block serve-event + serve-all-events)) + +;;; DECODE-TIMEOUT -- Internal +;;; +;;; Break a real timeout into seconds and microseconds. +;;; +(defun decode-timeout (timeout) + (declare (values (or index null) index)) + (typecase timeout + (integer (values timeout 0)) + (null (values nil 0)) + (real + (multiple-value-bind (q r) + (truncate (coerce timeout 'single-float)) + (declare (type index q) (single-float r)) + (values q (the index (truncate (* r 1f6)))))) + (t + (error "Timeout is not a real number or NIL: ~S" timeout)))) + + +;;; WAIT-UNTIL-FD-USABLE -- Public. +;;; +;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is +;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will +;;; timeout at the correct time irrespective of how many events are handled in +;;; the meantime. +;;; +(defun wait-until-fd-usable (fd direction &optional timeout) + "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or + :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving + up." + (declare (type (or real null) timeout)) + (let (usable) + (multiple-value-bind (to-sec to-usec) + (decode-timeout timeout) + (declare (type (or index null) to-sec to-usec)) + (multiple-value-bind + (stop-sec stop-usec) + (if to-sec + (multiple-value-bind (okay start-sec start-usec) + (unix:unix-gettimeofday) + (declare (ignore okay)) + (let ((usec (+ to-usec start-usec)) + (sec (+ to-sec start-sec))) + (declare (type (unsigned-byte 31) usec sec)) + (if (>= usec 1000000) + (values (1+ sec) (- usec 1000000)) + (values sec usec)))) + (values 0 0)) + (declare (type (unsigned-byte 31) stop-sec stop-usec)) + (with-fd-handler (fd direction #'(lambda (fd) + (declare (ignore fd)) + (setf usable t))) + (loop + (sub-serve-event to-sec to-usec) + + (when usable + (return t)) + + (when timeout + (multiple-value-bind (okay sec usec) + (unix:unix-gettimeofday) + (declare (ignore okay)) + (when (or (> sec stop-sec) + (and (= sec stop-sec) (>= usec stop-usec))) + (return nil)) + (setq to-sec (- stop-sec sec)) + (setq to-usec (- stop-usec usec)))))))))) + (defvar *display-event-handlers* nil "This is an alist mapping displays to user functions to be called when @@ -323,8 +351,15 @@ function. If timeout is specified, server will wait the specified time (in seconds) and then return, otherwise it will wait until something happens. Server returns T if something happened and NIL otherwise." - ;; First, check any X displays for any pending events. - #+clx + (multiple-value-bind (to-sec to-usec) + (decode-timeout timeout) + (sub-serve-event to-sec to-usec))) + + +;;; Check for any X displays with pending events. +;;; +#+clx +(defun handle-queued-clx-event () (dolist (d/h *display-event-handlers*) (let* ((d (car d/h)) (disp-fd (fd-stream-fd (xlib::display-input-stream d)))) @@ -345,41 +380,61 @@ (disable-clx-event-handling d) (error "Event-listen was true, but handler didn't handle: ~%~S" d/h))) - (return-from serve-event t)))) + (return-from handle-queued-clx-event t))))) + + +;;; Call file descriptor handlers according to the readable and writable masks +;;; returned by select. +;;; +(defun call-fd-handler (readable writeable) + (let ((result nil)) + (dolist (handler *descriptor-handlers*) + (when (logbitp (handler-descriptor handler) + (ecase (handler-direction handler) + (:input readable) + (:output writeable))) + (unwind-protect + (progn + ;; Doesn't work -- ACK + ;(setf (handler-active handler) t) + (funcall (handler-function handler) + (handler-descriptor handler))) + (setf (handler-active handler) nil)) + (macrolet ((frob (var) + `(setf ,var + (logand (32bit-logical-not + (ash 1 + (handler-descriptor + handler))) + ,var)))) + (ecase (handler-direction handler) + (:input (frob readable)) + (:output (frob writeable)))) + (setf result t))) + result)) + + +;;; SUB-SERVE-EVENT -- Internal +;;; +;;; Takes timeout broken into seconds and microseconds. +;;; +(defun sub-serve-event (to-sec to-usec) + #+clx + (when (handle-queued-clx-event) (return-from sub-serve-event t)) + ;; Next, wait for something to happen. (multiple-value-bind (value readable writeable) - (wait-for-event timeout) + (multiple-value-bind (count read-mask write-mask except-mask) + (calc-masks) + ;; Do the select. + (unix:unix-select count read-mask write-mask except-mask + to-sec to-usec)) (declare (type (unsigned-byte 32) readable writeable)) ;; Now see what it was (if anything) (cond ((fixnump value) (unless (zerop value) - ;; Check the descriptors. - (let ((result nil)) - (dolist (handler *descriptor-handlers*) - (when (logbitp (handler-descriptor handler) - (ecase (handler-direction handler) - (:input readable) - (:output writeable))) - (unwind-protect - (progn - ;; Doesn't work -- ACK - ;(setf (handler-active handler) t) - (funcall (handler-function handler) - (handler-descriptor handler))) - (setf (handler-active handler) nil)) - (macrolet ((frob (var) - `(setf ,var - (logand (32bit-logical-not - (ash 1 - (handler-descriptor - handler))) - ,var)))) - (ecase (handler-direction handler) - (:input (frob readable)) - (:output (frob writeable)))) - (setf result t))) - result))) + (call-fd-handler readable writeable))) ((eql readable unix:eintr) ;; We did an interrupt. t) @@ -421,28 +476,3 @@ read-mask write-mask except-mask))) - -;;; WAIT-FOR-EVENT -- internal -;;; -;;; Wait for something to happen. -;;; -(defun wait-for-event (&optional timeout) - "Wait for an something to show up on one of the file descriptors or a message - interupt to fire. Timeout is in seconds." - (multiple-value-bind - (timeout-sec timeout-usec) - (typecase timeout - (integer (values timeout 0)) - (null (values nil 0)) - (t - (multiple-value-bind (q r) - (truncate (coerce timeout 'single-float)) - (declare (type index q) (single-float r)) - (values q (truncate (* r 1f6)))))) - (declare (type index timeout-usec) - (type (or index null) timeout-sec)) - (multiple-value-bind (count read-mask write-mask except-mask) - (calc-masks) - ;; Do the select. - (unix:unix-select count read-mask write-mask except-mask - timeout-sec timeout-usec)))) -- GitLab