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            (%add-fd event-base event current-entry timeout)
 166            (update-fd (mux-of event-base) current-entry event-type :add))
 167           (t
 168            (let ((new-fd-entry (make-fd-entry fd)))
 169              (%add-fd event-base event new-fd-entry timeout)
 170              (monitor-fd (mux-of event-base) new-fd-entry))))
 171     (values event)))
 172
 173 (defun %add-timer (event-base timer)
 174   (schedule-timer (timers-of event-base) timer))
 175
 176 (defmethod add-timer ((event-base event-base) function
 177                       timeout &key one-shot)
 178   (check-type function (or symbol function))
 179   (check-type one-shot boolean)
 180   (%add-timer event-base (make-timer function timeout :one-shot one-shot)))
 181
 182 (defun %remove-fd-timer (event-base timer)
 183   (unschedule-timer (fd-timers-of event-base) timer))
 184
 185 (defun %remove-fd (event-base event)
 186   (with-accessors ((timers timers-of)) event-base
 187     (let* ((fd (fd-event-fd event))
 188            (fd-entry (fd-entry-of event-base fd)))
 189       (assert fd-entry)
 190       (setf (fd-entry-event fd-entry (fd-event-type event)) nil)
 191       (let ((timer (fd-event-timer event)))
 192         (when timer (%remove-fd-timer event-base timer)))
 193       (when (fd-entry-empty-p fd-entry)
 194         (remove-fd-entry event-base fd))
 195       (values event))))
 196
 197 (defun %remove-fd-event (event-base event)
 198   (let* ((fd (fd-event-fd event))
 199          (current-entry (fd-entry-of event-base fd)))
 200     (cond (current-entry
 201            (%remove-fd event-base event)
 202            (if (fd-entry-empty-p current-entry)
 203                (unmonitor-fd (mux-of event-base) current-entry)
 204                (update-fd (mux-of event-base) current-entry
 205                           (fd-event-type event) :del)))
 206           (t
 207            (%remove-fd event-base event)))))
 208
 209 (defun %remove-timer (event-base timer)
 210   (unschedule-timer (timers-of event-base) timer))
 211
 212 (defmethod remove-event ((event-base event-base) event)
 213   (etypecase event
 214     (timer    (%remove-timer event-base event))
 215     (fd-event (%remove-fd-event event-base event)))
 216   (values event-base))
 217
 218 (defun remove-events (event-base event-list)
 219   (dolist (ev event-list)
 220     (remove-event event-base ev)))
 221
 222 (defmethod remove-fd ((event-base event-base) fd)
 223   (let ((entry (fd-entry-of event-base fd)))
 224     (symbol-macrolet ((rev (fd-entry-read-event entry))
 225                       (wev (fd-entry-write-event entry))
 226                       (eev (fd-entry-error-event entry)))
 227       (labels ((maybe-remove-timer (event)
 228                  (when (and event (fd-event-timer event))
 229                    (%remove-fd-timer event-base (fd-event-timer event))))
 230                (maybe-remove-all-timers ()
 231                  (maybe-remove-timer rev)
 232                  (maybe-remove-timer wev)
 233                  (maybe-remove-timer eev)))
 234         (cond (entry
 235                (maybe-remove-all-timers)
 236                (unmonitor-fd (mux-of event-base) fd)
 237                (remove-fd-entry event-base fd))
 238               (t (warn "Trying to remove an unmonitored FD.")))))))
 239
 240 (defvar *maximum-event-loop-timeout* 1)
 241
 242 (defmethod event-dispatch :around ((event-base event-base)
 243                                    &key timeout one-shot)
 244   (declare (ignore one-shot))
 245   (setf (exit-p event-base) nil)
 246   (when timeout
 247     (exit-event-loop event-base :delay timeout))
 248   (call-next-method))
 249
 250 (defmethod event-dispatch ((event-base event-base) &key one-shot timeout
 251                            (max-timeout *maximum-event-loop-timeout*))
 252   (declare (ignore timeout))
 253   (with-accessors ((mux mux-of) (fds fds-of) (exit-p exit-p)
 254                    (exit-when-empty exit-when-empty-p)
 255                    (timers timers-of) (fd-timers fd-timers-of)
 256                    (expired-events expired-events-of))
 257       event-base
 258     (flet ((poll-timeout ()
 259              (min-timeout (time-to-next-timer timers)
 260                           (time-to-next-timer fd-timers)
 261                           max-timeout)))
 262       (do ((deletion-list () ())
 263            (got-fd-events-p nil nil)
 264            (got-fd-timeouts-p nil nil)
 265            (got-timers-p nil nil)
 266            (poll-timeout (poll-timeout) (poll-timeout))
 267            (now (osicat-sys:get-monotonic-time) (osicat-sys:get-monotonic-time)))
 268           ((or exit-p (and exit-when-empty (event-base-empty-p event-base))))
 269         (setf (expired-events-of event-base) nil)
 270         (setf (values got-fd-events-p deletion-list)
 271               (dispatch-fd-events-once event-base poll-timeout))
 272         (setf got-fd-timeouts-p (expire-pending-timers fd-timers now))
 273         (dispatch-fd-timeouts expired-events)
 274         (setf got-timers-p (expire-pending-timers timers now))
 275         (remove-events event-base deletion-list)
 276         (when (and (or got-fd-events-p got-fd-timeouts-p got-timers-p)
 277                    one-shot)
 278           (setf exit-p t))))))
 279
 280 ;;; Waits for events and dispatches them.  Returns T if some events
 281 ;;; have been received, NIL otherwise.
 282 (defun dispatch-fd-events-once (event-base timeout)
 283   (with-accessors ((mux mux-of) (fds fds-of) (timers timers-of))
 284       event-base
 285     (let ((deletion-list ())
 286           (fd-events (harvest-events mux timeout)))
 287       (dolist (ev fd-events)
 288         (destructuring-bind (fd ev-types) ev
 289           (let* ((fd-entry (fd-entry-of event-base fd))
 290                  (errorp (and fd-entry (member :error ev-types))))
 291             (labels ((append-events (events)
 292                        (nconcf deletion-list events))
 293                      (do-error ()
 294                        (%dispatch-event fd-entry :error)
 295                        (nconcf deletion-list (fd-entry-all-events fd-entry)))
 296                      (do-read ()
 297                        (let ((events (%dispatch-event fd-entry :read)))
 298                          (or errorp (append-events events))))
 299                      (do-write ()
 300                        (let ((events (%dispatch-event fd-entry :write)))
 301                          (or errorp (append-events events)))))
 302               (cond (fd-entry
 303                      (when errorp (do-error))
 304                      (when (member :read ev-types) (do-read))
 305                      (when (member :write ev-types) (do-write)))
 306                     (t
 307                      (warn "Got spurious event for non-monitored FD: ~A" fd)))))))
 308       (values (consp fd-events) deletion-list))))
 309
 310 (defun %dispatch-event (fd-entry event-type)
 311   (let ((deletion-list ())
 312         (ev (fd-entry-event fd-entry event-type)))
 313     (funcall (fd-event-handler ev) (fd-entry-fd fd-entry) event-type)
 314     (when (fd-event-one-shot-p ev) (push ev deletion-list))
 315     (values deletion-list)))
 316
 317 (defun dispatch-fd-timeouts (events)
 318   (dolist (ev events)
 319     (funcall (fd-event-handler ev)
 320              (fd-event-fd ev)
 321              :timeout)))