src/multiplex/event-loop.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Main event loop.
   4 ;;;
   5
   6 (in-package :iolib/multiplex)
   7
   8
   9 ;;;-------------------------------------------------------------------------
  10 ;;; Classes and Types
  11 ;;;-------------------------------------------------------------------------
  12
  13 (defclass event-base ()
  14   ((mux :reader mux-of)
  15    (fds :initform (make-hash-table :test 'eql)
  16         :reader fds-of)
  17    (timers :initform (make-priority-queue :key #'%timer-expire-time)
  18            :reader timers-of)
  19    (fd-timers :initform (make-priority-queue :key #'%timer-expire-time)
  20               :reader fd-timers-of)
  21    (expired-events :initform nil
  22                    :accessor expired-events-of)
  23    (write-interval-threshold :initarg :write-interval-threshold
  24                              :accessor write-interval-threshold-of)
  25    (exit :initform nil
  26          :accessor exit-p)
  27    (exit-when-empty :initarg :exit-when-empty
  28                     :accessor exit-when-empty-p))
  29   (:default-initargs :mux *default-multiplexer*
  30                      :write-interval-threshold 0.0d0
  31                      :exit-when-empty nil))
  32 \f
  33
  34 ;;;-------------------------------------------------------------------------
  35 ;;; PRINT-OBJECT
  36 ;;;-------------------------------------------------------------------------
  37
  38 (defmethod print-object ((base event-base) stream)
  39   (print-unreadable-object (base stream :type nil :identity t)
  40     (if (fds-of base)
  41         (format stream "event base, ~A FDs monitored, using: ~A"
  42                 (hash-table-count (fds-of base)) (mux-of base))
  43         (format stream "event base, closed"))))
  44 \f
  45
  46 ;;;-------------------------------------------------------------------------
  47 ;;; Generic functions
  48 ;;;-------------------------------------------------------------------------
  49
  50 (defgeneric set-io-handler (event-base fd event-type function &key timeout one-shot))
  51
  52 (defgeneric set-error-handler (event-base fd function))
  53
  54 (defgeneric add-timer (event-base function timeout &key one-shot))
  55
  56 (defgeneric remove-fd-handlers (event-base fd &key read write error)
  57   (:documentation "Removes FD handlers for the given event types.
  58 If READ, WRITE and ERROR are all NIL (the default), then all are removed.
  59 Returns T if some handlers were removed, NIL otherwise."))
  60
  61 (defgeneric remove-timer (event-base timer))
  62
  63 (defgeneric event-dispatch (event-base &key one-shot timeout min-step max-step))
  64
  65 (defgeneric exit-event-loop (event-base &key delay))
  66
  67 (defgeneric event-base-empty-p (event-base))
  68 \f
  69
  70 ;;;-------------------------------------------------------------------------
  71 ;;; Constructors
  72 ;;;-------------------------------------------------------------------------
  73
  74 (defmethod initialize-instance :after
  75     ((base event-base) &key mux write-interval-threshold)
  76   (check-type write-interval-threshold non-negative-real)
  77   (setf (write-interval-threshold-of base)
  78         (float write-interval-threshold 1.0d0))
  79   (setf (slot-value base 'mux) (make-instance mux)))
  80 \f
  81
  82 ;;;-------------------------------------------------------------------------
  83 ;;; CLOSE
  84 ;;;-------------------------------------------------------------------------
  85
  86 ;;; KLUDGE: CLOSE is for streams. --luis
  87 ;;;
  88 ;;; Also, we might want to close FDs here.  Or have a version/argument
  89 ;;; that handles that.
  90 (defmethod close ((event-base event-base) &key abort)
  91   (declare (ignore abort))
  92   (close-multiplexer (mux-of event-base))
  93   (dolist (slot '(mux fds timers fd-timers expired-events))
  94     (setf (slot-value event-base slot) nil))
  95   (values event-base))
  96 \f
  97
  98 ;;;-------------------------------------------------------------------------
  99 ;;; Helper macros
 100 ;;;-------------------------------------------------------------------------
 101
 102 (defmacro with-event-base ((var &rest initargs) &body body)
 103   "Binds VAR to a new EVENT-BASE, instantiated with INITARGS,
 104 within the extent of BODY.  Closes VAR."
 105   `(let ((,var (make-instance 'event-base ,@initargs)))
 106      (unwind-protect
 107           (locally ,@body)
 108        (when ,var (close ,var)))))
 109 \f
 110
 111 ;;;-------------------------------------------------------------------------
 112 ;;; Utilities
 113 ;;;-------------------------------------------------------------------------
 114
 115 (defun fd-entry-of (event-base fd)
 116   (gethash fd (fds-of event-base)))
 117
 118 (defun (setf fd-entry-of) (fd-entry event-base fd)
 119   (setf (gethash fd (fds-of event-base)) fd-entry))
 120
 121 (defmethod exit-event-loop ((event-base event-base) &key (delay 0))
 122   (add-timer event-base
 123              (lambda () (setf (exit-p event-base) t))
 124              delay :one-shot t))
 125
 126 (defmethod event-base-empty-p ((event-base event-base))
 127   (and (zerop (hash-table-count (fds-of event-base)))
 128        (priority-queue-empty-p (timers-of event-base))))
 129 \f
 130
 131 ;;;-------------------------------------------------------------------------
 132 ;;; SET-IO-HANDLER
 133 ;;;-------------------------------------------------------------------------
 134
 135 (defmethod set-io-handler :before
 136     ((event-base event-base) fd event-type function &key timeout one-shot)
 137   (declare (ignore timeout))
 138   (check-type fd unsigned-byte)
 139   (check-type event-type fd-event-type)
 140   (check-type function function-designator)
 141   ;; FIXME: check the type of the timeout
 142   (check-type one-shot boolean)
 143   (when (fd-monitored-p event-base fd event-type)
 144     (error "FD ~A is already monitored for event ~A" fd event-type)))
 145
 146 (defun fd-monitored-p (event-base fd event-type)
 147   "Generalised predicate returning the event handler if the given FD
 148 is monitored for EVENT-TYPE."
 149   (let ((entry (fd-entry-of event-base fd)))
 150     (and entry (fd-entry-handler entry event-type))))
 151
 152 (defmethod set-io-handler
 153     ((event-base event-base) fd event-type function &key timeout one-shot)
 154   (let ((current-fd-entry (fd-entry-of event-base fd))
 155         (event (make-fd-handler fd event-type function one-shot)))
 156     (cond
 157       (current-fd-entry
 158        (%set-io-handler event-base fd event current-fd-entry timeout)
 159        (update-fd (mux-of event-base) current-fd-entry event-type :add))
 160       (t
 161        (let ((new-fd-entry (make-fd-entry fd)))
 162          (%set-io-handler event-base fd event new-fd-entry timeout)
 163          (monitor-fd (mux-of event-base) new-fd-entry))))
 164     (values event)))
 165
 166 (defun %set-io-handler (event-base fd event fd-entry timeout)
 167   (when timeout
 168     (%set-io-handler-timer event-base event timeout))
 169   (setf (fd-entry-handler fd-entry (fd-handler-type event)) event)
 170   (setf (fd-entry-of event-base fd) fd-entry)
 171   (values event))
 172
 173 (defun %set-io-handler-timer (event-base event timeout)
 174   (let ((timer (make-timer (lambda () (expire-event event-base event))
 175                            timeout)))
 176     (setf (fd-handler-timer event) timer)
 177     (schedule-timer (fd-timers-of event-base) timer)))
 178
 179 (defun expire-event (event-base event)
 180   (push event (expired-events-of event-base)))
 181 \f
 182
 183 ;;;-------------------------------------------------------------------------
 184 ;;; SET-ERROR-HANDLER
 185 ;;;-------------------------------------------------------------------------
 186
 187 (defmethod set-error-handler :before
 188     ((event-base event-base) fd function)
 189   (check-type fd unsigned-byte)
 190   (check-type function function-designator)
 191   (unless (fd-entry-of event-base fd)
 192     (error "FD ~A is not being monitored" fd))
 193   (when (fd-has-error-handler-p event-base fd)
 194     (error "FD ~A already has an error handler" fd)))
 195
 196 (defun fd-has-error-handler-p (event-base fd)
 197   (let ((entry (fd-entry-of event-base fd)))
 198     (and entry (fd-entry-error-callback entry))))
 199
 200 (defmethod set-error-handler
 201     ((event-base event-base) fd function)
 202   (let ((fd-entry (fd-entry-of event-base fd)))
 203     (setf (fd-entry-error-callback fd-entry) function)))
 204 \f
 205
 206 ;;;-------------------------------------------------------------------------
 207 ;;; ADD-TIMER
 208 ;;;-------------------------------------------------------------------------
 209
 210 (defmethod add-timer :before
 211     ((event-base event-base) function timeout &key one-shot)
 212   (declare (ignore timeout))
 213   (check-type function function-designator)
 214   ;; FIXME: check the type of the timeout
 215   (check-type one-shot boolean))
 216
 217 (defmethod add-timer
 218     ((event-base event-base) function timeout &key one-shot)
 219   (schedule-timer (timers-of event-base)
 220                   (make-timer function timeout :one-shot one-shot)))
 221 \f
 222
 223 ;;;-------------------------------------------------------------------------
 224 ;;; REMOVE-FD-HANDLERS and REMOVE-TIMER
 225 ;;;-------------------------------------------------------------------------
 226
 227 (defmethod remove-fd-handlers
 228     ((event-base event-base) fd &key read write error)
 229   (unless (or read write error)
 230     (setf read t write t error t))
 231   (let ((entry (fd-entry-of event-base fd)))
 232     (cond
 233       (entry
 234        (prog1
 235            (%remove-fd-handlers event-base fd entry read write error)
 236          (when (and read write)
 237            (assert (null (fd-entry-of event-base fd))))))
 238       (t nil))))
 239
 240 (defun %remove-fd-handlers (event-base fd entry read write error)
 241   (let ((rev (fd-entry-read-handler entry))
 242         (wev (fd-entry-write-handler entry))
 243         (eev (fd-entry-error-callback entry))
 244         (removed nil))
 245     (when (and rev read)
 246       (%remove-io-handler event-base fd entry rev)
 247       (setf removed t))
 248     (when (and wev write)
 249       (%remove-io-handler event-base fd entry wev)
 250       (setf removed t))
 251     (when (and eev error)
 252       (setf (fd-entry-error-callback entry) nil)
 253       (setf removed t))
 254     removed))
 255
 256 (defun %remove-io-handler (event-base fd fd-entry event)
 257   (let ((event-type (fd-handler-type event)))
 258     (setf (fd-entry-handler fd-entry event-type) nil)
 259     (when-let (timer (fd-handler-timer event))
 260       (unschedule-timer (fd-timers-of event-base) timer))
 261     (cond
 262       ((fd-entry-empty-p fd-entry)
 263        (%remove-fd-entry event-base fd)
 264        (unmonitor-fd (mux-of event-base) fd-entry))
 265       (t
 266        (update-fd (mux-of event-base) fd-entry event-type :del)))))
 267
 268 (defun %remove-fd-entry (event-base fd)
 269   (remhash fd (fds-of event-base)))
 270
 271 (defmethod remove-timer :before
 272     ((event-base event-base) timer)
 273   (check-type timer timer))
 274
 275 (defmethod remove-timer ((event-base event-base) timer)
 276   (unschedule-timer (timers-of event-base) timer)
 277   (values event-base))
 278 \f
 279
 280 ;;;-------------------------------------------------------------------------
 281 ;;; EVENT-DISPATCH
 282 ;;;-------------------------------------------------------------------------
 283
 284 (defvar *minimum-event-loop-step* 0.0d0)
 285 (defvar *maximum-event-loop-step* nil)
 286
 287 (defmethod event-dispatch :around
 288     ((event-base event-base) &key timeout one-shot min-step max-step)
 289   (declare (ignore one-shot min-step max-step))
 290   (setf (exit-p event-base) nil)
 291   (let ((timer (when timeout
 292                  (exit-event-loop event-base :delay timeout))))
 293     (unwind-protect
 294          (call-next-method)
 295       (when timer
 296         (remove-timer event-base timer)))))
 297
 298 (defmethod event-dispatch ((event-base event-base) &key one-shot timeout
 299                            (min-step *minimum-event-loop-step*)
 300                            (max-step *maximum-event-loop-step*))
 301   (declare (ignore timeout))
 302   (coercef min-step 'double-float)
 303   (when max-step (coercef max-step 'double-float))
 304   (with-accessors ((mux mux-of) (fds fds-of) (exit-p exit-p)
 305                    (exit-when-empty exit-when-empty-p)
 306                    (timers timers-of) (fd-timers fd-timers-of)
 307                    (expired-events expired-events-of))
 308       event-base
 309     (labels ((poll-timeout (now)
 310                (let* ((deadline1 (time-to-next-timer timers))
 311                       (deadline2 (time-to-next-timer fd-timers))
 312                       (deadline (if (and deadline1 deadline2)
 313                                     (min deadline1 deadline2)
 314                                     (or deadline1 deadline2))))
 315                  (if deadline
 316                      (clamp-timeout (- deadline now) min-step max-step)
 317                      max-step)))
 318              (must-exit-loop-p ()
 319                (or exit-p
 320                    (and exit-when-empty
 321                         (event-base-empty-p event-base)))))
 322       (loop :with deletion-list := ()
 323             :with eventsp := nil
 324             :for now := (isys:get-monotonic-time)
 325             :for poll-timeout := (poll-timeout now)
 326             :until (must-exit-loop-p) :do
 327         (setf expired-events nil)
 328         (setf (values eventsp deletion-list)
 329               (dispatch-fd-events-once event-base poll-timeout now))
 330         (%remove-handlers event-base (delete nil deletion-list))
 331         (when (expire-pending-timers fd-timers now) (setf eventsp t))
 332         (dispatch-fd-timeouts expired-events)
 333         (when (expire-pending-timers timers now) (setf eventsp t))
 334         (when (and eventsp one-shot) (setf exit-p t))))))
 335
 336 (defun %remove-handlers (event-base event-list)
 337   (loop :for ev :in event-list
 338         :for fd := (fd-handler-fd ev)
 339         :for fd-entry := (fd-entry-of event-base fd)
 340      :do (%remove-io-handler event-base fd fd-entry ev)))
 341
 342 ;;; Waits for events and dispatches them.  Returns T if some events
 343 ;;; have been received, NIL otherwise.
 344 (defun dispatch-fd-events-once (event-base timeout now)
 345   (let ((wthreshold (write-interval-threshold-of event-base)))
 346     (loop
 347       :with fd-events := (harvest-events (mux-of event-base) timeout)
 348       :for ev :in fd-events
 349       :for dlist :=    (%handle-one-fd event-base ev now nil wthreshold)
 350                  :then (%handle-one-fd event-base ev now dlist wthreshold)
 351       :finally
 352          (priority-queue-reorder (fd-timers-of event-base))
 353        (return (values (consp fd-events) dlist)))))
 354
 355 (defun %handle-one-fd (event-base event now deletion-list wthreshold)
 356   (destructuring-bind (fd ev-types) event
 357     (let* ((readp nil) (writep nil)
 358            (fd-entry (fd-entry-of event-base fd))
 359            (errorp (and fd-entry (member :error ev-types))))
 360       (when fd-entry
 361         (when (member :read ev-types)
 362           (setf readp (%dispatch-event fd-entry :read
 363                                        (if errorp :error nil) now)))
 364         (when (member :write ev-types)
 365           (when (<= wthreshold (- now (fd-entry-write-ts fd-entry)))
 366             (unwind-protect
 367                  (setf writep (%dispatch-event fd-entry :write
 368                                                (if errorp :error nil) now))
 369               (setf (fd-entry-write-ts fd-entry) now))))
 370         (when errorp
 371           (when-let ((callback (fd-entry-error-callback fd-entry)))
 372             (funcall callback (fd-entry-fd fd-entry) :error))
 373           (setf readp t writep t))
 374         (when readp (push (fd-entry-read-handler fd-entry) deletion-list))
 375         (when writep (push (fd-entry-write-handler fd-entry) deletion-list)))
 376       (values deletion-list))))
 377
 378 (defun %dispatch-event (fd-entry event-type errorp now)
 379   (let ((ev (fd-entry-handler fd-entry event-type)))
 380     (when ev
 381       (funcall (fd-handler-callback ev)
 382                (fd-entry-fd fd-entry)
 383                event-type
 384                (if errorp :error nil))
 385       (when-let (timer (fd-handler-timer ev))
 386         (reschedule-timer-relative-to-now timer now))
 387       (fd-handler-one-shot-p ev))))
 388
 389 (defun dispatch-fd-timeouts (events)
 390   (dolist (ev events)
 391     (funcall (fd-handler-callback ev)
 392              (fd-handler-fd ev)
 393              (fd-handler-type ev)
 394              :timeout)))