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 (defvar *descriptor-handler-lock*
  46   (sb!thread::make-spinlock :name "descriptor handle lock"))
  47
  48 (sb!xc:defmacro with-descriptor-handlers (&body forms)
  49   ;; FD-STREAM functionality can add and remove descriptors on it's
  50   ;; own, and two threads adding add the same time could lose one.
  51   ;;
  52   ;; This is never held for long, so a spinlock is fine.
  53   `(without-interrupts
  54      (sb!thread::with-spinlock (*descriptor-handler-lock*)
  55        ,@forms)))
  56
  57 (defun list-all-descriptor-handlers ()
  58   (with-descriptor-handlers
  59     (copy-list *descriptor-handlers*)))
  60
  61 (defun select-descriptor-handlers (function)
  62   (declare (function function))
  63   (with-descriptor-handlers
  64     (remove-if-not function *descriptor-handlers*)))
  65
  66 (defun map-descriptor-handlers (function)
  67   (declare (function function))
  68   (with-descriptor-handlers
  69     (dolist (handler *descriptor-handlers*)
  70       (funcall function handler))))
  71
  72 ;;; Add a new handler to *descriptor-handlers*.
  73 (defun add-fd-handler (fd direction function)
  74   #!+sb-doc
  75   "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
  76   either :INPUT or :OUTPUT. The value returned should be passed to
  77   SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
  78   (unless (member direction '(:input :output))
  79     ;; FIXME: should be TYPE-ERROR?
  80     (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction))
  81   (let ((handler (make-handler direction fd function)))
  82     (with-descriptor-handlers
  83       (push handler *descriptor-handlers*))
  84     handler))
  85
  86 ;;; Remove an old handler from *descriptor-handlers*.
  87 (defun remove-fd-handler (handler)
  88   #!+sb-doc
  89   "Removes HANDLER from the list of active handlers."
  90   (with-descriptor-handlers
  91     (setf *descriptor-handlers*
  92           (delete handler *descriptor-handlers*))))
  93
  94 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
  95 (defun invalidate-descriptor (fd)
  96   #!+sb-doc
  97   "Remove any handers refering to fd. This should only be used when attempting
  98   to recover from a detected inconsistancy."
  99   (with-descriptor-handlers
 100     (setf *descriptor-handlers*
 101           (delete fd *descriptor-handlers*
 102                   :key #'handler-descriptor))))
 103
 104 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
 105 (defmacro with-fd-handler ((fd direction function) &rest body)
 106   #!+sb-doc
 107   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
 108    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
 109    use, and FUNCTION is the function to call whenever FD is usable."
 110   (let ((handler (gensym)))
 111     `(let (,handler)
 112        (unwind-protect
 113            (progn
 114              (setf ,handler (add-fd-handler ,fd ,direction ,function))
 115              ,@body)
 116          (when ,handler
 117            (remove-fd-handler ,handler))))))
 118
 119 ;;; First, get a list and mark bad file descriptors. Then signal an error
 120 ;;; offering a few restarts.
 121 (defun handler-descriptors-error ()
 122   (let ((bogus-handlers nil))
 123     (dolist (handler (list-all-descriptor-handlers))
 124       (unless (or (handler-bogus handler)
 125                   (sb!unix:unix-fstat (handler-descriptor handler)))
 126         (setf (handler-bogus handler) t)
 127         (push handler bogus-handlers)))
 128     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
 129                          bogus-handlers (length bogus-handlers))
 130       (remove-them ()
 131         :report "Remove bogus handlers."
 132         (with-descriptor-handlers
 133           (setf *descriptor-handlers*
 134                 (delete-if #'handler-bogus *descriptor-handlers*))))
 135       (retry-them ()
 136         :report "Retry bogus handlers."
 137        (dolist (handler bogus-handlers)
 138          (setf (handler-bogus handler) nil)))
 139       (continue ()
 140         :report "Go on, leaving handlers marked as bogus."))))
 141 \f
 142 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
 143
 144 ;;; Break a real timeout into seconds and microseconds.
 145 (defun decode-timeout (timeout)
 146   (declare (values (or index null) index))
 147   (typecase timeout
 148     (integer (values timeout 0))
 149     (null (values nil 0))
 150     (real
 151      (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
 152        (declare (type index q) (single-float r))
 153        (values q (the (values index t) (truncate (* r 1f6))))))
 154     (t
 155      (error "Timeout is not a real number or NIL: ~S" timeout))))
 156
 157 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
 158 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
 159 ;;; timeout at the correct time irrespective of how many events are handled in
 160 ;;; the meantime.
 161 (defun wait-until-fd-usable (fd direction &optional timeout)
 162   #!+sb-doc
 163   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
 164   :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
 165   up."
 166   (declare (type (or real null) timeout))
 167   (let (usable)
 168     (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
 169       (declare (type (or index null) to-sec to-usec))
 170       (multiple-value-bind (stop-sec stop-usec)
 171           (if to-sec
 172               (multiple-value-bind (okay start-sec start-usec)
 173                   (sb!unix:unix-gettimeofday)
 174                 (declare (ignore okay))
 175                 (let ((usec (+ to-usec start-usec))
 176                       (sec (+ to-sec start-sec)))
 177                   (declare (type (unsigned-byte 31) usec sec))
 178                   (if (>= usec 1000000)
 179                       (values (1+ sec) (- usec 1000000))
 180                       (values sec usec))))
 181               (values 0 0))
 182         (declare (type (unsigned-byte 31) stop-sec stop-usec))
 183         (with-fd-handler (fd direction (lambda (fd)
 184                                          (declare (ignore fd))
 185                                          (setf usable t)))
 186           (loop
 187             (sub-serve-event to-sec to-usec)
 188
 189             (when usable
 190               (return t))
 191
 192             (when timeout
 193               (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday)
 194                 (declare (ignore okay))
 195                 (when (or (> sec stop-sec)
 196                           (and (= sec stop-sec) (>= usec stop-usec)))
 197                   (return nil))
 198                 (setq to-sec (- stop-sec sec))
 199                 (cond ((> usec stop-usec)
 200                        (decf to-sec)
 201                        (setq to-usec (- (+ stop-usec 1000000) usec)))
 202                       (t
 203                        (setq to-usec (- stop-usec usec))))))))))))
 204 \f
 205 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 206 ;;; pending events are processed before returning.
 207 (defun serve-all-events (&optional timeout)
 208   #!+sb-doc
 209   "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
 210   SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
 211   0 until all events have been served. SERVE-ALL-EVENTS returns T if
 212   SERVE-EVENT did something and NIL if not."
 213   (do ((res nil)
 214        (sval (serve-event timeout) (serve-event 0)))
 215       ((null sval) res)
 216     (setq res t)))
 217
 218 ;;; Serve a single event.
 219 (defun serve-event (&optional timeout)
 220   #!+sb-doc
 221   "Receive on all ports and Xevents and dispatch to the appropriate handler
 222   function. If timeout is specified, server will wait the specified time (in
 223   seconds) and then return, otherwise it will wait until something happens.
 224   Server returns T if something happened and NIL otherwise."
 225   (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
 226     (sub-serve-event to-sec to-usec)))
 227
 228 ;;; When a *periodic-polling-function* is defined the server will not
 229 ;;; block for more than the maximum event timeout and will call the
 230 ;;; polling function if it does time out.
 231 (declaim (type (or null function) *periodic-polling-function*))
 232 (defvar *periodic-polling-function* nil)
 233 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
 234 (defvar *max-event-to-sec* 1)
 235 (defvar *max-event-to-usec* 0)
 236
 237 ;;; Takes timeout broken into seconds and microseconds.
 238 (defun sub-serve-event (to-sec to-usec)
 239   (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
 240
 241   (let ((call-polling-fn nil))
 242     (when (and *periodic-polling-function*
 243                ;; Enforce a maximum timeout.
 244                (or (null to-sec)
 245                    (> to-sec *max-event-to-sec*)
 246                    (and (= to-sec *max-event-to-sec*)
 247                         (> to-usec *max-event-to-usec*))))
 248       (setf to-sec *max-event-to-sec*)
 249       (setf to-usec *max-event-to-usec*)
 250       (setf call-polling-fn t))
 251
 252     ;; Next, wait for something to happen.
 253     (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
 254                           (write-fds (sb!alien:struct sb!unix:fd-set)))
 255       (sb!unix:fd-zero read-fds)
 256       (sb!unix:fd-zero write-fds)
 257       (let ((count 0))
 258         (declare (type index count))
 259
 260         ;; Initialize the fd-sets for UNIX-SELECT and return the active
 261         ;; descriptor count.
 262         (map-descriptor-handlers
 263          (lambda (handler)
 264            ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
 265            ;; to be checked here in addition to HANDLER-BOGUS
 266            (unless (handler-bogus handler)
 267              (let ((fd (handler-descriptor handler)))
 268                (ecase (handler-direction handler)
 269                  (:input (sb!unix:fd-set fd read-fds))
 270                  (:output (sb!unix:fd-set fd write-fds)))
 271                (when (> fd count)
 272                  (setf count fd))))))
 273         (incf count)
 274
 275         (multiple-value-bind (value err)
 276             (sb!unix:unix-fast-select count
 277                                       (sb!alien:addr read-fds)
 278                                       (sb!alien:addr write-fds)
 279                                       nil to-sec to-usec)
 280           #!+win32 (declare (ignorable err))
 281           (cond ((eql 0 value)
 282                  ;; Timed out.
 283                  (when call-polling-fn
 284                    (funcall *periodic-polling-function*)))
 285                 (value
 286                  ;; Call file descriptor handlers according to the
 287                  ;; readable and writable masks returned by select.
 288                  (dolist (handler
 289                            (select-descriptor-handlers
 290                             (lambda (handler)
 291                               (let ((fd (handler-descriptor handler)))
 292                                 (ecase (handler-direction handler)
 293                                   (:input (sb!unix:fd-isset fd read-fds))
 294                                   (:output (sb!unix:fd-isset fd write-fds)))))))
 295                    (funcall (handler-function handler)
 296                             (handler-descriptor handler)))
 297                  t)
 298                 ((eql err sb!unix:eintr)
 299                  ;; We did an interrupt.
 300                  ;;
 301                  ;; FIXME: Why T here?
 302                  t)
 303                 (t
 304                  ;; One of the file descriptors is bad.
 305                  (handler-descriptors-error)
 306                  nil)))))))
 307