common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

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

Browse source 
* 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().
This commit is contained in:
Nikodemus Siivola 2010-09-19 20:08:47 +00:00
parent 809babfb68
commit 6e02a5455a
11 changed files with 266 additions and 147 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
NEWS
View file

@ -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
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

18
contrib/sb-bsd-sockets/sockets.lisp
View file

@ -381,12 +381,17 @@ for the stream."))
(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
@ -407,8 +412,9 @@ and get an output stream in response\)."
: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))

3
contrib/sb-rt/rt.lisp
View file

@ -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: ~

2
src/code/condition.lisp
View file

@ -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)))))

60
src/code/fd-stream.lisp
View file

@ -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)
(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.
(reset-buffer obuf))
(return (reset-buffer obuf)))
(count
;; Partial write -- update buffer status and queue.
;; Do not use INCF! Another thread might have moved
;; head...
;; 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-and-replace-output-buffer stream))
(queue-or-wait))
#!-win32
((eql errno sb!unix:ewouldblock)
;; Blocking, queue.
(%queue-and-replace-output-buffer stream))
;; Blocking, queue or wair.
(queue-or-wait))
(t
(simple-stream-perror "Couldn't write to ~s"
stream errno)))))))))))
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
;; 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
@ -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))
(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
@ -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

84
src/code/serve-event.lisp
View file

@ -138,28 +138,41 @@
;;;; 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
(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))
@ -168,12 +181,38 @@ up."
(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
(when (or (minusp to-sec) (and (zerop to-sec) (not (plusp to-usec))))
(cond (signalp
(signal-deadline)
(go :restart))
(return-from wait-until-fd-usable nil)))))))))
(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))))))))
;;; 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)

115
src/code/unix.lisp
View file

@ -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,14 +592,16 @@ 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
;; 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*))
@ -610,7 +610,7 @@ corresponds to NAME, or NIL if there is none."
(:input (logior pollin pollpri))
(:output pollout))))
(with-alien ((fds (struct pollfd)))
(sb!unix:with-restarted-syscall (count errno)
(with-restarted-syscall (count errno)
(progn
(setf (slot fds 'fd) fd
(slot fds 'events) events
@ -618,8 +618,10 @@ corresponds to NAME, or NIL if there is none."
(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)))))))
(let ((revents (slot fds 'revents)))
(or (and (eql 1 count) (logtest events revents))
(logtest pollhup 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))))

4
tools-for-build/grovel-features.sh
View file

@ -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

1
tools-for-build/grovel-headers.c
View file

@ -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");

26
tools-for-build/os-provides-poll-test.c Normal file
View file

@ -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;
}

2
version.lisp-expr
View file

@ -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"