1.0.42.43: FD-STREAMS no longer hook into SERVE-EVENT by default

* SOCKET-MAKE-STREAM, and MAKE-FD-STREAM have new keyword
   argument :SERVE-EVENTS which requests that blocking IO on the
   stream should dispatch to SERVE-EVENT. For SOCKET-MAKE-STREAM the
   default is T, for MAKE-FD-STREAM the default it NIL.

 * Don't call SYSREAD-MAY-BLOCK-P at all unless we need to to handle
   events or check for timeout.

 * Make WAIT-UNTIL-FD-USABLE use UNIX-SIMPLE-POLL instead of going
   into SUB-SERVE-EVENT when appropriate:

   ** Explicit requests to not serve events.

   ** Timeout 0.

   ** No other handlers and no periodic polling function.

 * When FD-STREAM-SERVE-EVENTS is false but write returns EWOULDBLOCK,
   don't queue output but wait till poll(2) says we can go.

 * UNIX-SIMPLE-POLL uses poll() only on platforms where a build-time
   test shows it to exist and work as expected. Elsewhere it is built
   on top of good 'ol select().

NEWS

@@ -1,5 +1,13 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.42
+  * incompatible change: FD-STREAMS no longer participate in the serve-event
+    event-loop by default.
+    ** In addition to streams created by explicit calls to MAKE-FD-STREAM this
+       affects streams from CL:OPEN.
+    ** Streams from SOCKET-MAKE-STREAM still participate in serve-event by
+       default, but this is liable to change: applications needing serve-event
+       for socket streams should explicitly request it using :SERVE-EVENTS T
+       in the call.
   * enhancement: SB-EXT:WORD type is provided for use with SB-EXT:ATOMIC-INCF
     &co.
   * enhancement: CLOS effective method functions and defclass slot typechecking
@@ -9,8 +17,8 @@ changes relative to sbcl-1.0.42
   * enhancement: symbols are printed using fully qualified names in several
     error and warning messages which are often associated with package
     conflicts or mixups (lp#622789, thanks to Attila Lendvai)
-  * optimization: use poll(2) instead of select(2) to check for blocking IO
+  * optimization: where available, use poll(2) instead of select(2) to check
-    on a single FD.
+    for blocking IO on a single FD.
   * bug fix: SB-BSD-SOCKETS:SOCKET-CONNECT was not thread safe. (lp#505497,
     thanks to Andrew Golding)
   * bug fix: DOTIMES accepted literal non-integer reals. (lp#619393, thanks to

contrib/sb-bsd-sockets/sockets.lisp

@@ -381,12 +381,17 @@ for the stream."))
                                (buffering :full)
                                (external-format :default)
                                timeout
-                               auto-close)
+                               auto-close
-  "Default method for SOCKET objects. An ELEMENT-TYPE of :DEFAULT will
+                               (serve-events t))
-construct a bivalent stream. Acceptable values for BUFFERING are :FULL, :LINE
+  "Default method for SOCKET objects.
+
+An ELEMENT-TYPE of :DEFAULT will construct a bivalent stream, capable of both
+binary and character IO. Acceptable values for BUFFERING are :FULL, :LINE
 and :NONE. Streams will have no TIMEOUT by default. If AUTO-CLOSE is true, the
 underlying OS socket is automatically closed after the stream and the socket
-have been garbage collected.
+have been garbage collected. If SERVE-EVENTS is true, blocking IO on the
+socket will dispatch to the recursive event loop -- the default is currently
+true, but this liable to change.
 
 The stream for SOCKET will be cached, and a second invocation of this method
 will return the same stream. This may lead to oddities if this function is
@@ -407,8 +412,9 @@ and get an output stream in response\)."
                     :buffering buffering
                     :external-format external-format
                     :timeout timeout
-                    :auto-close auto-close)))
+                    :auto-close auto-close
-      (setf (slot-value socket 'stream) stream)
+                    :serve-events serve-events))
+      (setf (slot-value socket 'stream) stream))
     (sb-ext:cancel-finalization socket)
     stream))
 

contrib/sb-rt/rt.lisp

