X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fserve-event.lisp;h=b1a6eedca9364c9cb1c87ec298b35e29b459c06c;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=ed5c8dba48035877aa53229cc541ff1ab6225502;hpb=fe962ba01d267b92f638c8f0d19be41054219f04;p=sbcl.git diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index ed5c8db..b1a6eed 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -66,12 +66,14 @@ ;;; Add a new handler to *descriptor-handlers*. (defun add-fd-handler (fd direction function) #!+sb-doc - "Arange to call FUNCTION whenever FD is usable. DIRECTION should be + "Arrange to call FUNCTION whenever FD is usable. DIRECTION should be either :INPUT or :OUTPUT. The value returned should be passed to SYSTEM:REMOVE-FD-HANDLER when it is no longer needed." (unless (member direction '(:input :output)) ;; FIXME: should be TYPE-ERROR? (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)) + (unless (<= 0 fd (1- sb!unix:fd-setsize)) + (error "Cannot add an FD handler for ~D: not under FD_SETSIZE limit." fd)) (let ((handler (make-handler direction fd function))) (with-descriptor-handlers (push handler *descriptor-handlers*)) @@ -88,8 +90,8 @@ ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em. (defun invalidate-descriptor (fd) #!+sb-doc - "Remove any handers refering to fd. This should only be used when attempting - to recover from a detected inconsistancy." + "Remove any handlers referring to FD. This should only be used when attempting + to recover from a detected inconsistency." (with-descriptor-handlers (setf *descriptor-handlers* (delete fd *descriptor-handlers* @@ -119,57 +121,99 @@ (sb!unix:unix-fstat (handler-descriptor handler))) (setf (handler-bogus handler) t) (push handler bogus-handlers))) - (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." - bogus-handlers (length bogus-handlers)) - (remove-them () - :report "Remove bogus handlers." - (with-descriptor-handlers - (setf *descriptor-handlers* - (delete-if #'handler-bogus *descriptor-handlers*)))) - (retry-them () - :report "Retry bogus handlers." - (dolist (handler bogus-handlers) - (setf (handler-bogus handler) nil))) - (continue () - :report "Go on, leaving handlers marked as bogus."))) + (when bogus-handlers + (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." + bogus-handlers (length bogus-handlers)) + (remove-them () + :report "Remove bogus handlers." + (with-descriptor-handlers + (setf *descriptor-handlers* + (delete-if #'handler-bogus *descriptor-handlers*)))) + (retry-them () + :report "Retry bogus handlers." + (dolist (handler bogus-handlers) + (setf (handler-bogus handler) nil))) + (continue () + :report "Go on, leaving handlers marked as bogus.")))) nil) ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends +;;; When a *periodic-polling-function* is defined the server will not +;;; block for more than the maximum event timeout and will call the +;;; polling function if it does time out. +(declaim (type (or null symbol function) *periodic-polling-function*)) +(defvar *periodic-polling-function* nil + "Either NIL, or a designator for a function callable without any +arguments. Called when the system has been waiting for input for +longer then *PERIODIC-POLLING-PERIOD* seconds. Shared between all +threads, unless locally bound. EXPERIMENTAL.") +(declaim (real *periodic-polling-period*)) +(defvar *periodic-polling-period* 0 + "A real number designating the number of seconds to wait for input +at maximum, before calling the *PERIODIC-POLLING-FUNCTION* \(if any.) +Shared between all threads, unless locally bound. EXPERIMENTAL.") + ;;; 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) +(defun wait-until-fd-usable (fd direction &optional timeout (serve-events t)) #!+sb-doc "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." - (let (usable) - (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp) - (decode-timeout timeout) - (declare (type (or integer null) to-sec to-usec)) - (with-fd-handler (fd direction (lambda (fd) - (declare (ignore fd)) - (setf usable t))) - (loop - (sub-serve-event to-sec to-usec signalp) - (when usable - (return t)) - (when to-sec - (multiple-value-bind (sec usec) - (decode-internal-time (get-internal-real-time)) - (setf to-sec (- stop-sec sec)) - (cond ((> usec stop-usec) - (decf to-sec) - (setf to-usec (- (+ stop-usec 1000000) usec))) - (t - (setf to-usec (- stop-usec usec))))) - (when (or (minusp to-sec) (minusp to-usec)) - (if signalp - (signal-deadline) - (return nil))))))))) +up. Returns true once the FD is usable, NIL return indicates timeout. + +If SERVE-EVENTS is true (the default), events on other FDs are served while +waiting." + (tagbody + :restart + (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp) + (decode-timeout timeout) + (declare (type (or integer null) to-sec to-usec)) + (flet ((maybe-update-timeout () + ;; If we return early, recompute the timeouts, possibly + ;; signaling the deadline or returning with NIL to caller. + (setf (values to-sec to-usec) + (relative-decoded-times stop-sec stop-usec)) + (when (and (zerop to-sec) (not (plusp to-usec))) + (cond (signalp + (signal-deadline) + (go :restart)) + (t + (return-from wait-until-fd-usable nil)))))) + (if (and serve-events + ;; No timeout or non-zero timeout + (or (not to-sec) + (not (= 0 to-sec to-usec))) + ;; Something to do while we wait + (or *descriptor-handlers* *periodic-polling-function*)) + ;; Loop around SUB-SERVE-EVENT till done. + (dx-let ((usable (list nil))) + (dx-flet ((usable! (fd) + (declare (ignore fd)) + (setf (car usable) t))) + (with-fd-handler (fd direction #'usable!) + (loop + (sub-serve-event to-sec to-usec signalp) + (when (car usable) + (return-from wait-until-fd-usable t)) + (when to-sec + (maybe-update-timeout)))))) + ;; If we don't have to serve events, just poll on the single FD instead. + (loop for to-msec = (if (and to-sec to-usec) + (+ (* 1000 to-sec) (truncate to-usec 1000)) + -1) + when (or #!+win32 (eq direction :output) + #!+win32 (sb!win32:handle-listen + (sb!win32:get-osfhandle fd)) + #!-win32 + (sb!unix:unix-simple-poll fd direction to-msec)) + do (return-from wait-until-fd-usable t) + else + do (when to-sec (maybe-update-timeout)) + #!+win32 (sb!thread:thread-yield))))))) ;;; Wait for up to timeout seconds for an event to happen. Make sure all ;;; pending events are processed before returning. @@ -197,31 +241,49 @@ happens. Server returns T if something happened and NIL otherwise. Timeout (declare (ignore stop-sec stop-usec)) (sub-serve-event to-sec to-usec signalp))) -;;; Takes timeout broken into seconds and microseconds. +;;; Takes timeout broken into seconds and microseconds, NIL timeout means +;;; to wait as long as needed. (defun sub-serve-event (to-sec to-usec deadlinep) - ;; Next, wait for something to happen. + (or + (if *periodic-polling-function* + (multiple-value-bind (p-sec p-usec) + (decode-internal-time + (seconds-to-internal-time *periodic-polling-period*)) + (if to-sec + (loop repeat (/ (+ to-sec (/ to-usec 1e6)) + *periodic-polling-period*) + thereis (sub-sub-serve-event p-sec p-usec) + do (funcall *periodic-polling-function*)) + (loop thereis (sub-sub-serve-event p-sec p-usec) + do (funcall *periodic-polling-function*)))) + (sub-sub-serve-event to-sec to-usec)) + (when deadlinep + (signal-deadline)))) + +;;; Handles the work of the above, except for periodic polling. Returns +;;; true if something of interest happened. +(defun sub-sub-serve-event (to-sec to-usec) (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) (write-fds (sb!alien:struct sb!unix:fd-set))) + (sb!unix:fd-zero read-fds) + (sb!unix:fd-zero write-fds) + (let ((count 0)) + (declare (type index count)) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-zero write-fds) - (let ((count 0)) - (declare (type index count)) - - ;; Initialize the fd-sets for UNIX-SELECT and return the active - ;; descriptor count. - (map-descriptor-handlers - (lambda (handler) - ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs - ;; to be checked here in addition to HANDLER-BOGUS - (unless (handler-bogus handler) - (let ((fd (handler-descriptor handler))) - (ecase (handler-direction handler) - (:input (sb!unix:fd-set fd read-fds)) - (:output (sb!unix:fd-set fd write-fds))) - (when (> fd count) - (setf count fd)))))) - (incf count) + ;; Initialize the fd-sets for UNIX-SELECT and return the active + ;; descriptor count. + (map-descriptor-handlers + (lambda (handler) + ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs + ;; to be checked here in addition to HANDLER-BOGUS + (unless (handler-bogus handler) + (let ((fd (handler-descriptor handler))) + (ecase (handler-direction handler) + (:input (sb!unix:fd-set fd read-fds)) + (:output (sb!unix:fd-set fd write-fds))) + (when (> fd count) + (setf count fd)))))) + (incf count) ;; Next, wait for something to happen. (multiple-value-bind (value err) @@ -237,9 +299,15 @@ happens. Server returns T if something happened and NIL otherwise. Timeout ;; FIXME: Check for other errnos. Why do we return true ;; when interrupted? #!-win32 - (if (eql err sb!unix:eintr) - t - (handler-descriptors-error)) + (case err + (#.sb!unix:ebadf + (handler-descriptors-error)) + ((#.sb!unix:eintr #.sb!unix:eagain) + t) + (otherwise + (with-simple-restart (continue "Ignore failure and continue.") + (simple-perror "Unix system call select() failed" + :errno err)))) #!+win32 (handler-descriptors-error)) ((plusp value) @@ -253,10 +321,11 @@ happens. Server returns T if something happened and NIL otherwise. Timeout (ecase (handler-direction handler) (:input (sb!unix:fd-isset fd read-fds)) (:output (sb!unix:fd-isset fd write-fds))))))) - (funcall (handler-function handler) - (handler-descriptor handler))) - t) - ((zerop value) - (when deadlinep - (signal-deadline)) - nil)))))) + (with-simple-restart (remove-fd-handler "Remove ~S" handler) + (funcall (handler-function handler) + (handler-descriptor handler)) + (go :next)) + (remove-fd-handler handler) + :next) + t)))))) +