io.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 :io.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.5d0)
 268 (defvar *maximum-event-loop-step* 1.0d0)
 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   (with-accessors ((mux mux-of) (fds fds-of) (exit-p exit-p)
 282                    (exit-when-empty exit-when-empty-p)
 283                    (timers timers-of) (fd-timers fd-timers-of)
 284                    (expired-events expired-events-of))
 285       event-base
 286     (flet ((poll-timeout ()
 287              (clamp-timeout (min-timeout (time-to-next-timer timers)
 288                                          (time-to-next-timer fd-timers))
 289                             min-step max-step)))
 290       (do ((deletion-list () ())
 291            (eventsp nil nil)
 292            (poll-timeout (poll-timeout) (poll-timeout))
 293            (now (isys:%sys-get-monotonic-time)
 294                 (isys:%sys-get-monotonic-time)))
 295           ((or exit-p (and exit-when-empty (event-base-empty-p event-base))))
 296         (setf expired-events nil)
 297         (setf (values eventsp deletion-list)
 298               (dispatch-fd-events-once event-base poll-timeout now))
 299         (%remove-handlers event-base deletion-list)
 300         (when (expire-pending-timers fd-timers now) (setf eventsp t))
 301         (dispatch-fd-timeouts expired-events)
 302         (when (expire-pending-timers timers now) (setf eventsp t))
 303         (when (and eventsp one-shot) (setf exit-p t))))))
 304
 305 (defun %remove-handlers (event-base event-list)
 306   (loop :for ev :in event-list
 307         :for fd := (fd-handler-fd ev)
 308         :for fd-entry := (fd-entry-of event-base fd)
 309      :do (%remove-io-handler event-base fd fd-entry ev)))
 310
 311 ;;; Waits for events and dispatches them.  Returns T if some events
 312 ;;; have been received, NIL otherwise.
 313 (defun dispatch-fd-events-once (event-base timeout now)
 314   (loop
 315      :with fd-events := (harvest-events (mux-of event-base) timeout)
 316      :for ev :in fd-events
 317      :for dlist :=    (%handle-one-fd event-base ev now nil)
 318                 :then (%handle-one-fd event-base ev now dlist)
 319      :finally
 320         (priority-queue-reorder (fd-timers-of event-base))
 321       (return (values (consp fd-events) dlist))))
 322
 323 (defun %handle-one-fd (event-base event now deletion-list)
 324   (destructuring-bind (fd ev-types) event
 325     (let* ((readp nil) (writep nil)
 326            (fd-entry (fd-entry-of event-base fd))
 327            (errorp (and fd-entry (member :error ev-types))))
 328       (when fd-entry
 329         (when (member :read ev-types)
 330           (setf readp (%dispatch-event fd-entry :read
 331                                        (if errorp :error nil) now)))
 332         (when (member :write ev-types)
 333           (setf writep (%dispatch-event fd-entry :write
 334                                         (if errorp :error nil) now)))
 335         (when errorp
 336           (funcall (fd-entry-error-callback fd-entry)
 337                    (fd-entry-fd fd-entry)
 338                    :error)
 339           (setf readp t writep t))
 340         (when readp (push (fd-entry-read-handler fd-entry) deletion-list))
 341         (when writep (push (fd-entry-write-handler fd-entry) deletion-list)))
 342       (values deletion-list))))
 343
 344 (defun %dispatch-event (fd-entry event-type errorp now)
 345   (let ((ev (fd-entry-handler fd-entry event-type)))
 346     (funcall (fd-handler-callback ev)
 347              (fd-entry-fd fd-entry)
 348              event-type
 349              (if errorp :error nil))
 350     (when-let (timer (fd-handler-timer ev))
 351       (reschedule-timer-relative-to-now timer now))
 352     (fd-handler-one-shot-p ev)))
 353
 354 (defun dispatch-fd-timeouts (events)
 355   (dolist (ev events)
 356     (funcall (fd-handler-callback ev)
 357              (fd-handler-fd ev)
 358              (fd-handler-type ev)
 359              :timeout)))