From http://code.call-cc.org/cgi-bin/gitweb.cgi?p=chicken-core.git;a=commitdiff;h=556108092774086b6c86c2e27daf3f740ffec091
--- chicken-4.8.0.3/chicken.h
+++ chicken-4.8.0.3/chicken.h
@@ -1668,6 +1668,7 @@
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;
--- chicken-4.8.0.3/posixunix.scm
+++ chicken-4.8.0.3/posixunix.scm
@@ -493,16 +493,7 @@
"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:
--- chicken-4.8.0.3/runtime.c
+++ chicken-4.8.0.3/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>
@@ -4036,20 +4041,39 @@
return C_fix(n);
}
+/*
+ * TODO: Implement something for Windows that supports selecting on
+ * arbitrary fds (there, select() only works on network sockets and
+ * poll() is not available at all).
+ */
+C_regparm int C_fcall C_check_fd_ready(int fd)
+{
+#ifdef HAVE_POSIX_POLL
+ struct pollfd ps;
+ ps.fd = fd;
+ ps.events = POLLIN;
+ 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
+#if defined(C_NONUNIX)
+ /* The best we can currently do on Windows... */
return C_SCHEME_TRUE;
+#else
+ int fd = C_fileno(C_port_file(port));
+ return C_mk_bool(C_check_fd_ready(fd) == 1);
#endif
}
--- chicken-4.8.0.3/tcp.scm
+++ chicken-4.8.0.3/tcp.scm
@@ -46,6 +46,7 @@
# define fcntl(a, b, c) 0
# define EWOULDBLOCK 0
# define EINPROGRESS 0
+# define EAGAIN 0
# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \
getsockopt(socket, level, optname, (char *)optval, optlen)
#else
@@ -111,6 +112,7 @@
(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*
@@ -177,30 +179,6 @@
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);"
@@ -212,13 +190,6 @@
"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 ##net#parse-host
(let ((substring substring))
(lambda (host proto)
@@ -343,7 +314,9 @@
(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 ()
@@ -351,12 +324,11 @@
(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
@@ -386,7 +358,7 @@
c) ) )
(lambda ()
(or (fx< bufindex buflen)
- (let ((f (##net#select fd)))
+ (let ((f (##net#check-fd-ready fd)))
(when (eq? f -1)
(##sys#update-errno)
(##sys#signal-hook
@@ -469,12 +441,11 @@
(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
@@ -528,38 +499,29 @@
(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
- (##sys#update-errno)
- (##sys#signal-hook
- #:network-error
- 'tcp-accept
- (##sys#string-append "could not accept from listener - " strerror)
- 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)
(##sys#update-errno)
(##sys#signal-hook
@@ -578,8 +540,9 @@
(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"))
@@ -606,23 +569,9 @@
(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) (fail))
- (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 (fail) ) )))
|
