src/multiplex/event-loop.lisp

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