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 +#endif + #if !defined(C_NONUNIX) # include @@ -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) ) )))