;;;; -*- 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
* 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
- on a single FD.
+ * optimization: where available, use poll(2) instead of select(2) to check
+ 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
(buffering :full)
(external-format :default)
timeout
- auto-close)
- "Default method for SOCKET objects. An ELEMENT-TYPE of :DEFAULT will
-construct a bivalent stream. Acceptable values for BUFFERING are :FULL, :LINE
+ auto-close
+ (serve-events t))
+ "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
:buffering buffering
:external-format external-format
:timeout timeout
- :auto-close auto-close)))
- (setf (slot-value socket 'stream) stream)
+ :auto-close auto-close
+ :serve-events serve-events))
+ (setf (slot-value socket 'stream) stream))
(sb-ext:cancel-finalization socket)
stream))
(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: ~
(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)))))
(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 (*)))
(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)))
- (multiple-value-bind (count errno)
- (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
- head length)
- (cond ((eql count length)
- ;; Complete write -- we can use the same buffer.
- (reset-buffer obuf))
- (count
- ;; Partial write -- update buffer status and queue.
- ;; Do not use INCF! Another thread might have moved
- ;; head...
- (setf (buffer-head obuf) (+ count head))
- (%queue-and-replace-output-buffer stream))
- #!-win32
- ((eql errno sb!unix:ewouldblock)
- ;; Blocking, queue.
- (%queue-and-replace-output-buffer stream))
- (t
- (simple-stream-perror "Couldn't write to ~s"
- stream errno)))))))))))
+ (loop
+ (let ((length (- tail head)))
+ (multiple-value-bind (count errno)
+ (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
+ head length)
+ (flet ((queue-or-wait ()
+ (if (fd-stream-serve-events stream)
+ (return (%queue-and-replace-output-buffer stream))
+ (or (wait-until-fd-usable (fd-stream-fd stream) :output
+ (fd-stream-timeout stream)
+ nil)
+ (signal-timeout 'io-timeout
+ :stream stream
+ :direction :output
+ :seconds (fd-stream-timeout stream))))))
+ (cond ((eql count length)
+ ;; Complete write -- we can use the same buffer.
+ (return (reset-buffer obuf)))
+ (count
+ ;; 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)))
;;; 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
(errno 0)
(count 0))
(tagbody
- ;; Check for blocking input before touching the stream, as if
- ;; we happen to wait we are liable to be interrupted, and the
- ;; interrupt handler may use the same stream.
- (if (sysread-may-block-p stream)
+ ;; 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*)
+ (sysread-may-block-p stream))
(go :wait-for-input)
(go :main))
;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
: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))
- (signal-timeout 'io-timeout :stream stream :direction :read
+ (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)
+ (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
;; 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))))
(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)
;;; 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)
(element-type 'base-char)
(buffering :full)
(external-format :default)
+ serve-events
timeout
file
original
: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)
:delete-original delete-original
:pathname pathname
:dual-channel-p nil
+ :serve-events nil
:input-buffer-p t
:auto-close t))
(:probe
(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
\f
;;;; 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."
- (prog (usable)
+up. Returns true once the FD is usable, NIL return indicates timeout.
+
+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)
- (declare (ignore fd))
- (setf usable t)))
- (loop
- (sub-serve-event to-sec to-usec signalp)
- (when usable
- (return-from wait-until-fd-usable t))
- (when to-sec
- (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) (minusp to-usec))
- (if signalp
- (progn
- (signal-deadline)
- (go :restart))
- (return-from wait-until-fd-usable nil)))))))))
+ (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))))
+ (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 (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))))))))
\f
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
(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)
(slot usage 'ru-nivcsw))
who (addr usage))))
\f
-;;;; poll.h
-
(defvar *on-dangerous-wait* :warn)
;;; Calling select in a bad place can hang in a nasty manner, so it's better
type)
(sb!debug:backtrace)))
nil))
-
-(define-alien-type nil
- (struct pollfd
- (fd int)
- (events short) ; requested events
- (revents short))) ; returned events
-
-;; Just for a single fd.
-(defun unix-simple-poll (fd direction to-msec)
- (declare (fixnum fd to-msec))
- (when (and (minusp to-msec) (not *interrupts-enabled*))
- (note-dangerous-wait "poll(2)"))
- (let ((events (ecase direction
- (:input (logior pollin pollpri))
- (:output pollout))))
- (with-alien ((fds (struct pollfd)))
- (sb!unix:with-restarted-syscall (count errno)
- (progn
- (setf (slot fds 'fd) fd
- (slot fds 'events) events
- (slot fds 'revents) 0)
- (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)))))))
+\f
+;;;; poll.h
+#!+os-provides-poll
+(progn
+ (define-alien-type nil
+ (struct pollfd
+ (fd int)
+ (events short) ; requested events
+ (revents short))) ; returned events
+
+ (defun unix-simple-poll (fd direction to-msec)
+ (declare (fixnum fd to-msec))
+ (when (and (minusp to-msec) (not *interrupts-enabled*))
+ (note-dangerous-wait "poll(2)"))
+ (let ((events (ecase direction
+ (:input (logior pollin pollpri))
+ (:output pollout))))
+ (with-alien ((fds (struct pollfd)))
+ (with-restarted-syscall (count errno)
+ (progn
+ (setf (slot fds 'fd) fd
+ (slot fds 'events) events
+ (slot fds 'revents) 0)
+ (int-syscall ("poll" (* (struct pollfd)) int int)
+ (addr fds) 1 to-msec))
+ (if (zerop errno)
+ (let ((revents (slot fds 'revents)))
+ (or (and (eql 1 count) (logtest events revents))
+ (logtest pollhup revents)))
+ (error "Syscall poll(2) failed: ~A" (strerror))))))))
\f
;;;; sys/select.h
(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)))))))
\f
;;;; sys/stat.h
;;;; the headers that may or may not be the same thing. To be
;;;; investigated. -- CSR, 2002-03-25
(defconstant wstopped #o177)
-
-\f
-;;;; 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))))
-
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"
featurep os-provides-suseconds-t
featurep os-provides-getprotoby-r
+
+featurep os-provides-poll
defconstant("pollin", POLLIN);
defconstant("pollout", POLLOUT);
defconstant("pollpri", POLLPRI);
+ defconstant("pollhup", POLLHUP);
DEFTYPE("nfds-t", nfds_t);
printf(";;; langinfo\n");
--- /dev/null
+/* 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;
+}
;;; 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"
projects / sbcl.git / commitdiff