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-comment
  13   "$Header$")
  14 \f
  15 #|
  16 ;;;; object set stuff
  17
  18 ;;; a hashtable from ports to objects. Each entry is a cons (object . set).
  19 ;(defvar *port-table* (make-hash-table :test 'eql))
  20
  21 (defstruct (object-set
  22             (:constructor make-object-set
  23                           (name &optional
  24                                 (default-handler #'default-default-handler)))
  25             (:print-object
  26              (lambda (s stream)
  27                (format stream "#<Object Set ~S>" (object-set-name s)))))
  28   name                                  ; Name, for descriptive purposes.
  29   (table (make-hash-table :test 'eq))   ; Message-ID or
  30                                         ;   xevent-type --> handler fun.
  31   default-handler)
  32
  33 #!+sb-doc
  34 (setf (fdocumentation 'make-object-set 'function)
  35       "Make an object set for use by a RPC/xevent server. Name is for
  36       descriptive purposes only.")
  37
  38 ;;; If no such operation defined, signal an error.
  39 (defun default-default-handler (object)
  40   (error "You lose, object: ~S" object))
  41
  42 ;;; Look up the handler function for a given message ID.
  43 (defun object-set-operation (object-set message-id)
  44   #!+sb-doc
  45   "Return the handler function in Object-Set for the operation specified by
  46    Message-ID, if none, NIL is returned."
  47   (check-type object-set object-set)
  48   (check-type message-id fixnum)
  49   (values (gethash message-id (object-set-table object-set))))
  50
  51 ;;; The setf inverse for Object-Set-Operation.
  52 (defun %set-object-set-operation (object-set message-id new-value)
  53   (check-type object-set object-set)
  54   (check-type message-id fixnum)
  55   (setf (gethash message-id (object-set-table object-set)) new-value))
  56
  57 |#
  58 \f
  59 ;;;; file descriptor I/O noise
  60
  61 (defstruct (handler
  62             (:constructor make-handler (direction descriptor function)))
  63   ;; Reading or writing...
  64   (direction nil :type (member :input :output))
  65   ;; File descriptor this handler is tied to.
  66   (descriptor 0 :type (mod #.sb!unix:fd-setsize))
  67
  68   active                      ; T iff this handler is running.
  69   (function nil :type function) ; Function to call.
  70   bogus)                      ; T if this descriptor is bogus.
  71 (def!method print-object ((handler handler) stream)
  72   (print-unreadable-object (handler stream :type t)
  73     (format stream
  74             "~A on ~:[~;BOGUS ~]descriptor ~D: ~S"
  75             (handler-direction handler)
  76             (handler-bogus handler)
  77             (handler-descriptor handler)
  78             (handler-function handler))))
  79
  80 (defvar *descriptor-handlers* nil
  81   #!+sb-doc
  82   "List of all the currently active handlers for file descriptors")
  83
  84 ;;; Add a new handler to *descriptor-handlers*.
  85 (defun add-fd-handler (fd direction function)
  86   #!+sb-doc
  87   "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
  88   either :INPUT or :OUTPUT. The value returned should be passed to
  89   SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
  90   (assert (member direction '(:input :output))
  91           (direction)
  92           "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
  93   (let ((handler (make-handler direction fd function)))
  94     (push handler *descriptor-handlers*)
  95     handler))
  96
  97 ;;; Remove an old handler from *descriptor-handlers*.
  98 (defun remove-fd-handler (handler)
  99   #!+sb-doc
 100   "Removes HANDLER from the list of active handlers."
 101   (setf *descriptor-handlers*
 102         (delete handler *descriptor-handlers*
 103                 :test #'eq)))
 104
 105 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
 106 (defun invalidate-descriptor (fd)
 107   #!+sb-doc
 108   "Remove any handers refering to fd. This should only be used when attempting
 109   to recover from a detected inconsistancy."
 110   (setf *descriptor-handlers*
 111         (delete fd *descriptor-handlers*
 112                 :key #'handler-descriptor)))
 113
 114 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
 115 (defmacro with-fd-handler ((fd direction function) &rest body)
 116   #!+sb-doc
 117   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
 118    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
 119    use, and FUNCTION is the function to call whenever FD is usable."
 120   (let ((handler (gensym)))
 121     `(let (,handler)
 122        (unwind-protect
 123            (progn
 124              (setf ,handler (add-fd-handler ,fd ,direction ,function))
 125              ,@body)
 126          (when ,handler
 127            (remove-fd-handler ,handler))))))
 128
 129 ;;; First, get a list and mark bad file descriptors. Then signal an error
 130 ;;; offering a few restarts.
 131 (defun handler-descriptors-error ()
 132   (let ((bogus-handlers nil))
 133     (dolist (handler *descriptor-handlers*)
 134       (unless (or (handler-bogus handler)
 135                   (sb!unix:unix-fstat (handler-descriptor handler)))
 136         (setf (handler-bogus handler) t)
 137         (push handler bogus-handlers)))
 138     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
 139                          bogus-handlers (length bogus-handlers))
 140       (remove-them () :report "Remove bogus handlers."
 141        (setf *descriptor-handlers*
 142              (delete-if #'handler-bogus *descriptor-handlers*)))
 143       (retry-them () :report "Retry bogus handlers."
 144        (dolist (handler bogus-handlers)
 145          (setf (handler-bogus handler) nil)))
 146       (continue () :report "Go on, leaving handlers marked as bogus."))))
 147 \f
 148 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
 149
 150 ;;; Break a real timeout into seconds and microseconds.
 151 (defun decode-timeout (timeout)
 152   (declare (values (or index null) index))
 153   (typecase timeout
 154     (integer (values timeout 0))
 155     (null (values nil 0))
 156     (real
 157      (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
 158        (declare (type index q) (single-float r))
 159        (values q (the index (truncate (* r 1f6))))))
 160     (t
 161      (error "Timeout is not a real number or NIL: ~S" timeout))))
 162
 163 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
 164 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
 165 ;;; timeout at the correct time irrespective of how many events are handled in
 166 ;;; the meantime.
 167 (defun wait-until-fd-usable (fd direction &optional timeout)
 168   #!+sb-doc
 169   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
 170   :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
 171   up."
 172   (declare (type (or real null) timeout))
 173   (let (usable)
 174     (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
 175       (declare (type (or index null) to-sec to-usec))
 176       (multiple-value-bind (stop-sec stop-usec)
 177           (if to-sec
 178               (multiple-value-bind (okay start-sec start-usec)
 179                   (sb!unix:unix-gettimeofday)
 180                 (declare (ignore okay))
 181                 (let ((usec (+ to-usec start-usec))
 182                       (sec (+ to-sec start-sec)))
 183                   (declare (type (unsigned-byte 31) usec sec))
 184                   (if (>= usec 1000000)
 185                       (values (1+ sec) (- usec 1000000))
 186                       (values sec usec))))
 187               (values 0 0))
 188         (declare (type (unsigned-byte 31) stop-sec stop-usec))
 189         (with-fd-handler (fd direction #'(lambda (fd)
 190                                            (declare (ignore fd))
 191                                            (setf usable t)))
 192           (loop
 193             (sub-serve-event to-sec to-usec)
 194
 195             (when usable
 196               (return t))
 197
 198             (when timeout
 199               (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday)
 200                 (declare (ignore okay))
 201                 (when (or (> sec stop-sec)
 202                           (and (= sec stop-sec) (>= usec stop-usec)))
 203                   (return nil))
 204                 (setq to-sec (- stop-sec sec))
 205                 (cond ((> usec stop-usec)
 206                        (decf to-sec)
 207                        (setq to-usec (- (+ stop-usec 1000000) usec)))
 208                       (t
 209                        (setq to-usec (- stop-usec usec))))))))))))
 210 \f
 211 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 212 ;;; pending events are processed before returning.
 213 (defun serve-all-events (&optional timeout)
 214   #!+sb-doc
 215   "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
 216   SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
 217   0 until all events have been served. SERVE-ALL-EVENTS returns T if
 218   SERVE-EVENT did something and NIL if not."
 219   (do ((res nil)
 220        (sval (serve-event timeout) (serve-event 0)))
 221       ((null sval) res)
 222     (setq res t)))
 223
 224 ;;; Serve a single event.
 225 (defun serve-event (&optional timeout)
 226   #!+sb-doc
 227   "Receive on all ports and Xevents and dispatch to the appropriate handler
 228   function. If timeout is specified, server will wait the specified time (in
 229   seconds) and then return, otherwise it will wait until something happens.
 230   Server returns T if something happened and NIL otherwise."
 231   (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
 232     (sub-serve-event to-sec to-usec)))
 233
 234 ;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
 235 ;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
 236 ;;; if passed as function arguments.)
 237 (eval-when (:compile-toplevel :execute)
 238
 239 ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
 240 ;;; count.
 241 (sb!xc:defmacro calc-masks ()
 242   '(progn
 243      (sb!unix:fd-zero read-fds)
 244      (sb!unix:fd-zero write-fds)
 245      (let ((count 0))
 246        (declare (type index count))
 247        (dolist (handler *descriptor-handlers*)
 248          (unless (or (handler-active handler)
 249                      (handler-bogus handler))
 250            (let ((fd (handler-descriptor handler)))
 251              (ecase (handler-direction handler)
 252                (:input (sb!unix:fd-set fd read-fds))
 253                (:output (sb!unix:fd-set fd write-fds)))
 254              (when (> fd count)
 255                (setf count fd)))))
 256        (1+ count))))
 257
 258 ;;; Call file descriptor handlers according to the readable and writable masks
 259 ;;; returned by select.
 260 (sb!xc:defmacro call-fd-handler ()
 261   '(let ((result nil))
 262      (dolist (handler *descriptor-handlers*)
 263        (let ((desc (handler-descriptor handler)))
 264          (when (ecase (handler-direction handler)
 265                  (:input (sb!unix:fd-isset desc read-fds))
 266                  (:output (sb!unix:fd-isset desc write-fds)))
 267            (unwind-protect
 268                (progn
 269                  ;; Doesn't work -- ACK
 270                  ;(setf (handler-active handler) t)
 271                  (funcall (handler-function handler) desc))
 272              (setf (handler-active handler) nil))
 273            (ecase (handler-direction handler)
 274              (:input (sb!unix:fd-clr desc read-fds))
 275              (:output (sb!unix:fd-clr desc write-fds)))
 276            (setf result t)))
 277        result)))
 278
 279 ) ; EVAL-WHEN
 280
 281 ;;; When a *periodic-polling-function* is defined the server will not
 282 ;;; block for more than the maximum event timeout and will call the
 283 ;;; polling function if it does time out. One important use of this
 284 ;;; is to periodically call process-yield.
 285 (declaim (type (or null function) *periodic-polling-function*))
 286 (defvar *periodic-polling-function*
 287   #!-mp nil #!+mp #'sb!mp:process-yield)
 288 (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
 289 (defvar *max-event-to-sec* 1)
 290 (defvar *max-event-to-usec* 0)
 291
 292 ;;; Takes timeout broken into seconds and microseconds.
 293 (defun sub-serve-event (to-sec to-usec)
 294   (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
 295
 296   (let ((call-polling-fn nil))
 297     (when (and *periodic-polling-function*
 298                ;; Enforce a maximum timeout.
 299                (or (null to-sec)
 300                    (> to-sec *max-event-to-sec*)
 301                    (and (= to-sec *max-event-to-sec*)
 302                         (> to-usec *max-event-to-usec*))))
 303       (setf to-sec *max-event-to-sec*)
 304       (setf to-usec *max-event-to-usec*)
 305       (setf call-polling-fn t))
 306
 307     ;; Next, wait for something to happen.
 308     (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
 309                           (write-fds (sb!alien:struct sb!unix:fd-set)))
 310       (let ((count (calc-masks)))
 311         (multiple-value-bind (value err) (sb!unix:unix-fast-select
 312              count
 313              (sb!alien:addr read-fds) (sb!alien:addr write-fds)
 314              nil to-sec to-usec)
 315
 316           ;; Now see what it was (if anything)
 317           (cond (value
 318                  (cond ((zerop value)
 319                         ;; Timed out.
 320                         (when call-polling-fn
 321                           (funcall *periodic-polling-function*)))
 322                        (t
 323                         (call-fd-handler))))
 324                 ((eql err sb!unix:eintr)
 325                  ;; We did an interrupt.
 326                  t)
 327                 (t
 328                  ;; One of the file descriptors is bad.
 329                  (handler-descriptors-error)
 330                  nil)))))))