@@ -185,7 +185,8 @@
                 (not (equalp-with-case r (vals entry)))))
 
       (when (pend entry)
-        (let ((*print-circle* *print-circle-on-failure*))
+        (let ((*print-circle* *print-circle-on-failure*)
+              (*print-escape* nil))
           (format s "~&Test ~:@(~S~) failed~
                    ~%Form: ~S~
                    ~%Expected value~P: ~

src/code/condition.lisp

@@ -1245,7 +1245,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
    (lambda (condition stream)
      (declare (type stream stream))
      (format stream
-             "I/O timeout ~(~A~)ing ~S."
+             "I/O timeout while doing ~(~A~) on ~S."
              (io-timeout-direction condition)
              (stream-error-stream condition)))))
 

src/code/fd-stream.lisp

@@ -169,6 +169,8 @@
   (char-pos nil :type (or unsigned-byte null))
   ;; T if input is waiting on FD. :EOF if we hit EOF.
   (listen nil :type (member nil t :eof))
+  ;; T if serve-event is allowed when this stream blocks
+  (serve-events nil :type boolean)
 
   ;; the input buffer
   (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
@@ -262,32 +264,45 @@
                (aver (< head tail))
                (%queue-and-replace-output-buffer stream))
               (t
-               ;; Try a non-blocking write, queue whatever is left over.
+               ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue
+               ;; whatever is left over. Otherwise wait until we can write.
                (aver (< head tail))
                (synchronize-stream-output stream)
-               (let ((length (- tail head)))
+               (loop
-                 (multiple-value-bind (count errno)
+                 (let ((length (- tail head)))
-                     (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
+                   (multiple-value-bind (count errno)
-                                         head length)
+                       (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
-                   (cond ((eql count length)
+                                           head length)
-                          ;; Complete write -- we can use the same buffer.
+                     (flet ((queue-or-wait ()
-                          (reset-buffer obuf))
+                              (if (fd-stream-serve-events stream)
-                         (count
+                                  (return (%queue-and-replace-output-buffer stream))
-                          ;; Partial write -- update buffer status and queue.
+                                  (or (wait-until-fd-usable (fd-stream-fd stream) :output
-                          ;; Do not use INCF! Another thread might have moved
+                                                            (fd-stream-timeout stream)
-                          ;; head...
+                                                            nil)
-                          (setf (buffer-head obuf) (+ count head))
+                                      (signal-timeout 'io-timeout
-                          (%queue-and-replace-output-buffer stream))
+                                                      :stream stream
-                         #!-win32
+                                                      :direction :output
-                         ((eql errno sb!unix:ewouldblock)
+                                                      :seconds (fd-stream-timeout stream))))))
-                          ;; Blocking, queue.
+                        (cond ((eql count length)
-                          (%queue-and-replace-output-buffer stream))
+                               ;; Complete write -- we can use the same buffer.
-                         (t
+                               (return (reset-buffer obuf)))
-                          (simple-stream-perror "Couldn't write to ~s"
+                              (count
-                                                stream errno)))))))))))
+                               ;; Partial write -- update buffer status and
+                               ;; queue or wait. Do not use INCF! Another
+                               ;; thread might have moved head...
+                               (setf (buffer-head obuf) (+ count head))
+                               (queue-or-wait))
+                              #!-win32
+                              ((eql errno sb!unix:ewouldblock)
+                               ;; Blocking, queue or wair.
+                               (queue-or-wait))
+                              (t
+                               (simple-stream-perror "Couldn't write to ~s"
+                                                     stream errno)))))))))))))
 
 ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
 (defun %queue-and-replace-output-buffer (stream)
+  (aver (fd-stream-serve-events stream))
   (let ((queue (fd-stream-output-queue stream))
         (later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
         (new (get-buffer)))
@@ -312,6 +327,7 @@
 ;;; This is called by the FD-HANDLER for the stream when output is
 ;;; possible.
 (defun write-output-from-queue (stream)
+  (aver (fd-stream-serve-events stream))
   (synchronize-stream-output stream)
   (let (not-first-p)
     (tagbody
@@ -951,10 +967,13 @@
            (errno 0)
            (count 0))
     (tagbody
-       ;; Check for blocking input before touching the stream, as if
+       ;; Check for blocking input before touching the stream if we are to
-       ;; we happen to wait we are liable to be interrupted, and the
+       ;; serve events: if the FD is blocking, we don't want to hang on the
-       ;; interrupt handler may use the same stream.
+       ;; write if we are to serve events or notice timeouts.
-       (if (sysread-may-block-p stream)
+       (if (and (or (fd-stream-serve-events stream)
+                    (fd-stream-timeout stream)
+                    *deadline*)
+                (sysread-may-block-p stream))
            (go :wait-for-input)
            (go :main))
        ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
@@ -966,8 +985,11 @@
      :wait-for-input
        ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
        ;; to wait for input if read tells us EWOULDBLOCK.
-       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream))
+       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)
-         (signal-timeout 'io-timeout :stream stream :direction :read
+                                     (fd-stream-serve-events stream))
+         (signal-timeout 'io-timeout
+                         :stream stream
+                         :direction :input
                          :seconds (fd-stream-timeout stream)))
      :main
        ;; Since the read should not block, we'll disable the
@@ -978,7 +1000,7 @@
        ;; resulting thunk is stack-allocatable.
        ((lambda (return-reason)
           (ecase return-reason
-            ((nil))             ; fast path normal cases
+            ((nil))                     ; fast path normal cases
             ((:wait-for-input) (go :wait-for-input))
             ((:closed-flame)   (go :closed-flame))
             ((:read-error)     (go :read-error))))
@@ -2062,6 +2084,7 @@
   (flush-output-buffer stream)
   (do ()
       ((null (fd-stream-output-queue stream)))
+    (aver (fd-stream-serve-events stream))
     (serve-all-events)))
 
 (defun fd-stream-get-file-position (stream)
@@ -2163,6 +2186,9 @@
 ;;; FILE is the name of the file (will be returned by PATHNAME).
 ;;;
 ;;; NAME is used to identify the stream when printed.
+;;;
+;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
+;;; handle blocking IO on the stream.
 (defun make-fd-stream (fd
                        &key
                        (input nil input-p)
@@ -2170,6 +2196,7 @@
                        (element-type 'base-char)
                        (buffering :full)
                        (external-format :default)
+                       serve-events
                        timeout
                        file
                        original
@@ -2198,6 +2225,7 @@
                                  :external-format external-format
                                  :bivalent-p (eq element-type :default)
                                  :char-size (external-format-char-size external-format)
+                                 :serve-events serve-events
                                  :timeout
                                  (if timeout
                                      (coerce timeout 'single-float)
@@ -2400,6 +2428,7 @@
                                       :delete-original delete-original
                                       :pathname pathname
                                       :dual-channel-p nil
+                                      :serve-events nil
                                       :input-buffer-p t
                                       :auto-close t))
                      (:probe
@@ -2474,6 +2503,7 @@
     (setf *stdin*
           (make-fd-stream 0 :name "standard input" :input t :buffering :line
                           :element-type :default
+                          :serve-events t
                           :external-format (stdstream-external-format nil)))
     (setf *stdout*
           (make-fd-stream 1 :name "standard output" :output t :buffering :line

src/code/serve-event.lisp

@@ -138,42 +138,81 @@
 
 ;;;; 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."
+up. Returns true once the FD is usable, NIL return indicates timeout.
-  (prog (usable)
+
+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))
-       (with-fd-handler (fd direction (lambda (fd)
+       (flet ((maybe-update-timeout ()
-                                        (declare (ignore fd))
+                ;; If we return early, recompute the timeouts, possibly
-                                        (setf usable t)))
+                ;; signaling the deadline or returning with NIL to caller.
-         (loop
+                (multiple-value-bind (sec usec)
-           (sub-serve-event to-sec to-usec signalp)
+                    (decode-internal-time (get-internal-real-time))
-           (when usable
+                  (setf to-sec (- stop-sec sec))
-             (return-from wait-until-fd-usable t))
+                  (cond ((> usec stop-usec)
-           (when to-sec
+                         (decf to-sec)
-             (multiple-value-bind (sec usec)
+                         (setf to-usec (- (+ stop-usec 1000000) usec)))
-                 (decode-internal-time (get-internal-real-time))
+                        (t
-               (setf to-sec (- stop-sec sec))
+                         (setf to-usec (- stop-usec usec)))))
-               (cond ((> usec stop-usec)
+                (when (or (minusp to-sec) (and (zerop to-sec) (not (plusp to-usec))))
-                      (decf to-sec)
+                  (cond (signalp
-                      (setf to-usec (- (+ stop-usec 1000000) usec)))
+                         (signal-deadline)
-                     (t
+                         (go :restart))
-                      (setf to-usec (- stop-usec usec)))))
+                        (t
-             (when (or (minusp to-sec) (minusp to-usec))
+                         (return-from wait-until-fd-usable nil))))))
-               (if signalp
+         (if (and serve-events
-                   (progn
+                  ;; No timeout or non-zero timeout
-                     (signal-deadline)
+                  (or (not to-sec)
-                     (go :restart))
+                      (not (= 0 to-sec to-usec)))
-                   (return-from wait-until-fd-usable nil)))))))))
+                  ;; 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 (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))))))))
 
 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 ;;; pending events are processed before returning.
@@ -201,21 +240,6 @@ 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, NIL timeout means
 ;;; to wait as long as needed.
 (defun sub-serve-event (to-sec to-usec deadlinep)

src/code/unix.lisp

@@ -570,8 +570,6 @@ corresponds to NAME, or NIL if there is none."
                       (slot usage 'ru-nivcsw))
               who (addr usage))))
 
-;;;; poll.h
-
 (defvar *on-dangerous-wait* :warn)
 
 ;;; Calling select in a bad place can hang in a nasty manner, so it's better
@@ -594,32 +592,36 @@ corresponds to NAME, or NIL if there is none."
                type)
        (sb!debug:backtrace)))
     nil))
