1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / serve-event.lisp

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index 508d465..8fd5321 100644 (file)
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -72,6 +72,8 @@
   (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*))
@@ -173,15 +175,9 @@ waiting."
        (flet ((maybe-update-timeout ()
                 ;; If we return early, recompute the timeouts, possibly
                 ;; signaling the deadline or returning with NIL to caller.
-                (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) (and (zerop to-sec) (not (plusp to-usec))))
+                (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))
@@ -209,10 +205,15 @@ waiting."
              (loop for to-msec = (if (and to-sec to-usec)
                                      (+ (* 1000 to-sec) (truncate to-usec 1000))
                                      -1)
-                   when (sb!unix:unix-simple-poll fd direction to-msec)
+                   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))))))))
+                   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.
@@ -320,7 +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)))
+                 (with-simple-restart (remove-fd-handler "Remove ~S" handler)
+                   (funcall (handler-function handler)
+                            (handler-descriptor handler))
+                   (go :next))
+                 (remove-fd-handler handler)
+                 :next)
                t))))))