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 \f
  27 ;;;; EVENT-BASE
  28
  29 (defclass event-base ()
  30   ((mux :initarg :mux
  31         :reader mux-of)
  32    (fds :initform (make-hash-table :test 'eql)
  33         :reader fds-of)
  34    (timers :initform (make-priority-queue :key #'%timer-expire-time)
  35            :reader timers-of)
  36    (fd-timers :initform (make-priority-queue :key #'%timer-expire-time)
  37               :reader fd-timers-of)
  38    (expired-events :initform nil
  39                    :accessor expired-events-of)
  40    (exit :initform nil
  41          :accessor exit-p)
  42    (exit-when-empty :initarg :exit-when-empty
  43                     :accessor exit-when-empty-p))
  44   (:default-initargs :mux (make-instance *default-multiplexer*)
  45                      :exit-when-empty nil)
  46   (:documentation "An event base ..."))
  47
  48 (defmacro with-event-base ((var &rest initargs) &body body)
  49   "Binds VAR to a new EVENT-BASE, instantiated with INITARGS,
  50 within the extent of BODY.  Closes VAR."
  51   `(let ((,var (make-instance 'event-base ,@initargs)))
  52      (unwind-protect
  53           (locally ,@body)
  54        (when ,var (close ,var)))))
  55
  56 (defmethod print-object ((base event-base) stream)
  57   (print-unreadable-object (base stream :type nil :identity t)
  58     (if (fds-of base)
  59         (format stream "event base, ~A FDs monitored, using: ~A"
  60                 (hash-table-count (fds-of base)) (mux-of base))
  61         (format stream "event base, closed"))))
  62
  63 (defmethod initialize-instance :after ((base event-base) &key)
  64   (with-slots (mux) base
  65     (when (symbolp mux)
  66       (setf mux (make-instance mux)))))
  67
  68 ;;; KLUDGE: CLOSE is for streams. --luis
  69 ;;;
  70 ;;; Also, we might want to close FDs here.  Or have a version/argument
  71 ;;; that handles that.  Or... add finalizers to the fd streams.
  72 (defmethod close ((event-base event-base) &key abort)
  73   (declare (ignore abort))
  74   (with-accessors ((mux mux-of)) event-base
  75     (close-multiplexer mux)
  76     (dolist (slot '(mux fds timers fd-timers expired-events))
  77       (setf (slot-value event-base slot) nil))
  78     (values event-base)))
  79
  80 (defgeneric add-fd (base fd event-type function &key timeout one-shot)
  81   (:documentation ""))
  82
  83 (defgeneric add-timer (event-base function timeout &key one-shot)
  84   (:documentation ""))
  85
  86 (defgeneric remove-event (event-base event)
  87   (:documentation ""))
  88
  89 (defgeneric remove-fd (event-base fd)
  90   (:documentation ""))
  91
  92 (defgeneric event-dispatch (event-base &key one-shot timeout &allow-other-keys)
  93   (:documentation ""))
  94
  95 (defgeneric exit-event-loop (event-base &key delay)
  96   (:documentation "")
  97   (:method ((event-base event-base) &key (delay 0))
  98     (add-timer event-base
  99                #'(lambda () (setf (exit-p event-base) t))
 100                delay :one-shot t)))
 101
 102 (defgeneric event-base-empty-p (event-base)
 103   (:documentation "Return T if no FD event or timeout is registered with EVENT-BASE.")
 104   (:method ((event-base event-base))
 105     (and (zerop (hash-table-count (fds-of event-base)))
 106          (priority-queue-empty-p (timers-of event-base)))))
 107 \f
 108 ;;;;;;;;;;;;;;;;;
 109 ;;; Utilities ;;;
 110 ;;;;;;;;;;;;;;;;;
 111
 112 (defun fd-entry-of (event-base fd)
 113   "Return the FD-ENTRY of FD in EVENT-BASE."
 114   (gethash fd (fds-of event-base)))
 115
 116 (defun (setf fd-entry-of) (fd-entry event-base fd)
 117   "Return the FD-ENTRY of FD in EVENT-BASE."
 118   (setf (gethash fd (fds-of event-base)) fd-entry))
 119
 120 (defun remove-fd-entry (event-base fd)
 121   "Remove the FD-ENTRY of FD from EVENT-BASE."
 122   (remhash fd (fds-of event-base)))
 123 \f
 124 ;;;;;;;;;;;;;;;;;
 125 ;;; Internals ;;;
 126 ;;;;;;;;;;;;;;;;;
 127
 128 (defun expire-event (event-base event)
 129   (push event (expired-events-of event-base)))
 130
 131 (defun %add-fd-timer (event-base timer)
 132   (schedule-timer (fd-timers-of event-base) timer))
 133
 134 (defun %add-fd (event-base event fd-entry timeout)
 135   (with-accessors ((fd-timers fd-timers-of)) event-base
 136     (let ((fd (fd-event-fd event)))
 137       (when timeout
 138         (let ((timer (make-timer #'(lambda () (expire-event event-base event))
 139                                  timeout)))
 140           (setf (fd-event-timer event) timer)
 141           (%add-fd-timer event-base timer)))
 142       (setf (fd-entry-event fd-entry (fd-event-type event)) event)
 143       (setf (fd-entry-of event-base fd) fd-entry)
 144       (values event))))
 145
 146 (defmethod add-fd :before ((event-base event-base) fd event-type function
 147                            &key timeout one-shot)
 148   (declare (ignore timeout))
 149   (check-type fd unsigned-byte)
 150   (check-type event-type fd-event-type)
 151   (check-type function (or symbol function))
 152   (check-type one-shot boolean)
 153   (let ((fd-limit (fd-limit-of (mux-of event-base))))
 154     (when (and fd-limit (> fd fd-limit))
 155       (error "Cannot add such a large FD: ~A" fd))))
 156
 157 (defmethod add-fd ((event-base event-base) fd event-type function
 158                    &key timeout one-shot)
 159   (let ((current-entry (fd-entry-of event-base fd))
 160         (event (make-event fd event-type function one-shot)))
 161     (cond (current-entry
 162            (assert (null (fd-entry-event current-entry event-type))
 163                    ((fd-entry-event current-entry event-type))
 164                    "FD ~A is already monitored for event ~A" fd 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 (fd-entry) "FD ~A does not have an FD-ENTRY" fd)
 190       (setf (fd-entry-event fd-entry (fd-event-type event)) nil)
 191       (when-let ((timer (fd-event-timer event)))
 192         (%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 now))
 272         (remove-events event-base deletion-list)
 273         (setf got-fd-timeouts-p (expire-pending-timers fd-timers now))
 274         (dispatch-fd-timeouts expired-events)
 275         (setf got-timers-p (expire-pending-timers timers now))
 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 now)
 283   (with-accessors ((mux mux-of) (fds fds-of) (fd-timers fd-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 now)
 295                        (append-events (fd-entry-all-events fd-entry)))
 296                      (do-read ()
 297                        (let ((events (%dispatch-event fd-entry :read now)))
 298                          (or errorp (append-events events))))
 299                      (do-write ()
 300                        (let ((events (%dispatch-event fd-entry :write now)))
 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       (priority-queue-reorder fd-timers)
 309       (values (consp fd-events) deletion-list))))
 310
 311 (defun %dispatch-event (fd-entry event-type now)
 312   (let ((deletion-list ())
 313         (ev (fd-entry-event fd-entry event-type)))
 314     (funcall (fd-event-handler ev) (fd-entry-fd fd-entry) event-type)
 315     (when-let ((timer (fd-event-timer ev)))
 316       (reschedule-timer-relative-to-now timer now))
 317     (when (fd-event-one-shot-p ev) (push ev deletion-list))
 318     (values deletion-list)))
 319
 320 (defun dispatch-fd-timeouts (events)
 321   (dolist (ev events)
 322     (funcall (fd-event-handler ev)
 323              (fd-event-fd ev)
 324              :timeout)))