+
+;;;; poll.h
+#!+os-provides-poll
+(progn
+  (define-alien-type nil
+      (struct pollfd
+              (fd      int)
+              (events  short)           ; requested events
+              (revents short)))         ; returned events
 
-(define-alien-type nil
+  (defun unix-simple-poll (fd direction to-msec)
-  (struct pollfd
+    (declare (fixnum fd to-msec))
-    (fd      int)
+    (when (and (minusp to-msec) (not *interrupts-enabled*))
-    (events  short)   ; requested events
+      (note-dangerous-wait "poll(2)"))
-    (revents short))) ; returned events
+    (let ((events (ecase direction
-
+                    (:input (logior pollin pollpri))
-;; Just for a single fd.
+                    (:output pollout))))
-(defun unix-simple-poll (fd direction to-msec)
+      (with-alien ((fds (struct pollfd)))
-  (declare (fixnum fd to-msec))
+        (with-restarted-syscall (count errno)
-  (when (and (minusp to-msec) (not *interrupts-enabled*))
+          (progn
-    (note-dangerous-wait "poll(2)"))
+            (setf (slot fds 'fd) fd
-  (let ((events (ecase direction
+                  (slot fds 'events) events
-                  (:input (logior pollin pollpri))
+                  (slot fds 'revents) 0)
-                  (:output pollout))))
+            (int-syscall ("poll" (* (struct pollfd)) int int)
-    (with-alien ((fds (struct pollfd)))
+                         (addr fds) 1 to-msec))
-      (sb!unix:with-restarted-syscall (count errno)
+          (if (zerop errno)
-        (progn
+              (let ((revents (slot fds 'revents)))
-          (setf (slot fds 'fd) fd
+                (or (and (eql 1 count) (logtest events revents))
-                (slot fds 'events) events
+                    (logtest pollhup revents)))
-                (slot fds 'revents) 0)
+              (error "Syscall poll(2) failed: ~A" (strerror))))))))
-          (int-syscall ("poll" (* (struct pollfd)) int int)
-                       (addr fds) 1 to-msec))
-        (if (zerop errno)
-            (and (eql 1 count) (logtest events (slot fds 'revents)))
-            (error "Syscall poll(2) failed: ~A" (strerror)))))))
 
 ;;;; sys/select.h
 
@@ -707,6 +709,65 @@ corresponds to NAME, or NIL if there is none."
                        (fd-set-to-num nfds xpf))
                nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
                (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
+
+;;; Lisp-side implmentations of FD_FOO macros. Abandon all hope who enters
+;;; here...
+;;;
+(defmacro fd-set (offset fd-set)
+  (with-unique-names (word bit)
+    `(multiple-value-bind (,word ,bit) (floor ,offset
+                                              sb!vm:n-machine-word-bits)
+       (setf (deref (slot ,fd-set 'fds-bits) ,word)
+             (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+                                (ash 1 ,bit))
+                     (deref (slot ,fd-set 'fds-bits) ,word))))))
+
+(defmacro fd-clr (offset fd-set)
+  (with-unique-names (word bit)
+    `(multiple-value-bind (,word ,bit) (floor ,offset
+                                              sb!vm:n-machine-word-bits)
+       (setf (deref (slot ,fd-set 'fds-bits) ,word)
+             (logand (deref (slot ,fd-set 'fds-bits) ,word)
+                     (sb!kernel:word-logical-not
+                      (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
+                                 (ash 1 ,bit))))))))
+
+(defmacro fd-isset (offset fd-set)
+  (with-unique-names (word bit)
+    `(multiple-value-bind (,word ,bit) (floor ,offset
+                                              sb!vm:n-machine-word-bits)
+       (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
+
+(defmacro fd-zero (fd-set)
+  `(progn
+     ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
+         collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
+
+#!-os-provides-poll
+(defun unix-simple-poll (fd direction to-msec)
+  (multiple-value-bind (to-sec to-usec)
+      (if (minusp to-msec)
+          (values nil nil)
+          (multiple-value-bind (to-sec to-msec2) (truncate to-msec 1000)
+            (values to-sec (* to-msec2 1000))))
+    (sb!unix:with-restarted-syscall (count errno)
+      (sb!alien:with-alien ((fds (sb!alien:struct sb!unix:fd-set)))
+        (sb!unix:fd-zero fds)
+        (sb!unix:fd-set fd fds)
+        (multiple-value-bind (read-fds write-fds)
+            (ecase direction
+              (:input
+               (values (addr fds) nil))
+              (:output
+               (values nil (addr fds))))
+          (sb!unix:unix-fast-select (1+ fd)
+                                    read-fds write-fds nil
+                                    to-sec to-usec)))
+      (case count
+        ((1) t)
+        ((0) nil)
+        (otherwise
+         (error "Syscall select(2) failed on fd ~D: ~A" fd (strerror)))))))
 
 ;;;; sys/stat.h
 
@@ -1121,43 +1182,3 @@ the UNIX epoch (January 1st 1970.)"
 ;;;; the headers that may or may not be the same thing. To be
 ;;;; investigated. -- CSR, 2002-03-25
 (defconstant wstopped #o177)
-
-
-;;;; stuff not yet found in the header files
-;;;;
-;;;; Abandon all hope who enters here...
-
-;;; not checked for linux...
-(defmacro fd-set (offset fd-set)
-  (with-unique-names (word bit)
-    `(multiple-value-bind (,word ,bit) (floor ,offset
-                                              sb!vm:n-machine-word-bits)
-       (setf (deref (slot ,fd-set 'fds-bits) ,word)
-             (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
-                                (ash 1 ,bit))
-                     (deref (slot ,fd-set 'fds-bits) ,word))))))
-
-;;; not checked for linux...
-(defmacro fd-clr (offset fd-set)
-  (with-unique-names (word bit)
-    `(multiple-value-bind (,word ,bit) (floor ,offset
-                                              sb!vm:n-machine-word-bits)
-       (setf (deref (slot ,fd-set 'fds-bits) ,word)
-             (logand (deref (slot ,fd-set 'fds-bits) ,word)
-                     (sb!kernel:word-logical-not
-                      (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits)
-                                 (ash 1 ,bit))))))))
-
-;;; not checked for linux...
-(defmacro fd-isset (offset fd-set)
-  (with-unique-names (word bit)
-    `(multiple-value-bind (,word ,bit) (floor ,offset
-                                              sb!vm:n-machine-word-bits)
-       (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
-
-;;; not checked for linux...
-(defmacro fd-zero (fd-set)
-  `(progn
-     ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits)
-         collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
-

tools-for-build/grovel-features.sh

@@ -9,7 +9,7 @@ cd ./tools-for-build > /dev/null
 featurep() {
     bin="$1-test"
     rm -f $bin
-    $GNUMAKE $bin -I ../src/runtime > /dev/null 2>&1 && ./$bin > /dev/null 2>&1
+    $GNUMAKE $bin -I ../src/runtime > /dev/null 2>&1 && echo "input" | ./$bin> /dev/null 2>&1
     if [ "$?" = 104 ]
     then
         printf " :$1"
@@ -30,3 +30,5 @@ featurep os-provides-blksize-t
 featurep os-provides-suseconds-t
 
 featurep os-provides-getprotoby-r
+
+featurep os-provides-poll

tools-for-build/grovel-headers.c

@@ -258,6 +258,7 @@ main(int argc, char *argv[])
     defconstant("pollin", POLLIN);
     defconstant("pollout", POLLOUT);
     defconstant("pollpri", POLLPRI);
+    defconstant("pollhup", POLLHUP);
     DEFTYPE("nfds-t", nfds_t);
 
     printf(";;; langinfo\n");

tools-for-build/os-provides-poll-test.c

@@ -0,0 +1,26 @@
+/* test to build and run so that we know if we have poll that works on
+ * stdin and /dev/zero -- which is hopefully a sufficient sample to weed
+ * out crappy versions like that on Darwin.
+ */
+
+#include <fcntl.h>
+#include <poll.h>
+
+int main ()
+{
+    struct pollfd fds;
+
+    fds.fd = 0;
+    fds.events = POLLIN|POLLPRI;
+    fds.revents = 0;
+    if (!((1 == poll(&fds, 1, -1)) && ((POLLIN|POLLPRI) & fds.revents)))
+        return 0;
+
+    fds.fd = open("/dev/zero", O_RDONLY);
+    fds.events = POLLIN|POLLPRI;
+    fds.revents = 0;
+    if (!((1 == poll(&fds, 1, -1)) && ((POLLIN|POLLPRI) & fds.revents)))
+        return 0;
+
+    return 104;
+}

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.42.42"
+"1.0.42.43"