1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; event-loop.lisp --- Main event loop.
5 ;;; Copyright (C) 2006-2007, Stelian Ionescu <sionescu@common-lisp.net>
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
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.
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
24 (in-package :io.multiplex
)
29 (defclass event-base
()
32 (fds :initform
(make-hash-table :test
'eql
)
34 (timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
36 (fd-timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
38 (expired-events :initform nil
39 :accessor expired-events-of
)
42 (exit-when-empty :initarg
:exit-when-empty
43 :accessor exit-when-empty-p
))
44 (:default-initargs
:mux
(make-instance *default-multiplexer
*)
46 (:documentation
"An event base ..."))
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
)))
54 (when ,var
(close ,var
)))))
56 (defmethod print-object ((base event-base
) stream
)
57 (print-unreadable-object (base stream
:type nil
:identity t
)
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"))))
63 (defmethod initialize-instance :after
((base event-base
) &key
)
64 (with-slots (mux) base
66 (setf mux
(make-instance mux
)))))
68 ;;; KLUDGE: CLOSE is for streams. --luis
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
))
80 (defgeneric add-fd
(base fd event-type function
&key timeout one-shot
)
83 (defgeneric add-timer
(event-base function timeout
&key one-shot
)
86 (defgeneric remove-event
(event-base event
)
89 (defgeneric remove-fd
(event-base fd
)
92 (defgeneric event-dispatch
(event-base &key one-shot timeout
&allow-other-keys
)
95 (defgeneric exit-event-loop
(event-base &key delay
)
97 (:method
((event-base event-base
) &key
(delay 0))
99 #'(lambda () (setf (exit-p event-base
) t
))
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
)))))
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
)))
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
))
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
)))
128 (defun expire-event (event-base event
)
129 (push event
(expired-events-of event-base
)))
131 (defun %add-fd-timer
(event-base timer
)
132 (schedule-timer (fd-timers-of event-base
) timer
))
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
)))
138 (let ((timer (make-timer #'(lambda () (expire-event event-base event
))
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
)
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
))))
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
)))
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
))
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
))))
173 (defun %add-timer
(event-base timer
)
174 (schedule-timer (timers-of event-base
) timer
))
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
)))
182 (defun %remove-fd-timer
(event-base timer
)
183 (unschedule-timer (fd-timers-of event-base
) timer
))
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
))
197 (defun %remove-fd-event
(event-base event
)
198 (let* ((fd (fd-event-fd event
))
199 (current-entry (fd-entry-of event-base fd
)))
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
)))
207 (%remove-fd event-base event
)))))
209 (defun %remove-timer
(event-base timer
)
210 (unschedule-timer (timers-of event-base
) timer
))
212 (defmethod remove-event ((event-base event-base
) event
)
214 (timer (%remove-timer event-base event
))
215 (fd-event (%remove-fd-event event-base event
)))
218 (defun remove-events (event-base event-list
)
219 (dolist (ev event-list
)
220 (remove-event event-base ev
)))
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
)))
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.")))))))
240 (defvar *maximum-event-loop-timeout
* 1)
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
)
247 (exit-event-loop event-base
:delay timeout
))
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
))
258 (flet ((poll-timeout ()
259 (min-timeout (time-to-next-timer timers
)
260 (time-to-next-timer fd-timers
)
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
)
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
))
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
))
294 (%dispatch-event fd-entry
:error now
)
295 (append-events (fd-entry-all-events fd-entry
)))
297 (let ((events (%dispatch-event fd-entry
:read now
)))
298 (or errorp
(append-events events
))))
300 (let ((events (%dispatch-event fd-entry
:write now
)))
301 (or errorp
(append-events events
)))))
303 (when errorp
(do-error))
304 (when (member :read ev-types
) (do-read))
305 (when (member :write ev-types
) (do-write)))
307 (warn "Got spurious event for non-monitored FD: ~A" fd
)))))))
308 (priority-queue-reorder fd-timers
)
309 (values (consp fd-events
) deletion-list
))))
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
)))
320 (defun dispatch-fd-timeouts (events)
322 (funcall (fd-event-handler ev
)