1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
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
|
GitWeb