On Thu, Mar 21, 2013 at 07:13:46PM +0100, Jörg F. Wittenberger wrote:
> On Mar 20 2013, Peter Bex wrote:
> >Do you think you could post a clean patch for introducing just this one
> >change to tcp? That would be great. I'd have to dig in otherwise,
> >anyway since I'd like to change tcp to avoid using select().
>
> I'm afraid this is not completely possible.
>
> So far I did not bother to provide /true/ READY? procedures
> for the input ports. Instead they return #t until the port is
> closed. (I don't have any use for this test. Instead of testing
> whether or not the read would block I use to just read along
> and have the thread blocked if needed.)
>
> Doing a real READY? procedure is IMHO not going to work without
> a single-fd poll.
This is true. The ioctl suggested by Florian doesn't work for
tcp-accept-ready?; it only returns 1 when there's actual data to
read, not when the fd is in a ready state. I'm also unsure how
portable it is. OTOH, Windows does seem to know about it...
Anyway, using poll()/select() avoids these issues.
> Otherwise find the modifications attached.
Thanks for the patch! I've cleaned it up a little bit: Your patch
introduced an implicit dependency on SRFI-18 through thread-wait-for-i/o!,
which I've now rewritten to use core ##sys#thread-wait-for-i/o! and
##sys#thread-yield procedures.
I also noticed you tried to fix the timeouts by moving the blocking
of the thread to the start before the loop, but I think this would
cause trouble when the thread first gets interrupted on I/O and then
loops again; its timeout value would be cleared upon wakeup, then
it would loop, causing it to get stuck. I moved the calculation itself
to the start but kept the blocking where it was.
Finally, I saw that we were still using select() in a few other places,
in posixunix.scm (in file-select and file-select-one) and in each
char-ready? port procedure through C_char_ready_p(). I've reworked
those to use poll/select depending on what's available here too.
There's only posix's "file-select" left. I'm not sure what to do
with it. Probably it needs to be replaced with a select/poll
checking implementation as well. However, posixwindows doesn't have
an implementation for file-select at all, while select() certainly
is available on Windows (the scheduler uses it too, after all!).
Perhaps we could grab the common stuff and put it in library.scm?
That way, the scheduler and posixunix would be re-using the same code,
eliminating potential bugs due to the difference. We could even
replace the select() implementation with a more "native" system for
Windows (whatever that would be) once we've done this. What do y'all
think?
Anyway, here's the (preliminary) patch.
Cheers,
Peter
--
http://www.more-magic.net
>From b319c58af2c8d5ef3980642094033cd5e8d1e3aa Mon Sep 17 00:00:00 2001
From: Peter Bex <peter....@xs4all.nl>
Date: Wed, 27 Mar 2013 00:09:14 +0100
Subject: [PATCH] Replace select() by poll() when available, in char-ready? and
tcp-accept-ready?
Also, timeout values in tcp-accept and tcp-connect, and in the TCP port read
and write procedures are now honored more strictly by calculating the wait time
at the start instead of after each interrupted system call.
It was pointed out by Florian Zumbiehl that select() was still being used in a
few places, and Joerg Wittenberger provided an initial patch to remove select()
from the TCP unit.
---
NEWS | 2 +
chicken.h | 1 +
posixunix.scm | 11 +----
runtime.c | 36 ++++++++++++-----
tcp.scm | 126 +++++++++++++++++++---------------------------------------
5 files changed, 69 insertions(+), 107 deletions(-)
diff --git a/NEWS b/NEWS
index a34fbe0..1894aea 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@
- CVE-2013-1874: ./.csirc is no longer loaded from the current directory
upon startup of csi, which could lead to untrusted code execution.
(thanks to Florian Zumbiehl)
+ - Use POSIX poll() in other places where select() was still being used.
+ (thanks to Florian Zumbiehl and Joerg Wittenberger)
- Tools
- csc: added "-oi"/"-ot" options as alternatives to "-emit-inline-file"
diff --git a/chicken.h b/chicken.h
index 2b9030a..53553c5 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1730,6 +1730,7 @@ C_fctexport C_word C_fcall C_get_print_precision(void)
C_regparm;
C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
+C_fctexport int C_fcall C_check_fd_ready(int fd) C_regparm;
C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
diff --git a/posixunix.scm b/posixunix.scm
index 6d1fe51..d551e23 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -501,16 +501,7 @@ EOF
"if(val == -1) C_return(0);"
"C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
-(define ##sys#file-select-one
- (foreign-lambda* int ([int fd])
- "fd_set in;"
- "struct timeval tm;"
- "FD_ZERO(&in);"
- "FD_SET(fd, &in);"
- "tm.tv_sec = tm.tv_usec = 0;"
- "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) C_return(-1);"
- "else C_return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
-
+(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )
;;; Lo-level I/O:
diff --git a/runtime.c b/runtime.c
index 099dbdc..a54f67b 100644
--- a/runtime.c
+++ b/runtime.c
@@ -60,6 +60,11 @@
# define EOVERFLOW 0
#endif
+/* TODO: Include sys/select.h? Windows doesn't seem to have it... */
+#ifdef HAVE_POSIX_POLL
+# include <poll.h>
+#endif
+
#if !defined(C_NONUNIX)
# include <sys/types.h>
@@ -4174,21 +4179,30 @@ C_regparm C_word C_fcall C_execute_shell_command(C_word
string)
return C_fix(n);
}
+C_regparm int C_fcall C_check_fd_ready(int fd)
+{
+#ifdef HAVE_POSIX_POLL
+ struct pollfd ps;
+ ps.fd = fd;
+ ps.events = POLLIN|POLLERR|POLLHUP|POLLNVAL;
+ return poll(&ps, 1, 0);
+#else
+ fd_set in;
+ struct timeval tm;
+ int rv;
+ FD_ZERO(&in);
+ FD_SET(fd, &in);
+ tm.tv_sec = tm.tv_usec = 0;
+ rv = select(fd + 1, &in, NULL, NULL, &tm);
+ if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
+ return rv;
+#endif
+}
C_regparm C_word C_fcall C_char_ready_p(C_word port)
{
-#if !defined(C_NONUNIX)
- fd_set fs;
- struct timeval to;
int fd = C_fileno(C_port_file(port));
-
- FD_ZERO(&fs);
- FD_SET(fd, &fs);
- to.tv_sec = to.tv_usec = 0;
- return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
-#else
- return C_SCHEME_TRUE;
-#endif
+ return C_mk_bool(C_check_fd_ready(fd) == 1);
}
diff --git a/tcp.scm b/tcp.scm
index db713bb..7e37721 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -50,6 +50,9 @@ static WSADATA wsa;
# ifndef EINPROGRESS
# define EINPROGRESS 0
# endif
+# ifndef EAGAIN
+# define EAGAIN 0
+# endif
# define typecorrect_getsockopt(socket, level, optname, optval, optlen)
\
getsockopt(socket, level, optname, (char *)optval, optlen)
#else
@@ -115,6 +118,7 @@ EOF
(define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
(define ##net#shutdown (foreign-lambda int "shutdown" int int))
(define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
+(define ##net#check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
(define ##net#send
(foreign-lambda*
@@ -181,30 +185,6 @@ EOF
if((se = getservbyname(serv, proto)) == NULL) C_return(0);
else C_return(ntohs(se->s_port));") )
-(define ##net#select
- (foreign-lambda* int ((int fd))
- "fd_set in;
- struct timeval tm;
- int rv;
- FD_ZERO(&in);
- FD_SET(fd, &in);
- tm.tv_sec = tm.tv_usec = 0;
- rv = select(fd + 1, &in, NULL, NULL, &tm);
- if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
- C_return(rv);") )
-
-(define ##net#select-write
- (foreign-lambda* int ((int fd))
- "fd_set out;
- struct timeval tm;
- int rv;
- FD_ZERO(&out);
- FD_SET(fd, &out);
- tm.tv_sec = tm.tv_usec = 0;
- rv = select(fd + 1, NULL, &out, NULL, &tm);
- if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
- C_return(rv);") )
-
(define ##net#gethostaddr
(foreign-lambda* bool ((scheme-pointer saddr) (c-string host)
(unsigned-short port))
"struct hostent *he = gethostbyname(host);"
@@ -216,13 +196,6 @@ EOF
"addr->sin_addr = *((struct in_addr *)he->h_addr);"
"C_return(1);") )
-(define (yield)
- (##sys#call-with-current-continuation
- (lambda (return)
- (let ((ct ##sys#current-thread))
- (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
- (##sys#schedule) ) ) ) )
-
(define-syntax network-error
(syntax-rules ()
((_ loc msg . args)
@@ -342,7 +315,9 @@ EOF
(outbufsize (tbs))
(outbuf (and outbufsize (fx> outbufsize 0) ""))
(tmr (tcp-read-timeout))
+ (dlr (and tmr (+ (current-milliseconds) tmr)))
(tmw (tcp-write-timeout))
+ (dlw (and tmw (+ (current-milliseconds) tmw)))
(read-input
(lambda ()
(let loop ()
@@ -350,12 +325,11 @@ EOF
(cond ((eq? -1 n)
(cond ((or (eq? errno _ewouldblock)
(eq? errno _eagain))
- (when tmr
- (##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) tmr) ) )
+ (when dlr
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread dlr) )
(##sys#thread-block-for-i/o!
##sys#current-thread fd #:input)
- (yield)
+ (##sys#thread-yield!)
(when (##sys#slot ##sys#current-thread 13)
(##sys#signal-hook
#:network-timeout-error
@@ -381,7 +355,7 @@ EOF
c) ) )
(lambda ()
(or (fx< bufindex buflen)
- (let ((f (##net#select fd)))
+ (let ((f (##net#check-fd-ready fd)))
(when (eq? f -1)
(network-error #f "cannot check socket for input" fd) )
(eq? f 1) ) ) )
@@ -452,12 +426,11 @@ EOF
(cond ((eq? -1 n)
(cond ((or (eq? errno _ewouldblock)
(eq? errno _eagain))
- (when tmw
+ (when dlw
(##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) tmw) ) )
- (##sys#thread-block-for-i/o!
##sys#current-thread fd #:output)
- (yield)
+ ##sys#current-thread dlw) )
+ (##sys#thread-block-for-i/o!
##sys#current-thread fd #:output)
+ (##sys#thread-yield!)
(when (##sys#slot ##sys#current-thread 13)
(##sys#signal-hook
#:network-timeout-error
@@ -505,33 +478,29 @@ EOF
(define (tcp-accept tcpl)
(##sys#check-structure tcpl 'tcp-listener)
- (let ((fd (##sys#slot tcpl 1))
- (tma (tcp-accept-timeout)))
+ (let* ((fd (##sys#slot tcpl 1))
+ (tma (tcp-accept-timeout))
+ (dla (and tma (+ tma (current-milliseconds)))))
(let loop ()
- (if (eq? 1 (##net#select fd))
- (let ((fd (##net#accept fd #f #f)))
- (cond ((not (eq? -1 fd)) (##net#io-ports fd))
- ((eq? errno _eintr)
- (##sys#dispatch-interrupt loop))
- (else
- (network-error 'tcp-accept "could not accept from listener"
tcpl))))
- (begin
- (when tma
- (##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) tma) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
- (yield)
- (when (##sys#slot ##sys#current-thread 13)
- (##sys#signal-hook
- #:network-timeout-error
- 'tcp-accept
- "accept operation timed out" tma fd) )
- (loop) ) ) ) ) )
+ (when dla
+ (##sys#thread-block-for-timeout! ##sys#current-thread dla) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+ (##sys#thread-yield!)
+ (if (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-timeout-error
+ 'tcp-accept
+ "accept operation timed out" tma fd) )
+ (let ((fd (##net#accept fd #f #f)))
+ (cond ((not (eq? -1 fd)) (##net#io-ports fd))
+ ((eq? errno _eintr)
+ (##sys#dispatch-interrupt loop))
+ (else
+ (network-error 'tcp-accept "could not accept from listener"
tcpl)))) ) ) )
(define (tcp-accept-ready? tcpl)
(##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
- (let ((f (##net#select (##sys#slot tcpl 1))))
+ (let ((f (##net#check-fd-ready (##sys#slot tcpl 1))))
(when (eq? -1 f)
(network-error 'tcp-accept-ready? "cannot check socket for input" tcpl) )
(eq? 1 f) ) )
@@ -547,8 +516,9 @@ EOF
(define general-strerror (foreign-lambda c-string "strerror" int))
(define (tcp-connect host . more)
- (let ((port (optional more #f))
- (tmc (tcp-connect-timeout)))
+ (let* ((port (optional more #f))
+ (tmc (tcp-connect-timeout))
+ (dlc (and tmc (+ (current-milliseconds) tmc))))
(##sys#check-string host)
(unless port
(set!-values (host port) (##net#parse-host host "tcp"))
@@ -565,25 +535,9 @@ EOF
(let loop ()
(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
(cond ((eq? errno _einprogress)
- (let loop2 ()
- (let ((f (##net#select-write s)))
- (when (eq? f -1)
- (##net#close s)
- (network-error 'tcp-connect "cannot connect to socket"
host port))
- (unless (eq? f 1)
- (when tmc
- (##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) tmc) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread s
#:all)
- (yield)
- (when (##sys#slot ##sys#current-thread 13)
- (##net#close s)
- (##sys#signal-hook
- #:network-timeout-error
- 'tcp-connect
- "connect operation timed out" tmc s) )
- (loop2) ) ) ))
+ (when dlc
+ (##sys#thread-block-for-timeout! ##sys#current-thread dlc))
+ (##sys#thread-block-for-i/o! ##sys#current-thread s #:all))
((eq? errno _eintr)
(##sys#dispatch-interrupt loop))
(else
--
1.8.0.1
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
