Commit | Line | Data |
---|---|---|
6f81b18a AW |
1 | ;; poll |
2 | ||
0c65f52c | 3 | ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
6f81b18a AW |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ;;;; | |
19 | ||
20 | (define-module (ice-9 poll) | |
21 | #:use-module (srfi srfi-9) | |
22 | #:use-module (srfi srfi-9 gnu) | |
23 | #:use-module (rnrs bytevectors) | |
24 | #:export (make-empty-poll-set | |
25 | poll-set? | |
26 | poll-set-nfds | |
27 | poll-set-find-port | |
28 | poll-set-port | |
29 | poll-set-events | |
30 | set-poll-set-events! | |
31 | poll-set-revents | |
32 | set-poll-set-revents! | |
33 | poll-set-add! | |
34 | poll-set-remove! | |
35 | poll)) | |
36 | ||
37 | (eval-when (eval load compile) | |
38 | (load-extension (string-append "libguile-" (effective-version)) | |
39 | "scm_init_poll")) | |
40 | ||
41 | (if (defined? 'POLLIN) | |
42 | (export POLLIN)) | |
43 | ||
44 | (if (defined? 'POLLPRI) | |
45 | (export POLLPRI)) | |
46 | ||
47 | (if (defined? 'POLLOUT) | |
48 | (export POLLOUT)) | |
49 | ||
50 | (if (defined? 'POLLRDHUP) | |
51 | (export POLLRDHUP)) | |
52 | ||
53 | (if (defined? 'POLLERR) | |
54 | (export POLLERR)) | |
55 | ||
56 | (if (defined? 'POLLHUP) | |
57 | (export POLLHUP)) | |
58 | ||
59 | (if (defined? 'POLLNVAL) | |
60 | (export POLLNVAL)) | |
61 | ||
62 | ||
63 | (define-record-type <poll-set> | |
64 | (make-poll-set pollfds nfds ports) | |
65 | poll-set? | |
66 | (pollfds pset-pollfds set-pset-pollfds!) | |
67 | (nfds poll-set-nfds set-pset-nfds!) | |
68 | (ports pset-ports set-pset-ports!) | |
69 | ) | |
70 | ||
0c65f52c AW |
71 | (define-syntax-rule (pollfd-offset n) |
72 | (* n 8)) | |
6f81b18a AW |
73 | |
74 | (define* (make-empty-poll-set #:optional (pre-allocated 4)) | |
75 | (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0) | |
76 | 0 | |
77 | (make-vector pre-allocated #f))) | |
78 | ||
79 | (define (pset-size set) | |
80 | (vector-length (pset-ports set))) | |
81 | ||
82 | (define (ensure-pset-size! set size) | |
83 | (let ((prev (pset-size set))) | |
84 | (if (< prev size) | |
85 | (let lp ((new prev)) | |
86 | (if (< new size) | |
87 | (lp (* new 2)) | |
88 | (let ((old-pollfds (pset-pollfds set)) | |
89 | (nfds (poll-set-nfds set)) | |
90 | (old-ports (pset-ports set)) | |
91 | (new-pollfds (make-bytevector (pollfd-offset new) 0)) | |
92 | (new-ports (make-vector new #f))) | |
93 | (bytevector-copy! old-pollfds 0 new-pollfds 0 | |
94 | (pollfd-offset nfds)) | |
95 | (vector-move-left! old-ports 0 nfds new-ports 0) | |
96 | (set-pset-pollfds! set new-pollfds) | |
97 | (set-pset-ports! set new-ports))))))) | |
98 | ||
99 | (define (poll-set-find-port set port) | |
100 | (let lp ((i 0)) | |
101 | (if (< i (poll-set-nfds set)) | |
102 | (if (equal? (vector-ref (pset-ports set) i) port) | |
103 | i | |
104 | (lp (1+ i))) | |
105 | #f))) | |
106 | ||
107 | (define (poll-set-port set idx) | |
108 | (if (< idx (poll-set-nfds set)) | |
109 | (vector-ref (pset-ports set) idx) | |
110 | (error "poll set index out of bounds" set idx))) | |
111 | ||
112 | (define (poll-set-events set idx) | |
113 | (if (< idx (poll-set-nfds set)) | |
114 | (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4)) | |
115 | (error "poll set index out of bounds" set idx))) | |
116 | ||
117 | (define (set-poll-set-events! set idx events) | |
118 | (if (< idx (poll-set-nfds set)) | |
119 | (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4) | |
120 | events) | |
121 | (error "poll set index out of bounds" set idx))) | |
122 | ||
123 | (define (poll-set-revents set idx) | |
124 | (if (< idx (poll-set-nfds set)) | |
125 | (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6)) | |
126 | (error "poll set index out of bounds" set idx))) | |
127 | ||
128 | (define (set-poll-set-revents! set idx revents) | |
129 | (if (< idx (poll-set-nfds set)) | |
130 | (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6) | |
131 | revents) | |
132 | (error "poll set index out of bounds" set idx))) | |
133 | ||
134 | (define (poll-set-add! set fd-or-port events) | |
135 | (let* ((idx (poll-set-nfds set)) | |
136 | (off (pollfd-offset idx)) | |
137 | (fd (if (integer? fd-or-port) | |
138 | fd-or-port | |
139 | (port->fdes fd-or-port)))) | |
140 | ||
141 | (if (port? fd-or-port) | |
142 | ;; As we store the port in the fdset, there is no need to | |
143 | ;; increment the revealed count to prevent the fd from being | |
144 | ;; closed by a gc'd port. | |
145 | (release-port-handle fd-or-port)) | |
146 | ||
147 | (ensure-pset-size! set (1+ idx)) | |
148 | (bytevector-s32-native-set! (pset-pollfds set) off fd) | |
149 | (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events) | |
150 | (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents | |
151 | (vector-set! (pset-ports set) idx fd-or-port) | |
152 | (set-pset-nfds! set (1+ idx)))) | |
153 | ||
154 | (define (poll-set-remove! set idx) | |
155 | (if (not (< idx (poll-set-nfds set))) | |
156 | (error "poll set index out of bounds" set idx)) | |
157 | (let ((nfds (poll-set-nfds set)) | |
158 | (off (pollfd-offset idx)) | |
159 | (port (vector-ref (pset-ports set) idx))) | |
160 | (vector-move-left! (pset-ports set) (1+ idx) nfds | |
161 | (pset-ports set) idx) | |
162 | (vector-set! (pset-ports set) (1- nfds) #f) | |
163 | (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx)) | |
164 | (pset-pollfds set) off | |
165 | (- (pollfd-offset nfds) (pollfd-offset (1+ idx)))) | |
166 | ;; zero the struct pollfd all at once | |
167 | (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0) | |
168 | (set-pset-nfds! set (1- nfds)) | |
169 | port)) | |
170 | ||
171 | (define* (poll poll-set #:optional (timeout -1)) | |
172 | (primitive-poll (pset-pollfds poll-set) | |
173 | (poll-set-nfds poll-set) | |
e9634465 | 174 | (pset-ports poll-set) |
6f81b18a | 175 | timeout)) |