From: Nikodemus Siivola Date: Sun, 19 Sep 2010 20:08:47 +0000 (+0000) Subject: 1.0.42.43: FD-STREAMS no longer hook into SERVE-EVENT by default X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6e02a5455aeef5a4642a2334348544c1f19775ad;p=sbcl.git 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(). --- diff --git a/NEWS b/NEWS index 6f6d53e..ce063ac 100644 --- a/NEWS +++ b/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 - 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 diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index dcccc79..886dd6e 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -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)) diff --git a/contrib/sb-rt/rt.lisp b/contrib/sb-rt/rt.lisp index 77a4560..5b06bf9 100644 --- a/contrib/sb-rt/rt.lisp +++ b/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: ~ diff --git a/src/code/condition.lisp b/src/code/condition.lisp index dbd3bfc..35603bc 100644 --- a/src/code/condition.lisp +++ b/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))))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index c6d4282..969b177 100644 --- a/src/code/fd-stream.lisp +++ b/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))) - (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 diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 2046161..508d465 100644 --- a/src/code/serve-event.lisp +++ b/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." - (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 @@ 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) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index c645b89..2ea6ee9 100644 --- a/src/code/unix.lisp +++ b/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)) - -(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))))))) + +;;;; 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)))))))) ;;;; 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)))) - diff --git a/tools-for-build/grovel-features.sh b/tools-for-build/grovel-features.sh index d889caa..bfae723 100644 --- a/tools-for-build/grovel-features.sh +++ b/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 diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 7f9ef4e..33b2abc 100644 --- a/tools-for-build/grovel-headers.c +++ b/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"); diff --git a/tools-for-build/os-provides-poll-test.c b/tools-for-build/os-provides-poll-test.c new file mode 100644 index 0000000..8ff8b60 --- /dev/null +++ b/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 +#include + +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; +} diff --git a/version.lisp-expr b/version.lisp-expr index d2e8801..df0f38a 100644 --- a/version.lisp-expr +++ b/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"