1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!IMPL")
12 ;;;; file descriptor I/O noise
15 (:constructor make-handler
(direction descriptor function
))
17 ;; Reading or writing...
18 (direction nil
:type
(member :input
:output
))
19 ;; File descriptor this handler is tied to.
20 (descriptor 0 :type
#!-win32-uses-file-handles
(mod #.sb
!unix
:fd-setsize
)
21 #!+win32-uses-file-handles fixnum
)
22 ;; T iff this handler is running.
24 ;; FIXME: unused. At some point this used to be set to T
25 ;; around the call to the handler-function, but that was commented
26 ;; out with the verbose explantion "Doesn't work -- ACK".
29 (function nil
:type function
)
30 ;; T if this descriptor is bogus.
33 (def!method print-object
((handler handler
) stream
)
34 (print-unreadable-object (handler stream
:type t
)
36 "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
37 (handler-direction handler
)
38 (handler-bogus handler
)
39 (handler-descriptor handler
)
40 (handler-function handler
))))
42 (defvar *descriptor-handlers
* nil
44 "List of all the currently active handlers for file descriptors")
46 (sb!xc
:defmacro with-descriptor-handlers
(&body forms
)
47 ;; FD-STREAM functionality can add and remove descriptors on it's
48 ;; own, so getting an interrupt while modifying this and the
49 ;; starting to recursively modify it could lose...
50 `(without-interrupts ,@forms
))
52 (defun list-all-descriptor-handlers ()
53 (with-descriptor-handlers
54 (copy-list *descriptor-handlers
*)))
56 (defun select-descriptor-handlers (function)
57 (declare (function function
))
58 (with-descriptor-handlers
59 (remove-if-not function
*descriptor-handlers
*)))
61 (defun map-descriptor-handlers (function)
62 (declare (function function
))
63 (with-descriptor-handlers
64 (dolist (handler *descriptor-handlers
*)
65 (funcall function handler
))))
67 ;;; Add a new handler to *descriptor-handlers*.
68 (defun add-fd-handler (fd direction function
)
70 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
71 either :INPUT or :OUTPUT. The value returned should be passed to
72 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
73 (unless (member direction
'(:input
:output
))
74 ;; FIXME: should be TYPE-ERROR?
75 (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction
))
76 (let ((handler (make-handler direction fd function
)))
77 (with-descriptor-handlers
78 (push handler
*descriptor-handlers
*))
81 ;;; Remove an old handler from *descriptor-handlers*.
82 (defun remove-fd-handler (handler)
84 "Removes HANDLER from the list of active handlers."
85 (with-descriptor-handlers
86 (setf *descriptor-handlers
*
87 (delete handler
*descriptor-handlers
*))))
89 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
90 (defun invalidate-descriptor (fd)
92 "Remove any handers refering to fd. This should only be used when attempting
93 to recover from a detected inconsistancy."
94 (with-descriptor-handlers
95 (setf *descriptor-handlers
*
96 (delete fd
*descriptor-handlers
*
97 :key
#'handler-descriptor
))))
99 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
100 (defmacro with-fd-handler
((fd direction function
) &rest body
)
102 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
103 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
104 use, and FUNCTION is the function to call whenever FD is usable."
105 (let ((handler (gensym)))
109 (setf ,handler
(add-fd-handler ,fd
,direction
,function
))
112 (remove-fd-handler ,handler
))))))
114 ;;; First, get a list and mark bad file descriptors. Then signal an error
115 ;;; offering a few restarts.
116 (defun handler-descriptors-error ()
117 (let ((bogus-handlers nil
))
118 (dolist (handler (list-all-descriptor-handlers))
119 (unless (or (handler-bogus handler
)
120 (sb!unix
:unix-fstat
(handler-descriptor handler
)))
121 (setf (handler-bogus handler
) t
)
122 (push handler bogus-handlers
)))
123 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
124 bogus-handlers
(length bogus-handlers
))
126 :report
"Remove bogus handlers."
127 (with-descriptor-handlers
128 (setf *descriptor-handlers
*
129 (delete-if #'handler-bogus
*descriptor-handlers
*))))
131 :report
"Retry bogus handlers."
132 (dolist (handler bogus-handlers
)
133 (setf (handler-bogus handler
) nil
)))
135 :report
"Go on, leaving handlers marked as bogus.")))
139 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
141 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
142 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
143 ;;; timeout at the correct time irrespective of how many events are handled in
145 (defun wait-until-fd-usable (fd direction
&optional timeout
)
147 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
148 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
152 (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp
)
153 (decode-timeout timeout
)
154 (declare (type (or integer null
) to-sec to-usec
))
155 (with-fd-handler (fd direction
(lambda (fd)
156 (declare (ignore fd
))
159 (sub-serve-event to-sec to-usec signalp
)
161 (return-from wait-until-fd-usable t
))
163 (multiple-value-bind (sec usec
)
164 (decode-internal-time (get-internal-real-time))
165 (setf to-sec
(- stop-sec sec
))
166 (cond ((> usec stop-usec
)
168 (setf to-usec
(- (+ stop-usec
1000000) usec
)))
170 (setf to-usec
(- stop-usec usec
)))))
171 (when (or (minusp to-sec
) (minusp to-usec
))
176 (return-from wait-until-fd-usable nil
)))))))))
178 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
179 ;;; pending events are processed before returning.
180 (defun serve-all-events (&optional timeout
)
182 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
183 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
184 timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
185 T if SERVE-EVENT did something and NIL if not."
187 (sval (serve-event timeout
) (serve-event 0)))
191 ;;; Serve a single set of events.
192 (defun serve-event (&optional timeout
)
194 "Receive pending events on all FD-STREAMS and dispatch to the appropriate
195 handler functions. If timeout is specified, server will wait the specified
196 time (in seconds) and then return, otherwise it will wait until something
197 happens. Server returns T if something happened and NIL otherwise. Timeout
198 0 means polling without waiting."
199 (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp
)
200 (decode-timeout timeout
)
201 (declare (ignore stop-sec stop-usec
))
202 (sub-serve-event to-sec to-usec signalp
)))
204 ;;; When a *periodic-polling-function* is defined the server will not
205 ;;; block for more than the maximum event timeout and will call the
206 ;;; polling function if it does time out.
207 (declaim (type (or null symbol function
) *periodic-polling-function
*))
208 (defvar *periodic-polling-function
* nil
209 "Either NIL, or a designator for a function callable without any
210 arguments. Called when the system has been waiting for input for
211 longer then *PERIODIC-POLLING-PERIOD* seconds. Shared between all
212 threads, unless locally bound. EXPERIMENTAL.")
213 (declaim (real *periodic-polling-period
*))
214 (defvar *periodic-polling-period
* 0
215 "A real number designating the number of seconds to wait for input
216 at maximum, before calling the *PERIODIC-POLLING-FUNCTION* \(if any.)
217 Shared between all threads, unless locally bound. EXPERIMENTAL.")
219 ;;; Takes timeout broken into seconds and microseconds.
220 #!-win32-uses-file-handles
221 (defun sub-serve-event (to-sec to-usec deadlinep
)
222 ;; Figure out our peridic polling needs. MORE-SEC/USEC is the amount
223 ;; of actual waiting left after we poll (assuming we are polling.)
224 (multiple-value-bind (poll more-sec more-usec
)
225 (when *periodic-polling-function
*
226 (multiple-value-bind (p-sec p-usec
)
227 (decode-internal-time
228 (seconds-to-internal-time *periodic-polling-period
*))
229 (when (or (not to-sec
) (> to-sec p-sec
)
230 (and (= to-sec p-sec
) (> to-usec p-usec
)))
231 (multiple-value-prog1
232 (values *periodic-polling-function
*
233 (when to-sec
(- to-sec p-sec
))
234 (when to-sec
(- to-usec p-usec
)))
238 ;; Next, wait for something to happen.
239 (sb!alien
:with-alien
((read-fds (sb!alien
:struct sb
!unix
:fd-set
))
240 (write-fds (sb!alien
:struct sb
!unix
:fd-set
)))
241 (sb!unix
:fd-zero read-fds
)
242 (sb!unix
:fd-zero write-fds
)
244 (declare (type index count
))
246 ;; Initialize the fd-sets for UNIX-SELECT and return the active
248 (map-descriptor-handlers
250 ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
251 ;; to be checked here in addition to HANDLER-BOGUS
252 (unless (handler-bogus handler
)
253 (let ((fd (handler-descriptor handler
)))
254 (ecase (handler-direction handler
)
255 (:input
(sb!unix
:fd-set fd read-fds
))
256 (:output
(sb!unix
:fd-set fd write-fds
)))
261 ;; Next, wait for something to happen.
262 (multiple-value-bind (value err
)
263 (sb!unix
:unix-fast-select count
264 (sb!alien
:addr read-fds
)
265 (sb!alien
:addr write-fds
)
268 (declare (ignore err
))
269 ;; Now see what it was (if anything)
271 ;; Interrupted or one of the file descriptors is bad.
272 ;; FIXME: Check for other errnos. Why do we return true
275 (if (eql err sb
!unix
:eintr
)
277 (handler-descriptors-error))
279 (handler-descriptors-error))
281 ;; Got something. Call file descriptor handlers
282 ;; according to the readable and writable masks
283 ;; returned by select.
285 (select-descriptor-handlers
287 (let ((fd (handler-descriptor handler
)))
288 (ecase (handler-direction handler
)
289 (:input
(sb!unix
:fd-isset fd read-fds
))
290 (:output
(sb!unix
:fd-isset fd write-fds
)))))))
291 (funcall (handler-function handler
)
292 (handler-descriptor handler
)))
298 (sub-serve-event more-sec more-usec deadlinep
))
300 (signal-deadline))))))))))
302 #!+win32-uses-file-handles
303 (defvar *message-function
*) ; nyef-ism...?
305 #!+win32-uses-file-handles
306 (defun sub-serve-event (to-sec to-usec deadlinep
)
307 (sb!alien
:with-alien
((handles (array unsigned-long
63)))
308 ;; NOTE: Can't have more than 63 handles (api limit).
309 ;; FIXME: Enforce this.
312 (timeout (cond ((or to-sec to-usec
)
313 (+ (* (or to-sec
0) 1000)
316 (unless sb
!sys
:*interrupts-enabled
*
317 (sb!unix
::note-dangerous-select
))
318 sb
!win32
::+infinite
+))))
320 (map-descriptor-handlers
322 (unless (handler-bogus handler
)
323 (ecase (handler-direction handler
)
325 (let* ((handle (handler-descriptor handler
)))
326 (with-alien ((avail unsigned-long
))
327 (if (zerop (sb!win32
:peek-named-pipe handle nil
0
328 nil
(addr avail
) nil
))
330 (setf (deref handles count
) handle
)
332 (setf pipe-ready t
)))))
334 ;; Don't do anything here.
336 (let ((result (if (zerop count
)
337 ;; Either there are no descriptor handlers or
338 ;; they're all pipes. We don't dare call a
340 (if (boundp '*message-function
*)
341 ;; These results lose no matter what.
346 ;; There are valid descriptor handlers that
348 (if (boundp '*message-function
*)
349 (sb!win32
::MsgWaitForMultipleObjects
350 count
(addr (deref handles
0))
351 0 timeout sb
!win32
::+qs-allevents
+)
352 (sb!win32
::WaitForMultipleObjects
353 count
(addr (deref handles
0))
356 (dolist (handler (select-descriptor-handlers
358 (ecase (handler-direction handler
)
360 (with-alien ((avail unsigned-long
))
362 (sb!win32
:peek-named-pipe
363 (handler-descriptor handler
)
364 nil
0 nil
(addr avail
) nil
)))
365 (not (zerop avail
)))))
367 ;; Handles are always ready for output.
369 (funcall (handler-function handler
)
370 (handler-descriptor handler
))
372 (cond ((eq result nil
))
374 ;; The result'th handle in handles is ready for reading.
375 (let* ((handle (deref handles result
)))
376 (dolist (handler (select-descriptor-handlers
378 (ecase (handler-direction handler
)
380 (= handle
(handler-descriptor handler
)))
382 ;; Handles are always ready for output.
384 (funcall (handler-function handler
)
385 (handler-descriptor handler
))
388 ;; There is a windows message ready.
389 (funcall *message-function
*)
391 ((= result sb
!win32
::+wait-timeout
+)
392 ;; The timeout elapsed.
394 (sb!sys
:signal-deadline
))
397 ;; Something unexpected happened, should probably error.
398 (handler-descriptors-error) ;; ???