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
#!-os-provides-poll
(mod #.sb
!unix
:fd-setsize
)
21 #!+os-provides-poll
(and fixnum unsigned-byte
))
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 (defstruct (pollfds (:constructor make-pollfds
(list)))
35 ;; If using poll() we maintain, in addition to a list of HANDLER,
36 ;; an (ALIEN (* STRUCT POLLFD)) to avoid creating it repeatedly.
37 ;; The C array is created only when SUB-SUB-SERVE-EVENT needs it,
38 ;; not on each call to ADD/REMOVE-FD-HANDLER.
39 ;; If using select(), the C array is not used.
40 #!+os-provides-poll
(fds) ;
41 ;; N-FDS is less than or equal to the length of the C array,
42 ;; which is created potentially oversized.
43 #!+os-provides-poll
(n-fds)
44 ;; map from index in LIST to index into alien FDS
45 #!+os-provides-poll
(map))
47 (def!method print-object
((handler handler
) stream
)
48 (print-unreadable-object (handler stream
:type t
)
50 "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
51 (handler-direction handler
)
52 (handler-bogus handler
)
53 (handler-descriptor handler
)
54 (handler-function handler
))))
56 (defvar *descriptor-handlers
* nil
58 "List of all the currently active handlers for file descriptors")
60 (sb!xc
:defmacro with-descriptor-handlers
(&body forms
)
61 ;; FD-STREAM functionality can add and remove descriptors on it's
62 ;; own, so getting an interrupt while modifying this and the
63 ;; starting to recursively modify it could lose...
64 `(without-interrupts ,@forms
))
66 ;; Deallocating the pollfds is a no-op if not using poll()
67 #!-os-provides-poll
(declaim (inline deallocate-pollfds
))
69 ;; Free the cached C structures, if allocated.
70 ;; Must be called within the extent of WITH-DESCRIPTOR-HANDLERS.
71 (defun deallocate-pollfds ()
73 (awhen *descriptor-handlers
*
74 (when (pollfds-fds it
)
75 (free-alien (pollfds-fds it
)))
76 (setf (pollfds-fds it
) nil
77 (pollfds-n-fds it
) nil
78 (pollfds-map it
) nil
)))
80 (defun list-all-descriptor-handlers ()
81 (with-descriptor-handlers
82 (awhen *descriptor-handlers
*
83 (copy-list (pollfds-list it
)))))
85 ;; With the poll() interface it requires more care to maintain
86 ;; a correspondence betwen the Lisp and C representations.
88 (defun select-descriptor-handlers (function)
89 (declare (function function
))
90 (with-descriptor-handlers
91 (awhen *descriptor-handlers
*
92 (remove-if-not function
(pollfds-list it
)))))
94 (defun map-descriptor-handlers (function)
95 (declare (function function
))
96 (with-descriptor-handlers
97 (awhen *descriptor-handlers
*
98 (dolist (handler (pollfds-list it
))
99 (funcall function handler
)))))
101 ;;; Add a new handler to *descriptor-handlers*.
102 (defun add-fd-handler (fd direction function
)
104 "Arrange to call FUNCTION whenever FD is usable. DIRECTION should be
105 either :INPUT or :OUTPUT. The value returned should be passed to
106 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
107 (unless (member direction
'(:input
:output
))
108 ;; FIXME: should be TYPE-ERROR?
109 (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction
))
110 ;; lp#316068 - generate a more specific error than "X is not (MOD n)"
112 (unless (<= 0 fd
(1- sb
!unix
:fd-setsize
))
113 (error "Cannot add an FD handler for ~D: not under FD_SETSIZE limit." fd
))
114 (let ((handler (make-handler direction fd function
)))
115 (with-descriptor-handlers
117 (let ((handlers *descriptor-handlers
*))
119 (setf *descriptor-handlers
* (make-pollfds (list handler
)))
120 (push handler
(pollfds-list handlers
)))))
123 (macrolet ((filter-handlers (newval-form)
124 `(with-descriptor-handlers
126 (let* ((holder *descriptor-handlers
*)
127 (handlers (if holder
(pollfds-list holder
)))
129 ;; The case of "no handlers" is *DESCRIPTOR-HANDLERS* = NIL,
130 ;; like it starts as. So we set it back to NIL rather than
131 ;; an empty struct if no handlers remain.
133 ;; Since this macro is only for deletion of handlers,
134 ;; if LIST is not nil then HOLDER was too.
135 (setf (pollfds-list holder
) list
)
136 (setf *descriptor-handlers
* nil
))))))
138 ;;; Remove an old handler from *descriptor-handlers*.
139 (defun remove-fd-handler (handler)
141 "Removes HANDLER from the list of active handlers."
142 (filter-handlers (delete handler handlers
)))
144 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
145 (defun invalidate-descriptor (fd)
147 "Remove any handlers referring to FD. This should only be used when attempting
148 to recover from a detected inconsistency."
149 (filter-handlers (delete fd handlers
:key
#'handler-descriptor
)))
151 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
152 ;;; Note: this makes the poll() interface not super efficient because
153 ;;; it discards the cached C array of (struct pollfd), as it must do
154 ;;; each time the list of Lisp HANDLER structs is touched.
155 (defmacro with-fd-handler
((fd direction function
) &rest body
)
157 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
158 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
159 use, and FUNCTION is the function to call whenever FD is usable."
160 (let ((handler (gensym)))
164 (setf ,handler
(add-fd-handler ,fd
,direction
,function
))
167 (remove-fd-handler ,handler
))))))
169 ;;; First, get a list and mark bad file descriptors. Then signal an error
170 ;;; offering a few restarts.
171 (defun handler-descriptors-error
172 #!+os-provides-poll
(&optional
(bogus-handlers nil handlers-supplied-p
))
173 #!-os-provides-poll
(&aux bogus-handlers handlers-supplied-p
)
174 (if handlers-supplied-p
175 (dolist (handler bogus-handlers
)
176 ;; no fstat() - the kernel deemed them bogus already
177 (setf (handler-bogus handler
) t
))
178 (dolist (handler (list-all-descriptor-handlers))
179 (unless (or (handler-bogus handler
)
180 (sb!unix
:unix-fstat
(handler-descriptor handler
)))
181 (setf (handler-bogus handler
) t
)
182 (push handler bogus-handlers
))))
184 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
185 bogus-handlers
(length bogus-handlers
))
187 :report
"Remove bogus handlers."
188 (filter-handlers (delete-if #'handler-bogus handlers
)))
190 :report
"Retry bogus handlers."
191 (dolist (handler bogus-handlers
)
192 (setf (handler-bogus handler
) nil
)))
194 :report
"Go on, leaving handlers marked as bogus.")))
198 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
200 ;;; When a *periodic-polling-function* is defined the server will not
201 ;;; block for more than the maximum event timeout and will call the
202 ;;; polling function if it does time out.
203 (declaim (type (or null symbol function
) *periodic-polling-function
*))
204 (defvar *periodic-polling-function
* nil
206 "Either NIL, or a designator for a function callable without any
207 arguments. Called when the system has been waiting for input for
208 longer then *PERIODIC-POLLING-PERIOD* seconds. Shared between all
209 threads, unless locally bound. EXPERIMENTAL.")
210 (declaim (real *periodic-polling-period
*))
211 (defvar *periodic-polling-period
* 0
213 "A real number designating the number of seconds to wait for input
214 at maximum, before calling the *PERIODIC-POLLING-FUNCTION* \(if any.)
215 Shared between all threads, unless locally bound. EXPERIMENTAL.")
217 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
218 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
219 ;;; timeout at the correct time irrespective of how many events are handled in
221 (defun wait-until-fd-usable (fd direction
&optional timeout
(serve-events t
))
223 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
224 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
225 up. Returns true once the FD is usable, NIL return indicates timeout.
227 If SERVE-EVENTS is true (the default), events on other FDs are served while
231 (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp
)
232 (decode-timeout timeout
)
233 (declare (type (or integer null
) to-sec to-usec
))
234 (flet ((maybe-update-timeout ()
235 ;; If we return early, recompute the timeouts, possibly
236 ;; signaling the deadline or returning with NIL to caller.
237 (setf (values to-sec to-usec
)
238 (relative-decoded-times stop-sec stop-usec
))
239 (when (and (zerop to-sec
) (not (plusp to-usec
)))
244 (return-from wait-until-fd-usable nil
))))))
245 (if (and serve-events
246 ;; No timeout or non-zero timeout
248 (not (= 0 to-sec to-usec
)))
249 ;; Something to do while we wait
250 (or *descriptor-handlers
* *periodic-polling-function
*))
251 ;; Loop around SUB-SERVE-EVENT till done.
252 (dx-let ((usable (list nil
)))
253 (dx-flet ((usable! (fd)
254 (declare (ignore fd
))
255 (setf (car usable
) t
)))
256 (with-fd-handler (fd direction
#'usable
!)
258 (sub-serve-event to-sec to-usec signalp
)
260 (return-from wait-until-fd-usable t
))
262 (maybe-update-timeout))))))
263 ;; If we don't have to serve events, just poll on the single FD instead.
264 (loop for to-msec
= (if (and to-sec to-usec
)
265 (+ (* 1000 to-sec
) (truncate to-usec
1000))
267 when
(or #!+win32
(eq direction
:output
)
268 #!+win32
(sb!win32
:handle-listen
269 (sb!win32
:get-osfhandle fd
))
271 (sb!unix
:unix-simple-poll fd direction to-msec
))
272 do
(return-from wait-until-fd-usable t
)
274 do
(when to-sec
(maybe-update-timeout))
275 #!+win32
(sb!thread
:thread-yield
)))))))
277 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
278 ;;; pending events are processed before returning.
279 (defun serve-all-events (&optional timeout
)
281 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
282 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
283 timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
284 T if SERVE-EVENT did something and NIL if not."
286 (sval (serve-event timeout
) (serve-event 0)))
290 ;;; Serve a single set of events.
291 (defun serve-event (&optional timeout
)
293 "Receive pending events on all FD-STREAMS and dispatch to the appropriate
294 handler functions. If timeout is specified, server will wait the specified
295 time (in seconds) and then return, otherwise it will wait until something
296 happens. Server returns T if something happened and NIL otherwise. Timeout
297 0 means polling without waiting."
298 (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp
)
299 (decode-timeout timeout
)
300 (declare (ignore stop-sec stop-usec
))
301 (sub-serve-event to-sec to-usec signalp
)))
303 ;;; Takes timeout broken into seconds and microseconds, NIL timeout means
304 ;;; to wait as long as needed.
305 (defun sub-serve-event (to-sec to-usec deadlinep
)
307 (if *periodic-polling-function
*
308 (multiple-value-bind (p-sec p-usec
)
309 (decode-internal-time
310 (seconds-to-internal-time *periodic-polling-period
*))
312 (loop repeat
(/ (+ to-sec
(/ to-usec
1e6
))
313 *periodic-polling-period
*)
314 thereis
(sub-sub-serve-event p-sec p-usec
)
315 do
(funcall *periodic-polling-function
*))
316 (loop thereis
(sub-sub-serve-event p-sec p-usec
)
317 do
(funcall *periodic-polling-function
*))))
318 (sub-sub-serve-event to-sec to-usec
))
322 ;;; Handles the work of the above, except for periodic polling. Returns
323 ;;; true if something of interest happened.
325 (defun sub-sub-serve-event (to-sec to-usec
)
326 (with-alien ((read-fds (struct sb
!unix
:fd-set
))
327 (write-fds (struct sb
!unix
:fd-set
)))
328 (sb!unix
:fd-zero read-fds
)
329 (sb!unix
:fd-zero write-fds
)
331 (declare (type index count
))
333 ;; Initialize the fd-sets for UNIX-SELECT and return the active
335 (map-descriptor-handlers
337 ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
338 ;; to be checked here in addition to HANDLER-BOGUS
339 (unless (handler-bogus handler
)
340 (let ((fd (handler-descriptor handler
)))
341 (ecase (handler-direction handler
)
342 (:input
(sb!unix
:fd-set fd read-fds
))
343 (:output
(sb!unix
:fd-set fd write-fds
)))
348 ;; Next, wait for something to happen.
349 (multiple-value-bind (value err
)
350 (sb!unix
:unix-fast-select count
355 (declare (ignore err
))
356 ;; Now see what it was (if anything)
358 ;; Interrupted or one of the file descriptors is bad.
359 ;; FIXME: Check for other errnos. Why do we return true
364 (handler-descriptors-error))
365 ((#.sb
!unix
:eintr
#.sb
!unix
:eagain
)
368 (with-simple-restart (continue "Ignore failure and continue.")
369 (simple-perror "Unix system call select() failed"
372 (handler-descriptors-error))
374 ;; Got something. Call file descriptor handlers
375 ;; according to the readable and writable masks
376 ;; returned by select.
378 (select-descriptor-handlers
380 (let ((fd (handler-descriptor handler
)))
381 (ecase (handler-direction handler
)
382 (:input
(sb!unix
:fd-isset fd read-fds
))
383 (:output
(sb!unix
:fd-isset fd write-fds
)))))))
384 (with-simple-restart (remove-fd-handler "Remove ~S" handler
)
385 (funcall (handler-function handler
)
386 (handler-descriptor handler
))
388 (remove-fd-handler handler
)
392 ;; Return an pointer to an array of (struct pollfd).
393 ;; This isn't done via WITH-ALIEN for 2 reasons:
394 ;; 1. WITH-ALIEN can't make variable-length arrays
395 ;; 2. it's slightly nontrivial to condense the :input and :output masks
396 ;; Making USE-SCRATCHPAD-P an optional argument is a KLUDGE, but it allows
397 ;; picking which method of file descriptor de-duplication is used,
398 ;; so that both can be exercised by tests.
400 (defun compute-pollfds (handlers &optional
401 (n-handlers (length handlers
))
402 (use-scratchpad-p (>= n-handlers
15)))
403 ;; Assuming that all fds in HANDLERS are unique and none are bogus,
404 ;; either of which could be untrue,
405 ;; allocate the maximum length C array we'd need.
406 ;; Since interrupts are disabled inside WITH-DESCRIPTOR-HANDLERS,
407 ;; and *DESCRIPTOR-HANDLERS* is per-thread, double traversal is ok.
408 (let* ((fds (make-alien (struct sb
!unix
:pollfd
) n-handlers
))
409 (map (make-array n-handlers
:initial-element nil
))
412 (labels ((flag-bit (handler)
413 (ecase (handler-direction handler
)
414 (:input sb
!unix
:pollin
)
415 (:output sb
!unix
:pollout
)))
417 (let ((fd-index n-fds
))
419 (setf (slot (deref fds fd-index
) 'sb
!unix
:fd
)
420 (handler-descriptor handler
)
421 (slot (deref fds fd-index
) 'sb
!unix
:events
)
424 (or-flag (index handler
)
425 (setf (slot (deref fds index
) 'sb
!unix
:events
)
426 (logior (slot (deref fds index
) 'sb
!unix
:events
)
427 (flag-bit handler
)))))
428 ;; Now compute unique non-bogus file descriptors.
430 ;; This is O(N), but wastes space if there are, say, 16 descriptors
431 ;; numbered 1 through 15 and then 1025.
432 (let ((scratchpad ; direct map from file descriptor to position in FDS
433 (make-array (1+ (loop for handler in handlers
434 maximize
(handler-descriptor handler
)))
435 :initial-element nil
)))
436 (dolist (handler handlers
)
438 (unless (handler-bogus handler
)
439 (let* ((fd (handler-descriptor handler
))
440 (fd-index (svref scratchpad fd
)))
442 (or-flag fd-index handler
)
443 (setf fd-index
(set-flag handler
)
444 (svref scratchpad fd
) fd-index
))
445 (setf (svref map handler-index
) fd-index
)))))
446 ;; This is O(N^2) but fast for small inputs.
447 (dolist (handler handlers
)
449 (unless (handler-bogus handler
)
450 (let ((dup-of (position (handler-descriptor handler
)
451 handlers
:key
(lambda (x)
452 (unless (handler-bogus x
)
453 (handler-descriptor x
)))
456 (if dup-of
; fd already got an index into pollfds
457 (or-flag (setq fd-index
(svref map dup-of
)) handler
)
458 (setq fd-index
(set-flag handler
)))
459 (setf (svref map handler-index
) fd-index
))))))
460 (values fds n-fds map
)))
462 ;;; Handles the work of the above, except for periodic polling. Returns
463 ;;; true if something of interest happened.
465 (defun sub-sub-serve-event (to-sec to-usec
)
466 (let (list fds count map
)
467 (with-descriptor-handlers
468 (let ((handlers *descriptor-handlers
*))
470 (setq list
(pollfds-list handlers
)
471 fds
(pollfds-fds handlers
)
472 count
(pollfds-n-fds handlers
)
473 map
(pollfds-map handlers
))
474 (when (and list
(not fds
)) ; make the C array
475 (multiple-value-setq (fds count map
) (compute-pollfds list
))
476 (setf (pollfds-fds handlers
) fds
477 (pollfds-n-fds handlers
) count
478 (pollfds-map handlers
) map
)))))
479 ;; poll() wants the timeout in milliseconds.
481 (if (or (null to-sec
) (null to-usec
))
483 (ceiling (+ (* to-sec
1000000) to-usec
) 1000))))
484 ;; Next, wait for something to happen.
485 (multiple-value-bind (value err
)
487 (sb!unix
:unix-poll fds count to-millisec
)
488 ;; If invoked with no descriptors only for the effect of waiting
489 ;; until the timeout, make a valid pointer to a (struct pollfd).
490 (with-alien ((a (struct sb
!unix
:pollfd
)))
491 (sb!unix
:unix-poll a
0 to-millisec
)))
492 ;; From here down is mostly the same as the code
493 ;; for #!-os-provides-poll.
495 ;; Now see what it was (if anything)
497 ;; Interrupted or one of the file descriptors is bad.
498 ;; FIXME: Check for other errnos. Why do we return true
502 ;; poll() should never return EBADF, but I'm afraid that by
503 ;; removing this, someone will find a broken OS which does.
504 (handler-descriptors-error))
505 ((#.sb
!unix
:eintr
#.sb
!unix
:eagain
)
508 (with-simple-restart (continue "Ignore failure and continue.")
509 (simple-perror "Unix system call poll() failed"
512 ;; Got something. Scan the 'revents' fields of the pollfds
513 ;; to decide what to call.
514 ;; The #!-os-provides-poll code looks at *DESCRIPTOR-HANDLERS*
515 ;; again at this point, which seems wrong, but not terribly wrong
516 ;; because at worst there will be a a zero bit for a handler's
517 ;; descriptor. But I can't see how it would make sense here to
518 ;; look again because if anything changed, then the map of
519 ;; handler to index into the C array was necessarily clobbered.
520 (loop for handler in list
521 for fd-index across map
522 for revents
= (slot (deref fds fd-index
) 'sb
!unix
:revents
)
523 when
(logtest revents sb
!unix
:pollnval
)
524 collect handler into bad
525 ;; James Knight says that if POLLERR is set, user code
526 ;; _should_ attempt to perform I/O to observe the error.
527 ;; So we trigger either handler direction.
528 else when
(logtest revents
529 (ecase (handler-direction handler
)
530 ;; POLLHUP implies read will not block
531 (:input
(logior sb
!unix
:pollin
534 (:output
(logior sb
!unix
:pollout
536 collect handler into good
540 (handler-descriptors-error bad
)
541 (dolist (handler good t
)
542 (with-simple-restart (remove-fd-handler "Remove ~S" handler
)
543 (funcall (handler-function handler
)
544 (handler-descriptor handler
))
546 (remove-fd-handler handler
)