;;;; files for more information.
(in-package "SB!IMPL")
-\f
-#|
-;;;; object set stuff
-
-;;; a hashtable from ports to objects. Each entry is a cons (object . set).
-;(defvar *port-table* (make-hash-table :test 'eql))
-
-(defstruct (object-set
- (:constructor make-object-set
- (name &optional
- (default-handler #'default-default-handler)))
- (:print-object
- (lambda (s stream)
- (format stream "#<Object Set ~S>" (object-set-name s))))
- (:copier nil))
- name ; Name, for descriptive purposes.
- (table (make-hash-table :test 'eq)) ; Message-ID or
- ; xevent-type --> handler fun.
- default-handler)
-
-#!+sb-doc
-(setf (fdocumentation 'make-object-set 'function)
- "Make an object set for use by a RPC/xevent server. Name is for
- descriptive purposes only.")
-
-;;; If no such operation defined, signal an error.
-(defun default-default-handler (object)
- (error "You lose, object: ~S" object))
-
-;;; Look up the handler function for a given message ID.
-(defun object-set-operation (object-set message-id)
- #!+sb-doc
- "Return the handler function in Object-Set for the operation specified by
- Message-ID, if none, NIL is returned."
- (enforce-type object-set object-set)
- (enforce-type message-id fixnum)
- (values (gethash message-id (object-set-table object-set))))
-
-;;; The setf inverse for Object-Set-Operation.
-(defun %set-object-set-operation (object-set message-id new-value)
- (enforce-type object-set object-set)
- (enforce-type message-id fixnum)
- (setf (gethash message-id (object-set-table object-set)) new-value))
-|#
-\f
;;;; file descriptor I/O noise
(defstruct (handler
- (:constructor make-handler (direction descriptor function))
- (:copier nil))
+ (:constructor make-handler (direction descriptor function))
+ (:copier nil))
;; Reading or writing...
(direction nil :type (member :input :output))
;; File descriptor this handler is tied to.
(descriptor 0 :type (mod #.sb!unix:fd-setsize))
+ ;; T iff this handler is running.
+ ;;
+ ;; FIXME: unused. At some point this used to be set to T
+ ;; around the call to the handler-function, but that was commented
+ ;; out with the verbose explantion "Doesn't work -- ACK".
+ active
+ ;; Function to call.
+ (function nil :type function)
+ ;; T if this descriptor is bogus.
+ bogus)
- active ; T iff this handler is running.
- (function nil :type function) ; Function to call.
- bogus) ; T if this descriptor is bogus.
(def!method print-object ((handler handler) stream)
(print-unreadable-object (handler stream :type t)
(format stream
- "~A on ~:[~;BOGUS ~]descriptor ~D: ~S"
- (handler-direction handler)
- (handler-bogus handler)
- (handler-descriptor handler)
- (handler-function handler))))
+ "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
+ (handler-direction handler)
+ (handler-bogus handler)
+ (handler-descriptor handler)
+ (handler-function handler))))
(defvar *descriptor-handlers* nil
#!+sb-doc
"List of all the currently active handlers for file descriptors")
+(sb!xc:defmacro with-descriptor-handlers (&body forms)
+ ;; FD-STREAM functionality can add and remove descriptors on it's
+ ;; own, so getting an interrupt while modifying this and the
+ ;; starting to recursively modify it could lose...
+ `(without-interrupts ,@forms))
+
+(defun list-all-descriptor-handlers ()
+ (with-descriptor-handlers
+ (copy-list *descriptor-handlers*)))
+
+(defun select-descriptor-handlers (function)
+ (declare (function function))
+ (with-descriptor-handlers
+ (remove-if-not function *descriptor-handlers*)))
+
+(defun map-descriptor-handlers (function)
+ (declare (function function))
+ (with-descriptor-handlers
+ (dolist (handler *descriptor-handlers*)
+ (funcall function handler))))
+
;;; 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)))
- (push handler *descriptor-handlers*)
+ (with-descriptor-handlers
+ (push handler *descriptor-handlers*))
handler))
;;; Remove an old handler from *descriptor-handlers*.
(defun remove-fd-handler (handler)
#!+sb-doc
"Removes HANDLER from the list of active handlers."
- (setf *descriptor-handlers*
- (delete handler *descriptor-handlers*
- :test #'eq)))
+ (with-descriptor-handlers
+ (setf *descriptor-handlers*
+ (delete handler *descriptor-handlers*))))
;;; 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."
- (setf *descriptor-handlers*
- (delete fd *descriptor-handlers*
- :key #'handler-descriptor)))
+ "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*
+ :key #'handler-descriptor))))
;;; Add the handler to *descriptor-handlers* for the duration of BODY.
(defmacro with-fd-handler ((fd direction function) &rest body)
(let ((handler (gensym)))
`(let (,handler)
(unwind-protect
- (progn
- (setf ,handler (add-fd-handler ,fd ,direction ,function))
- ,@body)
- (when ,handler
- (remove-fd-handler ,handler))))))
+ (progn
+ (setf ,handler (add-fd-handler ,fd ,direction ,function))
+ ,@body)
+ (when ,handler
+ (remove-fd-handler ,handler))))))
;;; First, get a list and mark bad file descriptors. Then signal an error
;;; offering a few restarts.
(defun handler-descriptors-error ()
(let ((bogus-handlers nil))
- (dolist (handler *descriptor-handlers*)
+ (dolist (handler (list-all-descriptor-handlers))
(unless (or (handler-bogus handler)
- (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."
- (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."))))
+ (sb!unix:unix-fstat (handler-descriptor handler)))
+ (setf (handler-bogus handler) t)
+ (push handler bogus-handlers)))
+ (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)
+
\f
;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
-;;; 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 (values index t) (truncate (* r 1f6))))))
- (t
- (error "Timeout is not a real number or NIL: ~S" timeout))))
+;;; 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."
- (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)
- (sb!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)
+:OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
+up. Returns true once the FD is usable, NIL return indicates timeout.
- (when usable
- (return t))
-
- (when timeout
- (multiple-value-bind (okay sec usec) (sb!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))
- (cond ((> usec stop-usec)
- (decf to-sec)
- (setq to-usec (- (+ stop-usec 1000000) usec)))
- (t
- (setq to-usec (- stop-usec usec))))))))))))
+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)))))))
\f
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
(defun serve-all-events (&optional timeout)
#!+sb-doc
"SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
- SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
- 0 until all events have been served. SERVE-ALL-EVENTS returns T if
- SERVE-EVENT did something and NIL if not."
+SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
+timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
+T if SERVE-EVENT did something and NIL if not."
(do ((res nil)
(sval (serve-event timeout) (serve-event 0)))
((null sval) res)
(setq res t)))
-;;; Serve a single event.
+;;; Serve a single set of events.
(defun serve-event (&optional timeout)
#!+sb-doc
- "Receive on all ports and Xevents and dispatch to the appropriate handler
- 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."
- (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
- (sub-serve-event to-sec to-usec)))
-
-;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
-;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
-;;; if passed as function arguments.)
-(eval-when (:compile-toplevel :execute)
-
-;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
-;;; count.
-(sb!xc:defmacro calc-masks ()
- '(progn
- (sb!unix:fd-zero read-fds)
- (sb!unix:fd-zero write-fds)
- (let ((count 0))
- (declare (type index count))
- (dolist (handler *descriptor-handlers*)
- (unless (or (handler-active handler)
- (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)))))
- (1+ count))))
+ "Receive pending events on all FD-STREAMS and dispatch to the appropriate
+handler functions. 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. Timeout
+0 means polling without waiting."
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
+ (decode-timeout timeout)
+ (declare (ignore stop-sec stop-usec))
+ (sub-serve-event to-sec to-usec signalp)))
-;;; Call file descriptor handlers according to the readable and writable masks
-;;; returned by select.
-(sb!xc:defmacro call-fd-handler ()
- '(let ((result nil))
- (dolist (handler *descriptor-handlers*)
- (let ((desc (handler-descriptor handler)))
- (when (ecase (handler-direction handler)
- (:input (sb!unix:fd-isset desc read-fds))
- (:output (sb!unix:fd-isset desc write-fds)))
- (unwind-protect
- (progn
- ;; Doesn't work -- ACK
- ;(setf (handler-active handler) t)
- (funcall (handler-function handler) desc))
- (setf (handler-active handler) nil))
- (ecase (handler-direction handler)
- (:input (sb!unix:fd-clr desc read-fds))
- (:output (sb!unix:fd-clr desc write-fds)))
- (setf result t)))
- result)))
+;;; 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)
+ (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))))
-) ; EVAL-WHEN
-
-;;; 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. One important use of this
-;;; is to periodically call process-yield.
-(declaim (type (or null function) *periodic-polling-function*))
-(defvar *periodic-polling-function*
- #!-mp nil #!+mp #'sb!mp:process-yield)
-(declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
-(defvar *max-event-to-sec* 1)
-(defvar *max-event-to-usec* 0)
+;;; 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))
-;;; Takes timeout broken into seconds and microseconds.
-(defun sub-serve-event (to-sec to-usec)
- (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
+ ;; 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)
- (let ((call-polling-fn nil))
- (when (and *periodic-polling-function*
- ;; Enforce a maximum timeout.
- (or (null to-sec)
- (> to-sec *max-event-to-sec*)
- (and (= to-sec *max-event-to-sec*)
- (> to-usec *max-event-to-usec*))))
- (setf to-sec *max-event-to-sec*)
- (setf to-usec *max-event-to-usec*)
- (setf call-polling-fn t))
+ ;; 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
+ (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)
+ ;; 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)))))))
+ (with-simple-restart (remove-fd-handler "Remove ~S" handler)
+ (funcall (handler-function handler)
+ (handler-descriptor handler))
+ (go :next))
+ (remove-fd-handler handler)
+ :next)
+ t))))))
- ;; 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)))
- (let ((count (calc-masks)))
- (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)
-
- ;; Now see what it was (if anything)
- (cond (value
- (cond ((zerop value)
- ;; Timed out.
- (when call-polling-fn
- (funcall *periodic-polling-function*)))
- (t
- (call-fd-handler))))
- ((eql err sb!unix:eintr)
- ;; We did an interrupt.
- t)
- (t
- ;; One of the file descriptors is bad.
- (handler-descriptors-error)
- nil)))))))
projects / sbcl.git / blobdiff