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 (mod #.sb!unix:fd-setsize))
21 ;; T iff this handler is running.
23 ;; FIXME: unused. At some point this used to be set to T
24 ;; around the call to the handler-function, but that was commented
25 ;; out with the verbose explantion "Doesn't work -- ACK".
28 (function nil :type function)
29 ;; T if this descriptor is bogus.
32 (def!method print-object ((handler handler) stream)
33 (print-unreadable-object (handler stream :type t)
35 "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
36 (handler-direction handler)
37 (handler-bogus handler)
38 (handler-descriptor handler)
39 (handler-function handler))))
41 (defvar *descriptor-handlers* nil
43 "List of all the currently active handlers for file descriptors")
45 (sb!xc:defmacro with-descriptor-handlers (&body forms)
46 ;; FD-STREAM functionality can add and remove descriptors on it's
47 ;; own, so getting an interrupt while modifying this and the
48 ;; starting to recursively modify it could lose...
49 `(without-interrupts ,@forms))
51 (defun list-all-descriptor-handlers ()
52 (with-descriptor-handlers
53 (copy-list *descriptor-handlers*)))
55 (defun select-descriptor-handlers (function)
56 (declare (function function))
57 (with-descriptor-handlers
58 (remove-if-not function *descriptor-handlers*)))
60 (defun map-descriptor-handlers (function)
61 (declare (function function))
62 (with-descriptor-handlers
63 (dolist (handler *descriptor-handlers*)
64 (funcall function handler))))
66 ;;; Add a new handler to *descriptor-handlers*.
67 (defun add-fd-handler (fd direction function)
69 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
70 either :INPUT or :OUTPUT. The value returned should be passed to
71 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
72 (unless (member direction '(:input :output))
73 ;; FIXME: should be TYPE-ERROR?
74 (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction))
75 (let ((handler (make-handler direction fd function)))
76 (with-descriptor-handlers
77 (push handler *descriptor-handlers*))
80 ;;; Remove an old handler from *descriptor-handlers*.
81 (defun remove-fd-handler (handler)
83 "Removes HANDLER from the list of active handlers."
84 (with-descriptor-handlers
85 (setf *descriptor-handlers*
86 (delete handler *descriptor-handlers*))))
88 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
89 (defun invalidate-descriptor (fd)
91 "Remove any handers refering to fd. This should only be used when attempting
92 to recover from a detected inconsistancy."
93 (with-descriptor-handlers
94 (setf *descriptor-handlers*
95 (delete fd *descriptor-handlers*
96 :key #'handler-descriptor))))
98 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
99 (defmacro with-fd-handler ((fd direction function) &rest body)
101 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
102 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
103 use, and FUNCTION is the function to call whenever FD is usable."
104 (let ((handler (gensym)))
108 (setf ,handler (add-fd-handler ,fd ,direction ,function))
111 (remove-fd-handler ,handler))))))
113 ;;; First, get a list and mark bad file descriptors. Then signal an error
114 ;;; offering a few restarts.
115 (defun handler-descriptors-error ()
116 (let ((bogus-handlers nil))
117 (dolist (handler (list-all-descriptor-handlers))
118 (unless (or (handler-bogus handler)
119 (sb!unix:unix-fstat (handler-descriptor handler)))
120 (setf (handler-bogus handler) t)
121 (push handler bogus-handlers)))
122 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
123 bogus-handlers (length bogus-handlers))
125 :report "Remove bogus handlers."
126 (with-descriptor-handlers
127 (setf *descriptor-handlers*
128 (delete-if #'handler-bogus *descriptor-handlers*))))
130 :report "Retry bogus handlers."
131 (dolist (handler bogus-handlers)
132 (setf (handler-bogus handler) nil)))
134 :report "Go on, leaving handlers marked as bogus."))))
136 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
138 ;;; Break a real timeout into seconds and microseconds.
139 (defun decode-timeout (timeout)
140 (declare (values (or index null) index))
142 (integer (values timeout 0))
143 (null (values nil 0))
145 (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
146 (declare (type index q) (single-float r))
147 (values q (the (values index t) (truncate (* r 1f6))))))
149 (error "Timeout is not a real number or NIL: ~S" timeout))))
151 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
152 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
153 ;;; timeout at the correct time irrespective of how many events are handled in
155 (defun wait-until-fd-usable (fd direction &optional timeout)
157 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
158 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
160 (declare (type (or real null) timeout))
162 (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
163 (declare (type (or index null) to-sec to-usec))
164 (multiple-value-bind (stop-sec stop-usec)
166 (multiple-value-bind (okay start-sec start-usec)
167 (sb!unix:unix-gettimeofday)
168 (declare (ignore okay))
169 (let ((usec (+ to-usec start-usec))
170 (sec (+ to-sec start-sec)))
171 (declare (type (unsigned-byte 31) usec sec))
172 (if (>= usec 1000000)
173 (values (1+ sec) (- usec 1000000))
176 (declare (type (unsigned-byte 31) stop-sec stop-usec))
177 (with-fd-handler (fd direction (lambda (fd)
178 (declare (ignore fd))
181 (sub-serve-event to-sec to-usec)
187 (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday)
188 (declare (ignore okay))
189 (when (or (> sec stop-sec)
190 (and (= sec stop-sec) (>= usec stop-usec)))
192 (setq to-sec (- stop-sec sec))
193 (cond ((> usec stop-usec)
195 (setq to-usec (- (+ stop-usec 1000000) usec)))
197 (setq to-usec (- stop-usec usec))))))))))))
199 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
200 ;;; pending events are processed before returning.
201 (defun serve-all-events (&optional timeout)
203 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
204 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
205 0 until all events have been served. SERVE-ALL-EVENTS returns T if
206 SERVE-EVENT did something and NIL if not."
208 (sval (serve-event timeout) (serve-event 0)))
212 ;;; Serve a single event.
213 (defun serve-event (&optional timeout)
215 "Receive on all ports and Xevents and dispatch to the appropriate handler
216 function. If timeout is specified, server will wait the specified time (in
217 seconds) and then return, otherwise it will wait until something happens.
218 Server returns T if something happened and NIL otherwise."
219 (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
220 (sub-serve-event to-sec to-usec)))
222 ;;; When a *periodic-polling-function* is defined the server will not
223 ;;; block for more than the maximum event timeout and will call the
224 ;;; polling function if it does time out.
225 (declaim (type (or null function) *periodic-polling-function*))
226 (defvar *periodic-polling-function* nil)
227 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
228 (defvar *max-event-to-sec* 1)
229 (defvar *max-event-to-usec* 0)
231 ;;; Takes timeout broken into seconds and microseconds.
232 (defun sub-serve-event (to-sec to-usec)
233 (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
235 (let ((call-polling-fn nil))
236 (when (and *periodic-polling-function*
237 ;; Enforce a maximum timeout.
239 (> to-sec *max-event-to-sec*)
240 (and (= to-sec *max-event-to-sec*)
241 (> to-usec *max-event-to-usec*))))
242 (setf to-sec *max-event-to-sec*)
243 (setf to-usec *max-event-to-usec*)
244 (setf call-polling-fn t))
246 ;; Next, wait for something to happen.
247 (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
248 (write-fds (sb!alien:struct sb!unix:fd-set)))
249 (sb!unix:fd-zero read-fds)
250 (sb!unix:fd-zero write-fds)
252 (declare (type index count))
254 ;; Initialize the fd-sets for UNIX-SELECT and return the active
256 (map-descriptor-handlers
258 ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
259 ;; to be checked here in addition to HANDLER-BOGUS
260 (unless (handler-bogus handler)
261 (let ((fd (handler-descriptor handler)))
262 (ecase (handler-direction handler)
263 (:input (sb!unix:fd-set fd read-fds))
264 (:output (sb!unix:fd-set fd write-fds)))
269 (multiple-value-bind (value err)
270 (sb!unix:unix-fast-select count
271 (sb!alien:addr read-fds)
272 (sb!alien:addr write-fds)
274 #!+win32 (declare (ignorable err))
277 (when call-polling-fn
278 (funcall *periodic-polling-function*)))
280 ;; Call file descriptor handlers according to the
281 ;; readable and writable masks returned by select.
283 (select-descriptor-handlers
285 (let ((fd (handler-descriptor handler)))
286 (ecase (handler-direction handler)
287 (:input (sb!unix:fd-isset fd read-fds))
288 (:output (sb!unix:fd-isset fd write-fds)))))))
289 (funcall (handler-function handler)
290 (handler-descriptor handler)))
293 ((eql err sb!unix:eintr)
294 ;; We did an interrupt.
296 ;; FIXME: Why T here?
299 ;; One of the file descriptors is bad.
300 (handler-descriptors-error)