Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv19483/src/code
Modified Files:
condition.lisp fd-stream.lisp serve-event.lisp unix.lisp
Log Message:
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().
Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.107
retrieving revision 1.108
diff -u -d -r1.107 -r1.108
--- condition.lisp 2 Sep 2010 08:14:32 -0000 1.107
+++ condition.lisp 19 Sep 2010 20:08:47 -0000 1.108
@@ -1245,7 +1245,7 @@
(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)))))
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.146
retrieving revision 1.147
diff -u -d -r1.146 -r1.147
--- fd-stream.lisp 19 Sep 2010 14:14:15 -0000 1.146
+++ fd-stream.lisp 19 Sep 2010 20:08:47 -0000 1.147
@@ -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)))
- (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)))
@@ -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
@@ -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
Index: serve-event.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/serve-event.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- serve-event.lisp 14 Nov 2008 14:07:46 -0000 1.22
+++ serve-event.lisp 19 Sep 2010 20:08:47 -0000 1.23
@@ -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."
- (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))))))))
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
@@ -201,21 +240,6 @@
(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)
Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- unix.lisp 19 Sep 2010 14:14:16 -0000 1.108
+++ unix.lisp 19 Sep 2010 20:08:47 -0000 1.109
@@ -570,8 +570,6 @@
(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 @@
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
- (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)))))))
+ (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))))))))
;;;; sys/select.h
@@ -707,6 +709,65 @@
(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 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))))
-
|