X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fserve-event.lisp;h=8fd5321f8e5ea3f9a658b8a0d820c1633bd8d9d1;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=55482c4ed481406f16b3751c0754cd8f2feaa724;hpb=cb7837b769ce190baec60a2159c33099816ea6e3;p=sbcl.git

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index 55482c4..8fd5321 100644
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -8,78 +8,61 @@
 ;;;; files for more information.
 
 (in-package "SB!IMPL")
-
-#|
-;;;; 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))
 
-|#
-
 ;;;; 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
@@ -89,26 +72,30 @@
   (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)))
+  (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)
@@ -119,211 +106,226 @@
   (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)
+
 
 ;;;; 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)))))))
 
 ;;; 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)))))))