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
)
26 (declaim (optimize (debug 3) (safety 3)))
31 (defclass event-base
()
34 (fds :initform
(make-hash-table :test
'eql
)
36 (timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
38 (fd-timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
40 (expired-events :initform nil
41 :accessor expired-events-of
)
44 (exit-when-empty :initarg
:exit-when-empty
45 :accessor exit-when-empty-p
))
46 (:default-initargs
:mux
(make-instance *default-multiplexer
*)
48 (:documentation
"An event base ..."))
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
)))
56 (when ,var
(close ,var
)))))
58 (defmethod print-object ((base event-base
) stream
)
59 (print-unreadable-object (base stream
:type nil
:identity t
)
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"))))
65 (defmethod initialize-instance :after
((base event-base
) &key
)
66 (with-slots (mux) base
68 (setf mux
(make-instance mux
)))))
70 ;;; KLUDGE: CLOSE is for streams. --luis
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
))
82 (defgeneric add-fd
(base fd event-type function
&key timeout one-shot
)
85 (defgeneric add-timer
(event-base function timeout
&key one-shot
)
88 (defgeneric remove-event
(event-base event
)
91 (defgeneric remove-fd
(event-base fd
)
94 (defgeneric event-dispatch
(event-base &key one-shot timeout
&allow-other-keys
)
97 (defgeneric exit-event-loop
(event-base &key delay
)
99 (:method
((event-base event-base
) &key
(delay 0))
100 (add-timer event-base
101 #'(lambda () (setf (exit-p event-base
) t
))
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
)))))
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
)))
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
))
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
)))
130 (defun expire-event (event-base event
)
131 (push event
(expired-events-of event-base
)))
133 (defun %add-fd-timer
(event-base timer
)
134 (schedule-timer (fd-timers-of event-base
) timer
))
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
)))
140 (let ((timer (make-timer #'(lambda () (expire-event event-base event
))
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
)
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
))))
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
)))
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
))
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
))))
175 (defun %add-timer
(event-base timer
)
176 (schedule-timer (timers-of event-base
) timer
))
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
)))
184 (defun %remove-fd-timer
(event-base timer
)
185 (unschedule-timer (fd-timers-of event-base
) timer
))
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
))
199 (defun %remove-fd-event
(event-base event
)
200 (let* ((fd (fd-event-fd event
))
201 (current-entry (fd-entry-of event-base fd
)))
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
)))
209 (%remove-fd event-base event
)))))
211 (defun %remove-timer
(event-base timer
)
212 (unschedule-timer (timers-of event-base
) timer
))
214 (defmethod remove-event ((event-base event-base
) event
)
216 (timer (%remove-timer event-base event
))
217 (fd-event (%remove-fd-event event-base event
)))
220 (defun remove-events (event-base event-list
)
221 (dolist (ev event-list
)
222 (remove-event event-base ev
)))
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
)))
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.")))))))
242 (defvar *maximum-event-loop-timeout
* 1)
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
)
249 (exit-event-loop event-base
:delay timeout
))
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
))
260 (flet ((poll-timeout ()
261 (min-timeout (time-to-next-timer timers
)
262 (time-to-next-timer fd-timers
)
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
)
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
))
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
))
296 (%dispatch-event fd-entry
:error now
)
297 (append-events (fd-entry-all-events fd-entry
)))
299 (let ((events (%dispatch-event fd-entry
:read now
)))
300 (or errorp
(append-events events
))))
302 (let ((events (%dispatch-event fd-entry
:write now
)))
303 (or errorp
(append-events events
)))))
305 (when errorp
(do-error))
306 (when (member :read ev-types
) (do-read))
307 (when (member :write ev-types
) (do-write)))
309 (warn "Got spurious event for non-monitored FD: ~A" fd
)))))))
310 (priority-queue-reorder fd-timers
)
311 (values (consp fd-events
) deletion-list
))))
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
)))
322 (defun dispatch-fd-timeouts (events)
324 (funcall (fd-event-handler ev
)