1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Main event loop.
6 (in-package :iolib.multiplex
)
9 ;;;-------------------------------------------------------------------------
11 ;;;-------------------------------------------------------------------------
13 (defclass event-base
()
15 (fds :initform
(make-hash-table :test
'eql
)
17 (timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
19 (fd-timers :initform
(make-priority-queue :key
#'%timer-expire-time
)
21 (expired-events :initform nil
22 :accessor expired-events-of
)
23 (write-interval-threshold :initarg
:write-interval-threshold
24 :accessor write-interval-threshold-of
)
27 (exit-when-empty :initarg
:exit-when-empty
28 :accessor exit-when-empty-p
))
29 (:default-initargs
:mux
*default-multiplexer
*
30 :write-interval-threshold
0.0d0
31 :exit-when-empty nil
))
34 ;;;-------------------------------------------------------------------------
36 ;;;-------------------------------------------------------------------------
38 (defmethod print-object ((base event-base
) stream
)
39 (print-unreadable-object (base stream
:type nil
:identity t
)
41 (format stream
"event base, ~A FDs monitored, using: ~A"
42 (hash-table-count (fds-of base
)) (mux-of base
))
43 (format stream
"event base, closed"))))
46 ;;;-------------------------------------------------------------------------
48 ;;;-------------------------------------------------------------------------
50 (defgeneric set-io-handler
(event-base fd event-type function
&key timeout one-shot
))
52 (defgeneric set-error-handler
(event-base fd function
))
54 (defgeneric add-timer
(event-base function timeout
&key one-shot
))
56 (defgeneric remove-fd-handlers
(event-base fd
&key read write error
))
58 (defgeneric remove-timer
(event-base timer
))
60 (defgeneric event-dispatch
(event-base &key one-shot timeout min-step max-step
))
62 (defgeneric exit-event-loop
(event-base &key delay
))
64 (defgeneric event-base-empty-p
(event-base))
67 ;;;-------------------------------------------------------------------------
69 ;;;-------------------------------------------------------------------------
71 (defmethod initialize-instance :after
72 ((base event-base
) &key mux write-interval-threshold
)
73 (check-type write-interval-threshold non-negative-real
)
74 (setf (write-interval-threshold-of base
)
75 (float write-interval-threshold
1.0d0
))
76 (setf (slot-value base
'mux
) (make-instance mux
)))
79 ;;;-------------------------------------------------------------------------
81 ;;;-------------------------------------------------------------------------
83 ;;; KLUDGE: CLOSE is for streams. --luis
85 ;;; Also, we might want to close FDs here. Or have a version/argument
86 ;;; that handles that.
87 (defmethod close ((event-base event-base
) &key abort
)
88 (declare (ignore abort
))
89 (close-multiplexer (mux-of event-base
))
90 (dolist (slot '(mux fds timers fd-timers expired-events
))
91 (setf (slot-value event-base slot
) nil
))
95 ;;;-------------------------------------------------------------------------
97 ;;;-------------------------------------------------------------------------
99 (defmacro with-event-base
((var &rest initargs
) &body body
)
100 "Binds VAR to a new EVENT-BASE, instantiated with INITARGS,
101 within the extent of BODY. Closes VAR."
102 `(let ((,var
(make-instance 'event-base
,@initargs
)))
105 (when ,var
(close ,var
)))))
108 ;;;-------------------------------------------------------------------------
110 ;;;-------------------------------------------------------------------------
112 (defun fd-entry-of (event-base fd
)
113 (gethash fd
(fds-of event-base
)))
115 (defun (setf fd-entry-of
) (fd-entry event-base fd
)
116 (setf (gethash fd
(fds-of event-base
)) fd-entry
))
118 (defmethod exit-event-loop ((event-base event-base
) &key
(delay 0))
119 (add-timer event-base
120 (lambda () (setf (exit-p event-base
) t
))
123 (defmethod event-base-empty-p ((event-base event-base
))
124 (and (zerop (hash-table-count (fds-of event-base
)))
125 (priority-queue-empty-p (timers-of event-base
))))
128 ;;;-------------------------------------------------------------------------
130 ;;;-------------------------------------------------------------------------
132 (defmethod set-io-handler :before
133 ((event-base event-base
) fd event-type function
&key timeout one-shot
)
134 (declare (ignore timeout
))
135 (check-type fd unsigned-byte
)
136 (check-type event-type fd-event-type
)
137 (check-type function function-designator
)
138 ;; FIXME: check the type of the timeout
139 (check-type one-shot boolean
)
140 (when (fd-monitored-p event-base fd event-type
)
141 (error "FD ~A is already monitored for event ~A" fd event-type
)))
143 (defun fd-monitored-p (event-base fd event-type
)
144 (let ((entry (fd-entry-of event-base fd
)))
145 (and entry
(fd-entry-handler entry event-type
))))
147 (defmethod set-io-handler
148 ((event-base event-base
) fd event-type function
&key timeout one-shot
)
149 (let ((current-fd-entry (fd-entry-of event-base fd
))
150 (event (make-fd-handler fd event-type function one-shot
)))
153 (%set-io-handler event-base fd event current-fd-entry timeout
)
154 (update-fd (mux-of event-base
) current-fd-entry event-type
:add
))
156 (let ((new-fd-entry (make-fd-entry fd
)))
157 (%set-io-handler event-base fd event new-fd-entry timeout
)
158 (monitor-fd (mux-of event-base
) new-fd-entry
))))
161 (defun %set-io-handler
(event-base fd event fd-entry timeout
)
163 (%set-io-handler-timer event-base event timeout
))
164 (setf (fd-entry-handler fd-entry
(fd-handler-type event
)) event
)
165 (setf (fd-entry-of event-base fd
) fd-entry
)
168 (defun %set-io-handler-timer
(event-base event timeout
)
169 (let ((timer (make-timer (lambda () (expire-event event-base event
))
171 (setf (fd-handler-timer event
) timer
)
172 (schedule-timer (fd-timers-of event-base
) timer
)))
174 (defun expire-event (event-base event
)
175 (push event
(expired-events-of event-base
)))
178 ;;;-------------------------------------------------------------------------
179 ;;; SET-ERROR-HANDLER
180 ;;;-------------------------------------------------------------------------
182 (defmethod set-error-handler :before
183 ((event-base event-base
) fd function
)
184 (check-type fd unsigned-byte
)
185 (check-type function function-designator
)
186 (unless (fd-entry-of event-base fd
)
187 (error "FD ~A is not being monitored" fd
))
188 (when (fd-has-error-handler-p event-base fd
)
189 (error "FD ~A already has an error handler" fd
)))
191 (defun fd-has-error-handler-p (event-base fd
)
192 (let ((entry (fd-entry-of event-base fd
)))
193 (and entry
(fd-entry-error-callback entry
))))
195 (defmethod set-error-handler
196 ((event-base event-base
) fd function
)
197 (let ((fd-entry (fd-entry-of event-base fd
)))
198 (setf (fd-entry-error-callback fd-entry
) function
)))
201 ;;;-------------------------------------------------------------------------
203 ;;;-------------------------------------------------------------------------
205 (defmethod add-timer :before
206 ((event-base event-base
) function timeout
&key one-shot
)
207 (declare (ignore timeout
))
208 (check-type function function-designator
)
209 ;; FIXME: check the type of the timeout
210 (check-type one-shot boolean
))
213 ((event-base event-base
) function timeout
&key one-shot
)
214 (schedule-timer (timers-of event-base
)
215 (make-timer function timeout
:one-shot one-shot
)))
218 ;;;-------------------------------------------------------------------------
219 ;;; REMOVE-FD-HANDLERS and REMOVE-TIMER
220 ;;;-------------------------------------------------------------------------
222 (defmethod remove-fd-handlers
223 ((event-base event-base
) fd
&key read write error
)
224 (unless (or read write error
)
225 (setf read t write t error t
))
226 (let ((entry (fd-entry-of event-base fd
)))
229 (%remove-fd-handlers event-base fd entry read write error
)
230 (when (and read write
)
231 (assert (null (fd-entry-of event-base fd
)))))
233 (error "Trying to remove a non-monitored FD.")))))
235 (defun %remove-fd-handlers
(event-base fd entry read write error
)
236 (let ((rev (fd-entry-read-handler entry
))
237 (wev (fd-entry-write-handler entry
)))
239 (%remove-io-handler event-base fd entry rev
))
240 (when (and wev write
)
241 (%remove-io-handler event-base fd entry wev
))
243 (setf (fd-entry-error-callback entry
) nil
))))
245 (defun %remove-io-handler
(event-base fd fd-entry event
)
246 (let ((event-type (fd-handler-type event
)))
247 (setf (fd-entry-handler fd-entry event-type
) nil
)
248 (when-let (timer (fd-handler-timer event
))
249 (unschedule-timer (fd-timers-of event-base
) timer
))
251 ((fd-entry-empty-p fd-entry
)
252 (%remove-fd-entry event-base fd
)
253 (unmonitor-fd (mux-of event-base
) fd-entry
))
255 (update-fd (mux-of event-base
) fd-entry event-type
:del
)))))
257 (defun %remove-fd-entry
(event-base fd
)
258 (remhash fd
(fds-of event-base
)))
260 (defmethod remove-timer :before
261 ((event-base event-base
) timer
)
262 (check-type timer timer
))
264 (defmethod remove-timer ((event-base event-base
) timer
)
265 (unschedule-timer (timers-of event-base
) timer
)
269 ;;;-------------------------------------------------------------------------
271 ;;;-------------------------------------------------------------------------
273 (defvar *minimum-event-loop-step
* 0.0d0
)
274 (defvar *maximum-event-loop-step
* nil
)
276 (defmethod event-dispatch :around
277 ((event-base event-base
) &key timeout one-shot min-step max-step
)
278 (declare (ignore one-shot min-step max-step
))
279 (setf (exit-p event-base
) nil
)
280 (let ((timer (when timeout
281 (exit-event-loop event-base
:delay timeout
))))
285 (remove-timer event-base timer
)))))
287 (defmethod event-dispatch ((event-base event-base
) &key one-shot timeout
288 (min-step *minimum-event-loop-step
*)
289 (max-step *maximum-event-loop-step
*))
290 (declare (ignore timeout
))
291 (coercef min-step
'double-float
)
292 (when max-step
(coercef max-step
'double-float
))
293 (with-accessors ((mux mux-of
) (fds fds-of
) (exit-p exit-p
)
294 (exit-when-empty exit-when-empty-p
)
295 (timers timers-of
) (fd-timers fd-timers-of
)
296 (expired-events expired-events-of
))
298 (labels ((poll-timeout (now)
299 (let* ((deadline1 (time-to-next-timer timers
))
300 (deadline2 (time-to-next-timer fd-timers
))
301 (deadline (if (and deadline1 deadline2
)
302 (min deadline1 deadline2
)
303 (or deadline1 deadline2
))))
305 (clamp-timeout (- deadline now
) min-step max-step
)
310 (event-base-empty-p event-base
)))))
311 (loop :with deletion-list
:= ()
313 :for now
:= (isys:get-monotonic-time
)
314 :for poll-timeout
:= (poll-timeout now
)
315 :until
(must-exit-loop-p) :do
316 (setf expired-events nil
)
317 (setf (values eventsp deletion-list
)
318 (dispatch-fd-events-once event-base poll-timeout now
))
319 (%remove-handlers event-base
(delete nil deletion-list
))
320 (when (expire-pending-timers fd-timers now
) (setf eventsp t
))
321 (dispatch-fd-timeouts expired-events
)
322 (when (expire-pending-timers timers now
) (setf eventsp t
))
323 (when (and eventsp one-shot
) (setf exit-p t
))))))
325 (defun %remove-handlers
(event-base event-list
)
326 (loop :for ev
:in event-list
327 :for fd
:= (fd-handler-fd ev
)
328 :for fd-entry
:= (fd-entry-of event-base fd
)
329 :do
(%remove-io-handler event-base fd fd-entry ev
)))
331 ;;; Waits for events and dispatches them. Returns T if some events
332 ;;; have been received, NIL otherwise.
333 (defun dispatch-fd-events-once (event-base timeout now
)
334 (let ((wthreshold (write-interval-threshold-of event-base
)))
336 :with fd-events
:= (harvest-events (mux-of event-base
) timeout
)
337 :for ev
:in fd-events
338 :for dlist
:= (%handle-one-fd event-base ev now nil wthreshold
)
339 :then
(%handle-one-fd event-base ev now dlist wthreshold
)
341 (priority-queue-reorder (fd-timers-of event-base
))
342 (return (values (consp fd-events
) dlist
)))))
344 (defun %handle-one-fd
(event-base event now deletion-list wthreshold
)
345 (destructuring-bind (fd ev-types
) event
346 (let* ((readp nil
) (writep nil
)
347 (fd-entry (fd-entry-of event-base fd
))
348 (errorp (and fd-entry
(member :error ev-types
))))
350 (when (member :read ev-types
)
351 (setf readp
(%dispatch-event fd-entry
:read
352 (if errorp
:error nil
) now
)))
353 (when (member :write ev-types
)
354 (when (<= wthreshold
(- now
(fd-entry-write-ts fd-entry
)))
356 (setf writep
(%dispatch-event fd-entry
:write
357 (if errorp
:error nil
) now
))
358 (setf (fd-entry-write-ts fd-entry
) now
))))
360 (when-let ((callback (fd-entry-error-callback fd-entry
)))
361 (funcall callback
(fd-entry-fd fd-entry
) :error
))
362 (setf readp t writep t
))
363 (when readp
(push (fd-entry-read-handler fd-entry
) deletion-list
))
364 (when writep
(push (fd-entry-write-handler fd-entry
) deletion-list
)))
365 (values deletion-list
))))
367 (defun %dispatch-event
(fd-entry event-type errorp now
)
368 (let ((ev (fd-entry-handler fd-entry event-type
)))
370 (funcall (fd-handler-callback ev
)
371 (fd-entry-fd fd-entry
)
373 (if errorp
:error nil
))
374 (when-let (timer (fd-handler-timer ev
))
375 (reschedule-timer-relative-to-now timer now
))
376 (fd-handler-one-shot-p ev
))))
378 (defun dispatch-fd-timeouts (events)
380 (funcall (fd-handler-callback ev
)