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