1.0.48.7: add FD-STREAM-FD-TYPE, use it to decide when to poll the fd

  1.0.42.43 introduced a regression that caused reads from non-regular files
  to potentially block in an uninterruptible state, as WAIT-UNTIL-FD-USABLE
  started being called only when there was a timeout or events to serve.

  This was a win for regular files, because filling the input buffer then
  required one syscall less.

  ...but since uninterruptible blocking reads aren't fun for anyone, let's
  make things a bit smarter:

  * When creating an FD-STREAM, use fstat() to get the type of the fd, and
    store a keyword describing it in the FD-STREAM.

  * REFILL-INPUT-BUFFER now calls SYSREAD-MAY-BLOCK-P always if the file
    anything but :REGULAR -- so pipes and sockets and whatnot get their
    select() calls, and a read from a stream to one can no longer cause
    SBCL to hang.

diff --git a/NEWS b/NEWS
index 6fb5ce4..39819ac 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,9 @@ changes relative to sbcl-1.0.48:
   * enhancement: ASDF has been updated to version 2.015.1.
   * enhancement: backtraces involving frames from the default evaluator
     are more readable.
+  * bug fix: blocking reads from FIFOs created by RUN-PROGRAM were
+    uninterruptible, as well as blocking reads from socket streams created
+    with for which :SERVE-EVENTS NIL. (regression from 1.0.42.43)
 
 changes in sbcl-1.0.48 relative to sbcl-1.0.47:
   * incompatible change: SB!KERNEL:INSTANCE-LAMBDA, deprecated for over five

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index cf4afc2..58090b2 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2368,6 +2368,7 @@ no guarantees of interface stability."
                "USER-HOMEDIR"
                "WITH-RESTARTED-SYSCALL"
                "SB-MKSTEMP"
+               "FD-TYPE"
 
                ;; stuff with a one-to-one mapping to Unix constructs
                "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN" "DEV-T" "DIRECT"

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 54c7c51..07dfaf1 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -157,6 +157,8 @@
   (element-type 'base-char)
   ;; the Unix file descriptor
   (fd -1 :type fixnum)
+  ;; What do we know about the FD?
+  (fd-type :unknown :type keyword)
   ;; controls when the output buffer is flushed
   (buffering :full :type (member :full :line :none))
   ;; controls whether the input buffer must be cleared before output
@@ -970,11 +972,9 @@
            (count 0))
     (tagbody
        ;; Check for blocking input before touching the stream if we are to
-       ;; serve events: if the FD is blocking, we don't want to hang on the
-       ;; write if we are to serve events or notice timeouts.
-       (if (and (or (fd-stream-serve-events stream)
-                    (fd-stream-timeout stream)
-                    *deadline*)
+       ;; serve events: if the FD is blocking, we don't want to try an uninterruptible
+       ;; read(). Regular files should never block, so we can elide the check.
+       (if (and (neq :regular (fd-stream-fd-type stream))
                 (sysread-may-block-p stream))
            (go :wait-for-input)
            (go :main))
@@ -2217,6 +2217,7 @@
         ((not (or input output))
          (error "File descriptor must be opened either for input or output.")))
   (let ((stream (%make-fd-stream :fd fd
+                                 :fd-type (sb!unix:fd-type fd)
                                  :name name
                                  :file file
                                  :original original

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index d5ac483..115277a 100644 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -880,6 +880,30 @@ corresponds to NAME, or NIL if there is none."
     (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
              (%extract-stat-results (addr buf))
              fd (addr buf))))
+
+(defun fd-type (fd)
+  (declare (type unix-fd fd))
+  (let ((fmt (logand
+              sb!unix:s-ifmt
+              (or (with-alien ((buf (struct wrapped_stat)))
+                    (syscall ("fstat_wrapper" int (* (struct wrapped_stat)))
+                             (slot buf 'st-mode)
+                             fd (addr buf)))
+                  0))))
+    (cond ((logtest sb!unix:s-ififo fmt)
+           :fifo)
+          ((logtest sb!unix:s-ifchr fmt)
+           :character)
+          ((logtest sb!unix:s-ifdir fmt)
+           :directory)
+          ((logtest sb!unix:s-ifblk fmt)
+           :block)
+          ((logtest sb!unix:s-ifreg fmt)
+           :regular)
+          ((logtest sb!unix:s-ifsock fmt)
+           :socket)
+          (t
+           :unknown))))
 \f
 ;;;; time.h
 

diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp
index 46238b9..d27bb65 100644 (file)
--- a/tests/run-program.impure.lisp
+++ b/tests/run-program.impure.lisp
@@ -31,6 +31,40 @@
               (assert (= (read-byte in) i)))
       (process-close process))))
 
+#+sb-thread
+(with-test (:name :run-program-cat-2)
+  ;; Tests that reading from a FIFO is interruptible.
+  (let* ((process (sb-ext:run-program "/bin/cat" '()
+                                      :wait nil
+                                      :output :stream :input :stream))
+         (in (process-input process))
+         (out (process-output process))
+         (sem (sb-thread:make-semaphore))
+         (state :init)
+         (writer (sb-thread:make-thread (lambda ()
+                                          (sb-thread:wait-on-semaphore sem)
+                                          (setf state :sleep)
+                                          (sleep 2)
+                                          (setf state :write)
+                                          (write-line "OK" in)
+                                          (finish-output in))))
+         (timeout nil)
+         (got nil)
+         (unwind nil))
+    (sb-thread:signal-semaphore sem)
+    (handler-case
+        (with-timeout 0.1
+          (unwind-protect
+               (setf got (read-line out))
+            (setf unwind state)))
+      (timeout ()
+        (setf timeout t)))
+    (assert (not got))
+    (assert timeout)
+    (assert (eq unwind :sleep))
+    (sb-thread:join-thread writer)
+    (assert (equal "OK" (read-line out)))))
+
 ;;; Test driving an external program (cat) through pipes wrapped in
 ;;; composite streams.
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 2e2f4de..a6a714f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,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.48.6"
+"1.0.48.7"