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   (let ((handler (make-handler direction fd function)))
  76     (with-descriptor-handlers
  77       (push handler *descriptor-handlers*))
  78     handler))
  79
  80 ;;; Remove an old handler from *descriptor-handlers*.
  81 (defun remove-fd-handler (handler)
  82   #!+sb-doc
  83   "Removes HANDLER from the list of active handlers."
  84   (with-descriptor-handlers
  85     (setf *descriptor-handlers*
  86           (delete handler *descriptor-handlers*))))
  87
  88 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
  89 (defun invalidate-descriptor (fd)
  90   #!+sb-doc
  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))))
  97
  98 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
  99 (defmacro with-fd-handler ((fd direction function) &rest body)
 100   #!+sb-doc
 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)))
 105     `(let (,handler)
 106        (unwind-protect
 107            (progn
 108              (setf ,handler (add-fd-handler ,fd ,direction ,function))
 109              ,@body)
 110          (when ,handler
 111            (remove-fd-handler ,handler))))))
 112
 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     (when bogus-handlers
 123       (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
 124                            bogus-handlers (length bogus-handlers))
 125         (remove-them ()
 126           :report "Remove bogus handlers."
 127           (with-descriptor-handlers
 128             (setf *descriptor-handlers*
 129                   (delete-if #'handler-bogus *descriptor-handlers*))))
 130         (retry-them ()
 131           :report "Retry bogus handlers."
 132           (dolist (handler bogus-handlers)
 133             (setf (handler-bogus handler) nil)))
 134         (continue ()
 135           :report "Go on, leaving handlers marked as bogus."))))
 136   nil)
 137
 138 \f
 139 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
 140
 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
 144 ;;; the meantime.
 145 (defun wait-until-fd-usable (fd direction &optional timeout)
 146   #!+sb-doc
 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
 149 up."
 150   (prog (usable)
 151    :restart
 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))
 157                                         (setf usable t)))
 158          (loop
 159            (sub-serve-event to-sec to-usec signalp)
 160            (when usable
 161              (return-from wait-until-fd-usable t))
 162            (when to-sec
 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)
 167                       (decf to-sec)
 168                       (setf to-usec (- (+ stop-usec 1000000) usec)))
 169                      (t
 170                       (setf to-usec (- stop-usec usec)))))
 171              (when (or (minusp to-sec) (minusp to-usec))
 172                (if signalp
 173                    (progn
 174                      (signal-deadline)
 175                      (go :restart))
 176                    (return-from wait-until-fd-usable nil)))))))))
 177 \f
 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)
 181   #!+sb-doc
 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."
 186   (do ((res nil)
 187        (sval (serve-event timeout) (serve-event 0)))
 188       ((null sval) res)
 189     (setq res t)))
 190
 191 ;;; Serve a single set of events.
 192 (defun serve-event (&optional timeout)
 193   #!+sb-doc
 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)))
 203
 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.")
 218
 219 ;;; Takes timeout broken into seconds and microseconds, NIL timeout means
 220 ;;; to wait as long as needed.
 221 (defun sub-serve-event (to-sec to-usec deadlinep)
 222   (or
 223    (if *periodic-polling-function*
 224        (multiple-value-bind (p-sec p-usec)
 225            (decode-internal-time
 226             (seconds-to-internal-time *periodic-polling-period*))
 227          (if to-sec
 228              (loop repeat (/ (+ to-sec (/ to-usec 1e6))
 229                              *periodic-polling-period*)
 230                    thereis (sub-sub-serve-event p-sec p-usec)
 231                    do (funcall *periodic-polling-function*))
 232              (loop thereis (sub-sub-serve-event p-sec p-usec)
 233                    do (funcall *periodic-polling-function*))))
 234        (sub-sub-serve-event to-sec to-usec))
 235    (when deadlinep
 236      (signal-deadline))))
 237
 238 ;;; Handles the work of the above, except for periodic polling. Returns
 239 ;;; true if something of interest happened.
 240 (defun sub-sub-serve-event (to-sec to-usec)
 241   (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
 242                         (write-fds (sb!alien:struct sb!unix:fd-set)))
 243     (sb!unix:fd-zero read-fds)
 244     (sb!unix:fd-zero write-fds)
 245     (let ((count 0))
 246       (declare (type index count))
 247
 248       ;; Initialize the fd-sets for UNIX-SELECT and return the active
 249       ;; descriptor count.
 250       (map-descriptor-handlers
 251        (lambda (handler)
 252          ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
 253          ;; to be checked here in addition to HANDLER-BOGUS
 254          (unless (handler-bogus handler)
 255            (let ((fd (handler-descriptor handler)))
 256              (ecase (handler-direction handler)
 257                (:input (sb!unix:fd-set fd read-fds))
 258                (:output (sb!unix:fd-set fd write-fds)))
 259              (when (> fd count)
 260                (setf count fd))))))
 261       (incf count)
 262
 263       ;; Next, wait for something to happen.
 264       (multiple-value-bind (value err)
 265           (sb!unix:unix-fast-select count
 266                                     (sb!alien:addr read-fds)
 267                                     (sb!alien:addr write-fds)
 268                                     nil to-sec to-usec)
 269         #!+win32
 270         (declare (ignore err))
 271         ;; Now see what it was (if anything)
 272         (cond ((not value)
 273                ;; Interrupted or one of the file descriptors is bad.
 274                ;; FIXME: Check for other errnos. Why do we return true
 275                ;; when interrupted?
 276                #!-win32
 277                (case err
 278                  (#.sb!unix:ebadf
 279                   (handler-descriptors-error))
 280                  (#.sb!unix:eintr
 281                   t)
 282                  (otherwise
 283                   (with-simple-restart (continue "Ignore failure and continue.")
 284                     (simple-perror "Unix system call select() failed" :errno err))))
 285                #!+win32
 286                (handler-descriptors-error))
 287               ((plusp value)
 288                ;; Got something. Call file descriptor handlers
 289                ;; according to the readable and writable masks
 290                ;; returned by select.
 291                (dolist (handler
 292                         (select-descriptor-handlers
 293                          (lambda (handler)
 294                            (let ((fd (handler-descriptor handler)))
 295                              (ecase (handler-direction handler)
 296                                (:input (sb!unix:fd-isset fd read-fds))
 297                                (:output (sb!unix:fd-isset fd write-fds)))))))
 298                  (funcall (handler-function handler)
 299                           (handler-descriptor handler)))
 300                t))))))
 301