From dbc1b48749cb40ca38391cbf0ff5e1de1accacdc Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 12 Jan 2008 15:29:02 +0000 Subject: [PATCH] 1.0.13.25: reinstante *PERIODIC-POLLING-FUNCTION* * Instead of *MAX-EVENT-(U)SEC* use *PERIODIC-POLLING-PERIOD*. * After polling, if there is any more waiting left to do, call SUB-SERVE-EVENT again. (The old implementation did not do this, but this seems right to me.) * Export the API, and mark as EXPERIMENTAL. Unadvertised in the docs or NEWS for now -- but the docstrings should be clear enough. Waiting for happiness report from CLG folks before publishing this. --- package-data-list.lisp-expr | 2 + src/code/deadline.lisp | 4 +- src/code/serve-event.lisp | 150 ++++++++++++++++++++++++++----------------- version.lisp-expr | 2 +- 4 files changed, 98 insertions(+), 60 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a8b42e0..4833596 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2032,6 +2032,8 @@ SB-KERNEL) have been undone, but probably more remain." "*INTERRUPT-PENDING*" "*LINKAGE-INFO*" "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" + "*PERIODIC-POLLING-FUNCTION*" + "*PERIODIC-POLLING-PERIOD*" "*RUNTIME-DLHANDLE*" "*SHARED-OBJECTS*" "*STATIC-FOREIGN-SYMBOLS*" diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 413eb86..6deb829 100644 --- a/src/code/deadline.lisp +++ b/src/code/deadline.lisp @@ -92,7 +92,8 @@ for calling this when a deadline is reached." (new-deadline (+ (seconds-to-internal-time new-deadline-seconds) (get-internal-real-time)))) (setf *deadline* new-deadline - *deadline-seconds* new-deadline-seconds)))))) + *deadline-seconds* new-deadline-seconds))))) + nil) (defun defer-deadline (seconds &optional condition) "Find the DEFER-DEADLINE restart associated with CONDITION, and @@ -158,3 +159,4 @@ it will signal a timeout condition." (decode-internal-time final-deadline) (values to-sec to-usec stop-sec stop-usec signalp))) (values nil nil nil nil nil))))))) + diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index af16665..aa35856 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -200,66 +200,100 @@ 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))) +;;; 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.") + ;;; Takes timeout broken into seconds and microseconds. (defun sub-serve-event (to-sec to-usec deadlinep) - ;; Next, wait for something to happen. - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) - (write-fds (sb!alien:struct sb!unix:fd-set))) + ;; Figure out our peridic polling needs. MORE-SEC/USEC is the amount + ;; of actual waiting left after we poll (assuming we are polling.) + (multiple-value-bind (poll more-sec more-usec) + (when *periodic-polling-function* + (multiple-value-bind (p-sec p-usec) + (decode-internal-time + (seconds-to-internal-time *periodic-polling-period*)) + (when (or (not to-sec) (> to-sec p-sec) + (and (= to-sec p-sec) (> to-usec p-usec))) + (multiple-value-prog1 + (values *periodic-polling-function* + (when to-sec (- to-sec p-sec)) + (when to-sec (- to-usec p-usec))) + (setf to-sec p-sec + to-usec p-sec))))) + + ;; Next, wait for something to happen. + (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) + (sb!unix:unix-fast-select count + (sb!alien:addr read-fds) + (sb!alien:addr write-fds) + nil to-sec to-usec) + #!+win32 + (declare (ignore err)) + ;; Now see what it was (if anything) + (cond ((not value) + ;; Interrupted or one of the file descriptors is bad. + ;; FIXME: Check for other errnos. Why do we return true + ;; when interrupted? + #!-win32 + (if (eql err sb!unix:eintr) + t + (handler-descriptors-error)) + #!+win32 + (handler-descriptors-error)) + ((plusp value) + ;; Got something. Call file descriptor handlers + ;; according to the readable and writable masks + ;; returned by select. + (dolist (handler + (select-descriptor-handlers + (lambda (handler) + (let ((fd (handler-descriptor handler))) + (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) + ;; Timeout. + (cond (poll + (funcall poll) + (sub-serve-event more-sec more-usec deadlinep)) + (deadlinep + (signal-deadline)))))))))) - ;; Next, wait for something to happen. - (multiple-value-bind (value err) - (sb!unix:unix-fast-select count - (sb!alien:addr read-fds) - (sb!alien:addr write-fds) - nil to-sec to-usec) - #!+win32 - (declare (ignore err)) - ;; Now see what it was (if anything) - (cond ((not value) - ;; Interrupted or one of the file descriptors is bad. - ;; FIXME: Check for other errnos. Why do we return true - ;; when interrupted? - #!-win32 - (if (eql err sb!unix:eintr) - t - (handler-descriptors-error)) - #!+win32 - (handler-descriptors-error)) - ((plusp value) - ;; Got something. Call file descriptor handlers - ;; according to the readable and writable masks - ;; returned by select. - (dolist (handler - (select-descriptor-handlers - (lambda (handler) - (let ((fd (handler-descriptor handler))) - (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)))))) diff --git a/version.lisp-expr b/version.lisp-expr index afb5f07..83f0d21 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.13.24" +"1.0.13.25" -- 1.7.10.4