From 9e2022652258e8a30e5cedbf0abc9cd85a0f6af7 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter.bex@xs4all.nl>
Date: Thu, 18 Apr 2013 00:31:08 +0200
Subject: [PATCH] Implement file-select in terms of POSIX poll() for UNIX
Signed-off-by: felix <felix@call-with-current-continuation.org>
---
posixunix.scm | 116 ++++++++++++++++++++++++++------------------------------
1 files changed, 54 insertions(+), 62 deletions(-)
diff --git a/posixunix.scm b/posixunix.scm
index 15cb535..90e0176 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -67,6 +67,7 @@ static C_TLS int C_wait_status;
#endif
#include <sys/mman.h>
+#include <sys/poll.h>
#include <time.h>
#ifndef O_FSYNC
@@ -136,7 +137,6 @@ static C_TLS struct {
static C_TLS int C_pipefds[ 2 ];
static C_TLS time_t C_secs;
static C_TLS struct tm C_tm;
-static C_TLS fd_set C_fd_sets[ 2 ];
static C_TLS struct timeval C_timeval;
static C_TLS char C_hostbuf[ 256 ];
static C_TLS struct stat C_statbuf;
@@ -303,13 +303,6 @@ static C_TLS sigset_t C_sigset;
#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
-#define C_zero_fd_set(i) FD_ZERO(&C_fd_sets[ i ])
-#define C_set_fd_set(i, fd) FD_SET(fd, &C_fd_sets[ i ])
-#define C_test_fd_set(i, fd) FD_ISSET(fd, &C_fd_sets[ i ])
-#define C_C_select(m) C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
-#define C_C_select_t(m, t) (C_set_timeval(t, &C_timeval), \
- C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
-
#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
#if defined(__SVR4) || defined(C_MACOSX)
@@ -656,60 +649,59 @@ EOF
;;; I/O multiplexing:
-(define file-select
- (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)]
- [fd_set (foreign-lambda void "C_set_fd_set" int int)]
- [fd_test (foreign-lambda bool "C_test_fd_set" int int)] )
- (lambda (fdsr fdsw . timeout)
- (let ([fdmax 0]
- [tm (if (pair? timeout) (car timeout) #f)] )
- (fd_zero 0)
- (fd_zero 1)
- (cond [(not fdsr)]
- [(fixnum? fdsr)
- (set! fdmax fdsr)
- (fd_set 0 fdsr) ]
- [else
- (##sys#check-list fdsr 'file-select)
- (for-each
- (lambda (fd)
- (##sys#check-exact fd 'file-select)
- (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
- (fd_set 0 fd) )
- fdsr) ] )
- (cond [(not fdsw)]
- [(fixnum? fdsw)
- (set! fdmax fdsw)
- (fd_set 1 fdsw) ]
- [else
- (##sys#check-list fdsw 'file-select)
- (for-each
- (lambda (fd)
- (##sys#check-exact fd 'file-select)
- (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
- (fd_set 1 fd) )
- fdsw) ] )
- (let ([n (cond [tm
- (##sys#check-number tm 'file-select)
- (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
- [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
- (cond [(fx< n 0)
- (posix-error #:file-error 'file-select "failed" fdsr fdsw) ]
- [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))]
- [else
- (values
- (and fdsr
- (if (fixnum? fdsr)
- (fd_test 0 fdsr)
- (let ([lstr '()])
- (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr)
- lstr) ) )
- (and fdsw
- (if (fixnum? fdsw)
- (fd_test 1 fdsw)
- (let ([lstw '()])
- (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw)
- lstw) ) ) ) ] ) ) ) ) ) )
+(define (file-select fdsr fdsw . timeout)
+ (let* ((tm (if (pair? timeout) (car timeout) #f))
+ (fdsrl (cond ((not fdsr) '())
+ ((fixnum? fdsr) (list fdsr))
+ (else (##sys#check-list fdsr 'file-select)
+ fdsr)))
+ (fdswl (cond ((not fdsw) '())
+ ((fixnum? fdsw) (list fdsw))
+ (else (##sys#check-list fdsw 'file-select)
+ fdsw)))
+ (nfdsr (##sys#length fdsrl))
+ (nfdsw (##sys#length fdswl))
+ (nfds (fx+ nfdsr nfdsw))
+ (fds-blob (##sys#make-blob
+ (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))
+ (when tm (##sys#check-number tm))
+ (do ((i 0 (fx+ i 1))
+ (fdsrl fdsrl (cdr fdsrl)))
+ ((null? fdsrl))
+ ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))
+ "struct pollfd *fds = p;"
+ "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))
+ (do ((i nfdsr (fx+ i 1))
+ (fdswl fdswl (cdr fdswl)))
+ ((null? fdswl))
+ ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))
+ "struct pollfd *fds = p;"
+ "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))
+ (let ((n ((foreign-lambda int "poll" scheme-pointer int int)
+ fds-blob nfds (if tm (inexact->exact (* (max 0 tm) 1000)) -1))))
+ (cond ((fx< n 0)
+ (posix-error #:file-error 'file-select "failed" fdsr fdsw) )
+ ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))
+ (else
+ (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))
+ (cond ((null? fds) (##sys#fast-reverse res))
+ (((foreign-lambda* bool ((int i) (scheme-pointer p))
+ "struct pollfd *fds = p;"
+ "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));")
+ i fds-blob)
+ (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))
+ (else (lp (fx+ i 1) res (cdr fds))))))
+ (wl (let lp ((i nfdsr) (res '()) (fds fdswl))
+ (cond ((null? fds) (##sys#fast-reverse res))
+ (((foreign-lambda* bool ((int i) (scheme-pointer p))
+ "struct pollfd *fds = p;"
+ "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")
+ i fds-blob)
+ (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))
+ (else (lp (fx+ i 1) res (cdr fds)))))))
+ (values
+ (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))
+ (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl)))))))))
;;; File attribute access:
--
1.7.2.1
|
