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