io-multiplex/event-loop.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; event-loop.lisp --- Main event loop.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :io.multiplex)
  25
  26 (declaim (optimize (debug 3) (safety 3)))
  27
  28 \f
  29 ;;;; EVENT-BASE
  30
  31 (defclass event-base ()
  32   ((mux :initarg :mux
  33         :reader mux-of)
  34    (fds :initform (make-hash-table :test 'eql)
  35         :reader fds-of)
  36    (timers :initform (make-priority-queue :key #'%timer-expire-time)
  37            :reader timers-of)
  38    (fd-timers :initform (make-priority-queue :key #'%timer-expire-time)
  39               :reader fd-timers-of)
  40    (expired-events :initform nil
  41                    :accessor expired-events-of)
  42    (exit :initform nil
  43          :accessor exit-p)
  44    (exit-when-empty :initarg :exit-when-empty
  45                     :accessor exit-when-empty-p))
  46   (:default-initargs :mux (make-instance *default-multiplexer*)
  47                      :exit-when-empty nil)
  48   (:documentation "An event base ..."))
  49
  50 (defmacro with-event-base ((var &rest initargs) &body body)
  51   "Binds VAR to a new EVENT-BASE, instantiated with INITARGS,
  52 within the extent of BODY.  Closes VAR."
  53   `(let ((,var (make-instance 'event-base ,@initargs)))
  54      (unwind-protect
  55           (progn ,@body)
  56        (close ,var))))
  57
  58 (defmethod print-object ((base event-base) stream)
  59   (print-unreadable-object (base stream :type nil :identity t)
  60     (if (fds-of base)
  61         (format stream "event base, ~A FDs monitored, using: ~A"
  62                 (hash-table-count (fds-of base)) (mux-of base))
  63         (format stream "event base, closed"))))
  64
  65 (defmethod initialize-instance :after ((base event-base) &key)
  66   (with-slots (mux) base
  67     (when (symbolp mux)
  68       (setf mux (make-instance mux)))))
  69
  70 ;;; KLUDGE: CLOSE is for streams. --luis
  71 ;;;
  72 ;;; Also, we might want to close FDs here.  Or have a version/argument
  73 ;;; that handles that.  Or... add finalizers to the fd streams.
  74 (defmethod close ((event-base event-base) &key abort)
  75   (declare (ignore abort))
  76   (with-accessors ((mux mux-of)) event-base
  77     (close-multiplexer mux)
  78     (dolist (slot '(mux fds timers fd-timers expired-events))
  79       (setf (slot-value event-base slot) nil))
  80     (values event-base)))
  81
  82 (defgeneric add-fd (base fd event-type function &key timeout one-shot)
  83   (:documentation ""))
  84
  85 (defgeneric add-timer (event-base function timeout &key one-shot)
  86   (:documentation ""))
  87
  88 (defgeneric remove-event (event-base event)
  89   (:documentation ""))
  90
  91 (defgeneric remove-fd (event-base fd)
  92   (:documentation ""))
  93
  94 (defgeneric event-dispatch (event-base &key one-shot timeout &allow-other-keys)
  95   (:documentation ""))
  96
  97 (defgeneric exit-event-loop (event-base &key delay)
  98   (:documentation "")
  99   (:method ((event-base event-base) &key (delay 0))
 100     (add-timer event-base
 101                #'(lambda () (setf (exit-p event-base) t))
 102                delay :one-shot t)))
 103
 104 (defgeneric event-base-empty-p (event-base)
 105   (:documentation "Return T if no FD event or timeout is registered with EVENT-BASE.")
 106   (:method ((event-base event-base))
 107     (and (zerop (hash-table-count (fds-of event-base)))
 108          (priority-queue-empty-p (timers-of event-base)))))
 109 \f
 110 ;;;;;;;;;;;;;;;;;
 111 ;;; Utilities ;;;
 112 ;;;;;;;;;;;;;;;;;
 113
 114 (defun fd-entry-of (event-base fd)
 115   "Return the FD-ENTRY of FD in EVENT-BASE."
 116   (gethash fd (fds-of event-base)))
 117
 118 (defun (setf fd-entry-of) (fd-entry event-base fd)
 119   "Return the FD-ENTRY of FD in EVENT-BASE."
 120   (setf (gethash fd (fds-of event-base)) fd-entry))
 121
 122 (defun remove-fd-entry (event-base fd)
 123   "Remove the FD-ENTRY of FD from EVENT-BASE."
 124   (remhash fd (fds-of event-base)))
 125 \f
 126 ;;;;;;;;;;;;;;;;;
 127 ;;; Internals ;;;
 128 ;;;;;;;;;;;;;;;;;
 129
 130 (defun expire-event (event-base event)
 131   (push event (expired-events-of event-base)))
 132
 133 (defun %add-fd-timer (event-base timer)
 134   (schedule-timer (fd-timers-of event-base) timer))
 135
 136 (defun %add-fd (event-base event fd-entry timeout)
 137   (with-accessors ((fd-timers fd-timers-of)) event-base
 138     (let ((fd (fd-event-fd event)))
 139       (when timeout
 140         (let ((timer (make-timer #'(lambda () (expire-event event-base event))
 141                                  timeout)))
 142           (setf (fd-event-timer event) timer)
 143           (%add-fd-timer event-base timer)))
 144       (setf (fd-entry-event fd-entry (fd-event-type event)) event)
 145       (setf (fd-entry-of event-base fd) fd-entry)
 146       (values event))))
 147
 148 (defmethod add-fd :before ((event-base event-base) fd event-type function
 149                            &key timeout one-shot)
 150   (declare (ignore timeout))
 151   (check-type fd unsigned-byte)
 152   (check-type event-type fd-event-type)
 153   (check-type function (or symbol function))
 154   (check-type one-shot boolean)
 155   (let ((fd-limit (fd-limit-of (mux-of event-base))))
 156     (when (and fd-limit (> fd fd-limit))
 157       (error "Cannot add such a large FD: ~A" fd))))
 158
 159 (defmethod add-fd ((event-base event-base) fd event-type function
 160                    &key timeout one-shot)
 161   (let ((current-entry (fd-entry-of event-base fd))
 162         (event (make-event fd event-type function one-shot)))
 163     (cond (current-entry
 164            (assert (null (fd-entry-event current-entry event-type))
 165                     ((fd-entry-event current-entry event-type))
 166                     "FD ~A is already monitored for event ~A" fd event-type)
 167            (%add-fd event-base event current-entry timeout)
 168            (update-fd (mux-of event-base) current-entry event-type :add))
 169           (t
 170            (let ((new-fd-entry (make-fd-entry fd)))
 171              (%add-fd event-base event new-fd-entry timeout)
 172              (monitor-fd (mux-of event-base) new-fd-entry))))
 173     (values event)))
 174
 175 (defun %add-timer (event-base timer)
 176   (schedule-timer (timers-of event-base) timer))
 177
 178 (defmethod add-timer ((event-base event-base) function
 179                       timeout &key one-shot)
 180   (check-type function (or symbol function))
 181   (check-type one-shot boolean)
 182   (%add-timer event-base (make-timer function timeout :one-shot one-shot)))
 183
 184 (defun %remove-fd-timer (event-base timer)
 185   (unschedule-timer (fd-timers-of event-base) timer))
 186
 187 (defun %remove-fd (event-base event)
 188   (with-accessors ((timers timers-of)) event-base
 189     (let* ((fd (fd-event-fd event))
 190            (fd-entry (fd-entry-of event-base fd)))
 191       (assert fd-entry (fd-entry) "FD ~A does not have an FD-ENTRY" fd)
 192       (setf (fd-entry-event fd-entry (fd-event-type event)) nil)
 193       (when-let ((timer (fd-event-timer event)))
 194         (%remove-fd-timer event-base timer))
 195       (when (fd-entry-empty-p fd-entry)
 196         (remove-fd-entry event-base fd))
 197       (values event))))
 198
 199 (defun %remove-fd-event (event-base event)
 200   (let* ((fd (fd-event-fd event))
 201          (current-entry (fd-entry-of event-base fd)))
 202     (cond (current-entry
 203            (%remove-fd event-base event)
 204            (if (fd-entry-empty-p current-entry)
 205                (unmonitor-fd (mux-of event-base) current-entry)
 206                (update-fd (mux-of event-base) current-entry
 207                           (fd-event-type event) :del)))
 208           (t
 209            (%remove-fd event-base event)))))
 210
 211 (defun %remove-timer (event-base timer)
 212   (unschedule-timer (timers-of event-base) timer))
 213
 214 (defmethod remove-event ((event-base event-base) event)
 215   (etypecase event
 216     (timer    (%remove-timer event-base event))
 217     (fd-event (%remove-fd-event event-base event)))
 218   (values event-base))
 219
 220 (defun remove-events (event-base event-list)
 221   (dolist (ev event-list)
 222     (remove-event event-base ev)))
 223
 224 (defmethod remove-fd ((event-base event-base) fd)
 225   (let ((entry (fd-entry-of event-base fd)))
 226     (symbol-macrolet ((rev (fd-entry-read-event entry))
 227                       (wev (fd-entry-write-event entry))
 228                       (eev (fd-entry-error-event entry)))
 229       (labels ((maybe-remove-timer (event)
 230                  (when (and event (fd-event-timer event))
 231                    (%remove-fd-timer event-base (fd-event-timer event))))
 232                (maybe-remove-all-timers ()
 233                  (maybe-remove-timer rev)
 234                  (maybe-remove-timer wev)
 235                  (maybe-remove-timer eev)))
 236         (cond (entry
 237                (maybe-remove-all-timers)
 238                (unmonitor-fd (mux-of event-base) fd)
 239                (remove-fd-entry event-base fd))
 240               (t (warn "Trying to remove an unmonitored FD.")))))))
 241
 242 (defvar *maximum-event-loop-timeout* 1)
 243
 244 (defmethod event-dispatch :around ((event-base event-base)
 245                                    &key timeout one-shot)
 246   (declare (ignore one-shot))
 247   (setf (exit-p event-base) nil)
 248   (when timeout
 249     (exit-event-loop event-base :delay timeout))
 250   (call-next-method))
 251
 252 (defmethod event-dispatch ((event-base event-base) &key one-shot timeout
 253                            (max-timeout *maximum-event-loop-timeout*))
 254   (declare (ignore timeout))
 255   (with-accessors ((mux mux-of) (fds fds-of) (exit-p exit-p)
 256                    (exit-when-empty exit-when-empty-p)
 257                    (timers timers-of) (fd-timers fd-timers-of)
 258                    (expired-events expired-events-of))
 259       event-base
 260     (flet ((poll-timeout ()
 261              (min-timeout (time-to-next-timer timers)
 262                           (time-to-next-timer fd-timers)
 263                           max-timeout)))
 264       (do ((deletion-list () ())
 265            (got-fd-events-p nil nil)
 266            (got-fd-timeouts-p nil nil)
 267            (got-timers-p nil nil)
 268            (poll-timeout (poll-timeout) (poll-timeout))
 269            (now (osicat-sys:get-monotonic-time) (osicat-sys:get-monotonic-time)))
 270           ((or exit-p (and exit-when-empty (event-base-empty-p event-base))))
 271         (setf (expired-events-of event-base) nil)
 272         (setf (values got-fd-events-p deletion-list)
 273               (dispatch-fd-events-once event-base poll-timeout now))
 274         (remove-events event-base deletion-list)
 275         (setf got-fd-timeouts-p (expire-pending-timers fd-timers now))
 276         (dispatch-fd-timeouts expired-events)
 277         (setf got-timers-p (expire-pending-timers timers now))
 278         (when (and (or got-fd-events-p got-fd-timeouts-p got-timers-p)
 279                    one-shot)
 280           (setf exit-p t))))))
 281
 282 ;;; Waits for events and dispatches them.  Returns T if some events
 283 ;;; have been received, NIL otherwise.
 284 (defun dispatch-fd-events-once (event-base timeout now)
 285   (with-accessors ((mux mux-of) (fds fds-of) (fd-timers fd-timers-of))
 286       event-base
 287     (let ((deletion-list ())
 288           (fd-events (harvest-events mux timeout)))
 289       (dolist (ev fd-events)
 290         (destructuring-bind (fd ev-types) ev
 291           (let* ((fd-entry (fd-entry-of event-base fd))
 292                  (errorp (and fd-entry (member :error ev-types))))
 293             (labels ((append-events (events)
 294                        (nconcf deletion-list events))
 295                      (do-error ()
 296                        (%dispatch-event fd-entry :error now)
 297                        (append-events (fd-entry-all-events fd-entry)))
 298                      (do-read ()
 299                        (let ((events (%dispatch-event fd-entry :read now)))
 300                          (or errorp (append-events events))))
 301                      (do-write ()
 302                        (let ((events (%dispatch-event fd-entry :write now)))
 303                          (or errorp (append-events events)))))
 304               (cond (fd-entry
 305                      (when errorp (do-error))
 306                      (when (member :read ev-types) (do-read))
 307                      (when (member :write ev-types) (do-write)))
 308                     (t
 309                      (warn "Got spurious event for non-monitored FD: ~A" fd)))))))
 310       (priority-queue-reorder fd-timers)
 311       (values (consp fd-events) deletion-list))))
 312
 313 (defun %dispatch-event (fd-entry event-type now)
 314   (let ((deletion-list ())
 315         (ev (fd-entry-event fd-entry event-type)))
 316     (funcall (fd-event-handler ev) (fd-entry-fd fd-entry) event-type)
 317     (when-let ((timer (fd-event-timer ev)))
 318       (reschedule-timer-relative-to-now timer now))
 319     (when (fd-event-one-shot-p ev) (push ev deletion-list))
 320     (values deletion-list)))
 321
 322 (defun dispatch-fd-timeouts (events)
 323   (dolist (ev events)
 324     (funcall (fd-event-handler ev)
 325              (fd-event-fd ev)
 326              :timeout)))