fix rounding of floats big enough to be bignums
[sbcl.git] / src / code / serve-event.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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.
9
10 (in-package "SB!IMPL")
11
12 ;;;; file descriptor I/O noise
13
14 (defstruct (handler
15             (:constructor make-handler (direction descriptor function))
16             (:copier nil))
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.
22   ;;
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".
26   active
27   ;; Function to call.
28   (function nil :type function)
29   ;; T if this descriptor is bogus.
30   bogus)
31
32 (def!method print-object ((handler handler) stream)
33   (print-unreadable-object (handler stream :type t)
34     (format stream
35             "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
36             (handler-direction handler)
37             (handler-bogus handler)
38             (handler-descriptor handler)
39             (handler-function handler))))
40
41 (defvar *descriptor-handlers* nil
42   #!+sb-doc
43   "List of all the currently active handlers for file descriptors")
44
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))
50
51 (defun list-all-descriptor-handlers ()
52   (with-descriptor-handlers
53     (copy-list *descriptor-handlers*)))
54
55 (defun select-descriptor-handlers (function)
56   (declare (function function))
57   (with-descriptor-handlers
58     (remove-if-not function *descriptor-handlers*)))
59
60 (defun map-descriptor-handlers (function)
61   (declare (function function))
62   (with-descriptor-handlers
63     (dolist (handler *descriptor-handlers*)
64       (funcall function handler))))
65
66 ;;; Add a new handler to *descriptor-handlers*.
67 (defun add-fd-handler (fd direction function)
68   #!+sb-doc
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   (unless (<= 0 fd (1- sb!unix:fd-setsize))
76     (error "Cannot add an FD handler for ~D: not under FD_SETSIZE limit." fd))
77   (let ((handler (make-handler direction fd function)))
78     (with-descriptor-handlers
79       (push handler *descriptor-handlers*))
80     handler))
81
82 ;;; Remove an old handler from *descriptor-handlers*.
83 (defun remove-fd-handler (handler)
84   #!+sb-doc
85   "Removes HANDLER from the list of active handlers."
86   (with-descriptor-handlers
87     (setf *descriptor-handlers*
88           (delete handler *descriptor-handlers*))))
89
90 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
91 (defun invalidate-descriptor (fd)
92   #!+sb-doc
93   "Remove any handers refering to fd. This should only be used when attempting
94   to recover from a detected inconsistancy."
95   (with-descriptor-handlers
96     (setf *descriptor-handlers*
97           (delete fd *descriptor-handlers*
98                   :key #'handler-descriptor))))
99
100 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
101 (defmacro with-fd-handler ((fd direction function) &rest body)
102   #!+sb-doc
103   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
104    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
105    use, and FUNCTION is the function to call whenever FD is usable."
106   (let ((handler (gensym)))
107     `(let (,handler)
108        (unwind-protect
109            (progn
110              (setf ,handler (add-fd-handler ,fd ,direction ,function))
111              ,@body)
112          (when ,handler
113            (remove-fd-handler ,handler))))))
114
115 ;;; First, get a list and mark bad file descriptors. Then signal an error
116 ;;; offering a few restarts.
117 (defun handler-descriptors-error ()
118   (let ((bogus-handlers nil))
119     (dolist (handler (list-all-descriptor-handlers))
120       (unless (or (handler-bogus handler)
121                   (sb!unix:unix-fstat (handler-descriptor handler)))
122         (setf (handler-bogus handler) t)
123         (push handler bogus-handlers)))
124     (when bogus-handlers
125       (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
126                            bogus-handlers (length bogus-handlers))
127         (remove-them ()
128           :report "Remove bogus handlers."
129           (with-descriptor-handlers
130             (setf *descriptor-handlers*
131                   (delete-if #'handler-bogus *descriptor-handlers*))))
132         (retry-them ()
133           :report "Retry bogus handlers."
134           (dolist (handler bogus-handlers)
135             (setf (handler-bogus handler) nil)))
136         (continue ()
137           :report "Go on, leaving handlers marked as bogus."))))
138   nil)
139
140 \f
141 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
142
143 ;;; When a *periodic-polling-function* is defined the server will not
144 ;;; block for more than the maximum event timeout and will call the
145 ;;; polling function if it does time out.
146 (declaim (type (or null symbol function) *periodic-polling-function*))
147 (defvar *periodic-polling-function* nil
148   "Either NIL, or a designator for a function callable without any
149 arguments. Called when the system has been waiting for input for
150 longer then *PERIODIC-POLLING-PERIOD* seconds. Shared between all
151 threads, unless locally bound. EXPERIMENTAL.")
152 (declaim (real *periodic-polling-period*))
153 (defvar *periodic-polling-period* 0
154   "A real number designating the number of seconds to wait for input
155 at maximum, before calling the *PERIODIC-POLLING-FUNCTION* \(if any.)
156 Shared between all threads, unless locally bound. EXPERIMENTAL.")
157
158 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
159 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
160 ;;; timeout at the correct time irrespective of how many events are handled in
161 ;;; the meantime.
162 (defun wait-until-fd-usable (fd direction &optional timeout (serve-events t))
163   #!+sb-doc
164   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
165 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
166 up. Returns true once the FD is usable, NIL return indicates timeout.
167
168 If SERVE-EVENTS is true (the default), events on other FDs are served while
169 waiting."
170   (tagbody
171    :restart
172      (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
173          (decode-timeout timeout)
174        (declare (type (or integer null) to-sec to-usec))
175        (flet ((maybe-update-timeout ()
176                 ;; If we return early, recompute the timeouts, possibly
177                 ;; signaling the deadline or returning with NIL to caller.
178                 (multiple-value-bind (sec usec)
179                     (decode-internal-time (get-internal-real-time))
180                   (setf to-sec (- stop-sec sec))
181                   (cond ((> usec stop-usec)
182                          (decf to-sec)
183                          (setf to-usec (- (+ stop-usec 1000000) usec)))
184                         (t
185                          (setf to-usec (- stop-usec usec)))))
186                 (when (or (minusp to-sec) (and (zerop to-sec) (not (plusp to-usec))))
187                   (cond (signalp
188                          (signal-deadline)
189                          (go :restart))
190                         (t
191                          (return-from wait-until-fd-usable nil))))))
192          (if (and serve-events
193                   ;; No timeout or non-zero timeout
194                   (or (not to-sec)
195                       (not (= 0 to-sec to-usec)))
196                   ;; Something to do while we wait
197                   (or *descriptor-handlers* *periodic-polling-function*))
198              ;; Loop around SUB-SERVE-EVENT till done.
199              (dx-let ((usable (list nil)))
200                (dx-flet ((usable! (fd)
201                                   (declare (ignore fd))
202                                   (setf (car usable) t)))
203                  (with-fd-handler (fd direction #'usable!)
204                    (loop
205                      (sub-serve-event to-sec to-usec signalp)
206                      (when (car usable)
207                        (return-from wait-until-fd-usable t))
208                      (when to-sec
209                        (maybe-update-timeout))))))
210              ;; If we don't have to serve events, just poll on the single FD instead.
211              (loop for to-msec = (if (and to-sec to-usec)
212                                      (+ (* 1000 to-sec) (truncate to-usec 1000))
213                                      -1)
214                    when (or #!+win32 (eq direction :output)
215                             (sb!unix:unix-simple-poll fd direction to-msec))
216                    do (return-from wait-until-fd-usable t)
217                    else
218                    do (when to-sec (maybe-update-timeout))))))))
219 \f
220 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
221 ;;; pending events are processed before returning.
222 (defun serve-all-events (&optional timeout)
223   #!+sb-doc
224   "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
225 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
226 timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
227 T if SERVE-EVENT did something and NIL if not."
228   (do ((res nil)
229        (sval (serve-event timeout) (serve-event 0)))
230       ((null sval) res)
231     (setq res t)))
232
233 ;;; Serve a single set of events.
234 (defun serve-event (&optional timeout)
235   #!+sb-doc
236   "Receive pending events on all FD-STREAMS and dispatch to the appropriate
237 handler functions. If timeout is specified, server will wait the specified
238 time (in seconds) and then return, otherwise it will wait until something
239 happens. Server returns T if something happened and NIL otherwise. Timeout
240 0 means polling without waiting."
241   (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
242       (decode-timeout timeout)
243     (declare (ignore stop-sec stop-usec))
244     (sub-serve-event to-sec to-usec signalp)))
245
246 ;;; Takes timeout broken into seconds and microseconds, NIL timeout means
247 ;;; to wait as long as needed.
248 (defun sub-serve-event (to-sec to-usec deadlinep)
249   (or
250    (if *periodic-polling-function*
251        (multiple-value-bind (p-sec p-usec)
252            (decode-internal-time
253             (seconds-to-internal-time *periodic-polling-period*))
254          (if to-sec
255              (loop repeat (/ (+ to-sec (/ to-usec 1e6))
256                              *periodic-polling-period*)
257                    thereis (sub-sub-serve-event p-sec p-usec)
258                    do (funcall *periodic-polling-function*))
259              (loop thereis (sub-sub-serve-event p-sec p-usec)
260                    do (funcall *periodic-polling-function*))))
261        (sub-sub-serve-event to-sec to-usec))
262    (when deadlinep
263      (signal-deadline))))
264
265 ;;; Handles the work of the above, except for periodic polling. Returns
266 ;;; true if something of interest happened.
267 (defun sub-sub-serve-event (to-sec to-usec)
268   (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
269                         (write-fds (sb!alien:struct sb!unix:fd-set)))
270     (sb!unix:fd-zero read-fds)
271     (sb!unix:fd-zero write-fds)
272     (let ((count 0))
273       (declare (type index count))
274
275       ;; Initialize the fd-sets for UNIX-SELECT and return the active
276       ;; descriptor count.
277       (map-descriptor-handlers
278        (lambda (handler)
279          ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
280          ;; to be checked here in addition to HANDLER-BOGUS
281          (unless (handler-bogus handler)
282            (let ((fd (handler-descriptor handler)))
283              (ecase (handler-direction handler)
284                (:input (sb!unix:fd-set fd read-fds))
285                (:output (sb!unix:fd-set fd write-fds)))
286              (when (> fd count)
287                (setf count fd))))))
288       (incf count)
289
290       ;; Next, wait for something to happen.
291       (multiple-value-bind (value err)
292           (sb!unix:unix-fast-select count
293                                     (sb!alien:addr read-fds)
294                                     (sb!alien:addr write-fds)
295                                     nil to-sec to-usec)
296         #!+win32
297         (declare (ignore err))
298         ;; Now see what it was (if anything)
299         (cond ((not value)
300                ;; Interrupted or one of the file descriptors is bad.
301                ;; FIXME: Check for other errnos. Why do we return true
302                ;; when interrupted?
303                #!-win32
304                (case err
305                  (#.sb!unix:ebadf
306                   (handler-descriptors-error))
307                  ((#.sb!unix:eintr #.sb!unix:eagain)
308                   t)
309                  (otherwise
310                   (with-simple-restart (continue "Ignore failure and continue.")
311                     (simple-perror "Unix system call select() failed"
312                                    :errno err))))
313                #!+win32
314                (handler-descriptors-error))
315               ((plusp value)
316                ;; Got something. Call file descriptor handlers
317                ;; according to the readable and writable masks
318                ;; returned by select.
319                (dolist (handler
320                         (select-descriptor-handlers
321                          (lambda (handler)
322                            (let ((fd (handler-descriptor handler)))
323                              (ecase (handler-direction handler)
324                                (:input (sb!unix:fd-isset fd read-fds))
325                                (:output (sb!unix:fd-isset fd write-fds)))))))
326                  (with-simple-restart (remove-fd-handler "Remove ~S" handler)
327                    (funcall (handler-function handler)
328                             (handler-descriptor handler))
329                    (go :next))
330                  (remove-fd-handler handler)
331                  :next)
332                t))))))
333