1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; common.lisp --- Miscellaneous definitions.
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 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 (defvar *available-multiplexers
* nil
)
28 (defvar *best-available-multiplexer
* nil
))
30 (defvar *maximum-event-loop-timeout
* 1)
34 (defclass event-base
()
35 ((mux :initform
(make-instance *best-available-multiplexer
*)
36 :initarg
:mux
:reader mux-of
)
37 (fds :initform
(make-hash-table :test
'eql
)
39 (timeouts :initform
(make-queue)
43 (exit-when-empty :initarg
:exit-when-empty
44 :accessor exit-when-empty-p
))
45 (:default-initargs
:exit-when-empty nil
)
46 (:documentation
"An event base ..."))
48 (defmethod print-object ((base event-base
) stream
)
49 (print-unreadable-object (base stream
:type nil
:identity t
)
50 (format stream
"event base, ~A FDs monitored, using: ~A"
51 ;; kludge: quick fix for printing closed event bases
52 (when (fds-of base
) (hash-table-count (fds-of base
)))
55 (defmethod initialize-instance :after
((base event-base
) &key
)
56 (with-slots (mux) base
58 (setq mux
(make-instance mux
)))))
60 ;;; KLUDGE: CLOSE is for streams. --luis
62 ;;; Also, we might want to close FDs here. Or have a version/argument
63 ;;; that handles that. Or... add finalizers to the fd streams.
64 (defmethod close ((event-base event-base
) &key abort
)
65 (declare (ignore abort
))
66 (with-accessors ((mux mux-of
)) event-base
67 (close-multiplexer mux
)
68 (dolist (slot '(fds timeouts exit
))
69 (setf (slot-value event-base slot
) nil
))
72 (defgeneric add-fd
(base fd event-type function
&key timeout persistent
)
75 (defgeneric add-timeout
(event-base function timeout
&key persistent
)
78 (defgeneric remove-event
(event-base event
)
81 (defgeneric remove-events
(event-base event-list
)
84 (defgeneric event-dispatch
(event-base &key
&allow-other-keys
)
87 (defgeneric exit-event-loop
(event-base &key delay
)
89 (:method
((event-base event-base
) &key
(delay 0))
90 (add-timeout event-base
91 #'(lambda (fd event-type
)
92 (declare (ignore fd event-type
))
93 (setf (exit-p event-base
) t
))
94 delay
:persistent nil
)))
96 (defgeneric event-base-empty-p
(event-base)
98 (:method
((event-base event-base
))
99 (and (zerop (hash-table-count (fds-of event-base
)))
100 (queue-empty-p (timeouts-of event-base
)))))
102 (defgeneric fd-entry-of
(event-base fd
)
104 (:method
((event-base event-base
) fd
)
105 (gethash fd
(fds-of event-base
))))
107 (defun %add-event
(event-base event
&optional fd-entry
)
108 (with-accessors ((fds fds-of
) (timeouts timeouts-of
)) event-base
109 (when (event-timeout event
)
110 ;; add the event to the timeout queue
111 (queue-sorted-insert timeouts event
#'< #'event-abs-timeout
))
112 (let ((fd (event-fd event
)))
113 ;; if it's an FD event add it to its fd-entry int the FDs hash-table
114 ;; if there's no such fd-entry, create it
116 (fd-entry-add-event fd-entry event
)
117 (setf (gethash fd fds
) fd-entry
))
120 (defun %remove-event
(event-base event
)
121 (with-accessors ((fds fds-of
) (timeouts timeouts-of
)) event-base
122 (when (event-timeout event
)
123 ;; remove the event from the timeout queue
124 (queue-delete timeouts event
))
125 (let ((fd (event-fd event
)))
126 ;; if it's an FD event remove it from its fd-entry
127 ;; if the fd-emtry is then empty, remove it
129 (let ((fd-entry (gethash fd fds
)))
131 (fd-entry-del-event fd-entry event
)
132 (when (fd-entry-empty-p fd-entry
)
136 (defun calc-possible-edge-change-when-adding (fd-entry event-type
)
137 (cond ((and (eql event-type
:read
)
138 (queue-empty-p (fd-entry-read-events fd-entry
)))
140 ((and (eql event-type
:write
)
141 (queue-empty-p (fd-entry-write-events fd-entry
)))
144 (defmethod add-fd ((event-base event-base
) fd event-type function
145 &key timeout persistent
)
146 (check-type fd unsigned-byte
)
147 (check-type event-type fd-event
)
148 (let ((fd-limit (fd-limit-of (mux-of event-base
))))
149 (when (and fd-limit
(> fd fd-limit
))
150 (error "Cannot add such a large FD: ~A" fd
)))
151 (let ((current-entry (fd-entry-of event-base fd
))
152 (event (make-event fd event-type function persistent
153 (abs-timeout timeout
)
154 (normalize-timeout timeout
)))
158 (setf edge-change
(calc-possible-edge-change-when-adding
159 current-entry event-type
))
160 (%add-event event-base event current-entry
)
162 (setf (fd-entry-edge-change current-entry
) edge-change
)
163 (update-fd (mux-of event-base
) current-entry
)
164 (setf (fd-entry-edge-change current-entry
) nil
)))
166 (setf current-entry
(make-fd-entry fd
))
167 (%add-event event-base event current-entry
)
168 (unless (monitor-fd (mux-of event-base
) current-entry
)
169 (%remove-event event-base event
))))
172 (defmethod add-timeout ((event-base event-base
) function timeout
175 (%add-event event-base
(make-event nil
:timeout function persistent
176 (abs-timeout timeout
)
177 (normalize-timeout timeout
))))
179 (defun calc-possible-edge-change-when-removing (fd-entry event-type
)
180 (cond ((and (eql event-type
:read
)
181 (not (queue-empty-p (fd-entry-read-events fd-entry
))))
183 ((and (eql event-type
:write
)
184 (not (queue-empty-p (fd-entry-write-events fd-entry
))))
187 (defmethod remove-event ((event-base event-base
) event
)
188 (check-type (event-type event
) event-type
)
189 (let* ((fd (event-fd event
))
190 (current-entry (fd-entry-of event-base fd
))
194 (setf edge-change
(calc-possible-edge-change-when-removing
195 current-entry
(event-type event
)))
196 (%remove-event event-base event
)
197 (if (fd-entry-empty-p current-entry
)
198 (unmonitor-fd (mux-of event-base
) current-entry
)
200 (setf (fd-entry-edge-change current-entry
) edge-change
)
201 (update-fd (mux-of event-base
) current-entry
)
202 (setf (fd-entry-edge-change current-entry
) nil
))))
203 (%remove-event event-base event
)))
206 (defmacro with-fd-handler
((event-base fd event-type function
&optional timeout
)
209 (once-only (event-base)
210 (with-unique-names (event)
214 (setf ,event
(add-fd ,event-base
,fd
,event-type
,function
219 (remove-event ,event-base
,event
)))))))
221 (defmethod event-dispatch :around
((event-base event-base
)
222 &key timeout only-once
)
223 (setf (exit-p event-base
) nil
)
225 (exit-event-loop event-base
:delay timeout
))
226 (call-next-method event-base
:only-once only-once
))
228 (defun recalculate-timeouts (timeouts)
229 (let ((now (osicat:get-monotonic-time
)))
230 (dolist (ev (queue-head timeouts
))
231 (event-recalc-abs-timeout ev now
))))
233 (defun dispatch-timeouts (dispatch-list)
234 (dolist (ev dispatch-list
)
235 (funcall (event-handler ev
) nil
:timeout
)))
237 (defmethod remove-events ((event-base event-base
) event-list
)
238 (dolist (ev event-list
)
239 (remove-event event-base ev
)))
241 (defmethod event-dispatch ((event-base event-base
) &key only-once
)
242 (with-accessors ((mux mux-of
) (fds fds-of
)
243 (exit-p exit-p
) (exit-when-empty exit-when-empty-p
)
244 (timeouts timeouts-of
)) event-base
245 (flet ((recalc-poll-timeout ()
246 (calc-min-timeout (events-calc-min-rel-timeout timeouts
)
247 *maximum-event-loop-timeout
*)))
248 (do ((poll-timeout (recalc-poll-timeout) (recalc-poll-timeout))
249 (deletion-list () ())
250 (dispatch-list () ()))
251 ((or exit-p
(and exit-when-empty
(event-base-empty-p event-base
))))
252 (recalculate-timeouts timeouts
)
253 (when (dispatch-fd-events-once event-base poll-timeout
)
254 (and only-once
(setf exit-p t
)))
255 (setf (values deletion-list dispatch-list
)
256 (filter-expired-events
257 (expired-events timeouts
(osicat:get-monotonic-time
))))
258 (dispatch-timeouts dispatch-list
)
259 (remove-events event-base deletion-list
)
260 (queue-sort timeouts
#'< #'event-abs-timeout
)))))
262 ;;; Waits for events and dispatches them. Returns T if some events
263 ;;; have been received, NIL otherwise.
264 (defun dispatch-fd-events-once (event-base timeout
)
265 (with-accessors ((mux mux-of
) (fds fds-of
) (timeouts timeouts-of
))
267 (let ((deletion-list ())
268 (fd-events (harvest-events mux timeout
)))
269 (dolist (ev fd-events
)
270 (destructuring-bind (fd ev-types
) ev
271 (let ((fd-entry (fd-entry-of event-base fd
)))
273 (let ((errorp (member :error ev-types
)))
275 (dispatch-error-events fd-entry
)
276 (nconcf deletion-list
277 (fd-entry-all-events fd-entry
)))
278 (when (member :read ev-types
)
279 (dispatch-read-events fd-entry
)
281 (nconcf deletion-list
282 (fd-entry-one-shot-events fd-entry
:read
))))
283 (when (member :write ev-types
)
284 (dispatch-write-events fd-entry
)
286 (nconcf deletion-list
287 (fd-entry-one-shot-events fd-entry
:write
)))))
288 (warn "Got spurious event for non-monitored FD: ~A" fd
)))))
289 (dolist (ev deletion-list
)
290 (remove-event event-base ev
))
293 (defun expired-events (queue now
)
295 #'(lambda (to) (and to
(<= to now
)))
296 #'event-abs-timeout
))
298 (defun filter-expired-events (events)
299 (let ((deletion-list ())
302 (push ev dispatch-list
)
303 (unless (event-persistent-p ev
)
304 (push ev deletion-list
)))
305 (values deletion-list dispatch-list
)))
307 (defun events-calc-min-rel-timeout (timeouts)
308 (let* ((now (osicat:get-monotonic-time
))
309 (first-valid-event (find-if #'(lambda (to)
310 (or (null to
) (< now to
)))
311 (queue-head timeouts
)
312 :key
#'event-abs-timeout
)))
313 (when (and first-valid-event
314 (event-abs-timeout first-valid-event
))
315 (- (event-abs-timeout first-valid-event
) now
))))
317 (defun dispatch-error-events (fd-entry)
318 (dolist (ev (queue-head (fd-entry-error-events fd-entry
)))
319 (funcall (event-handler ev
) (fd-entry-fd fd-entry
) :error
)))
321 (defun dispatch-read-events (fd-entry)
322 (dolist (ev (queue-head (fd-entry-read-events fd-entry
)))
323 (funcall (event-handler ev
) (fd-entry-fd fd-entry
) :read
)))
325 (defun dispatch-write-events (fd-entry)
326 (dolist (ev (queue-head (fd-entry-write-events fd-entry
)))
327 (funcall (event-handler ev
) (fd-entry-fd fd-entry
) :write
)))
332 '(member :read
:write
:error
))
334 (deftype event-type
()
335 '(or fd-event
(member :timeout
)))
337 (defstruct (fd-entry (:constructor make-fd-entry
(fd))
339 (fd 0 :type unsigned-byte
)
340 (edge-change nil
:type symbol
)
341 (read-events (make-queue) :type queue
)
342 (write-events (make-queue) :type queue
)
343 (error-events (make-queue) :type queue
))
345 (defun fd-entry-event-list (fd-entry event-type
)
346 (check-type fd-entry fd-entry
)
347 (check-type event-type fd-event
)
349 (:read
(fd-entry-read-events fd-entry
))
350 (:write
(fd-entry-write-events fd-entry
))
351 (:error
(fd-entry-error-events fd-entry
))))
353 (defun (setf fd-entry-event-list
) (fd-entry event-list event-type
)
354 (check-type fd-entry fd-entry
)
355 (check-type event-type fd-event
)
357 (:read
(setf (fd-entry-read-events fd-entry
) event-list
))
358 (:write
(setf (fd-entry-write-events fd-entry
) event-list
))
359 (:error
(setf (fd-entry-error-events fd-entry
) event-list
))))
361 (defun fd-entry-empty-p (fd-entry)
362 (and (queue-empty-p (fd-entry-read-events fd-entry
))
363 (queue-empty-p (fd-entry-write-events fd-entry
))
364 (queue-empty-p (fd-entry-error-events fd-entry
))))
366 (defun fd-entry-add-event (fd-entry event
)
367 (queue-enqueue (fd-entry-event-list fd-entry
(event-type event
))
370 (defun fd-entry-del-event (fd-entry event
)
371 (queue-delete (fd-entry-event-list fd-entry
(event-type event
))
374 (defun fd-entry-all-events (fd-entry)
375 (append (queue-head (fd-entry-read-events fd-entry
))
376 (queue-head (fd-entry-write-events fd-entry
))
377 (queue-head (fd-entry-error-events fd-entry
))))
379 (defun fd-entry-one-shot-events (fd-entry event-type
)
380 (remove-if #'event-persistent-p
381 (queue-head (fd-entry-event-list fd-entry event-type
))))
385 (defstruct (event (:constructor make-event
(fd type handler persistent-p
386 abs-timeout timeout
))
388 ;; a file descriptor or nil in case of a timeout
389 (fd nil
:type
(or null unsigned-byte
))
390 (type nil
:type
(or null event-type
))
391 (handler nil
:type
(or null function
))
392 ;; if an event is not persistent it is removed
393 ;; after it occurs or if it times out
394 (persistent-p nil
:type boolean
)
395 (abs-timeout nil
:type
(or null timeout
))
396 (timeout nil
:type
(or null timeout
)))
398 (defun event-timed-out-p (event timeout
)
399 (let ((ev-to (event-abs-timeout event
)))
400 (when (and ev-to timeout
)
403 (defun event-recalc-abs-timeout (event now
)
404 (setf (event-abs-timeout event
)
405 (+ now
(event-timeout event
))))
410 (defcfun ("_getmaxstdio" get-fd-limit
) :int
)
413 (defun get-fd-limit ()
414 (let ((fd-limit (nix:getrlimit nix
::rlimit-nofile
)))
415 (unless (eql fd-limit nix
::rlim-infinity
)
418 (defclass multiplexer
()
420 (fd-limit :initform
(get-fd-limit)
422 :reader fd-limit-of
)))
424 (defgeneric monitor-fd
(mux fd-entry
)
425 (:method
((mux multiplexer
) fd-entry
)
426 (declare (ignore fd-entry
))
429 (defgeneric update-fd
(mux fd-entry
)
430 (:method
((mux multiplexer
) fd-entry
)
431 (declare (ignore fd-entry
))
434 (defgeneric unmonitor-fd
(mux fd-entry
)
435 (:method
((mux multiplexer
) fd-entry
)
436 (declare (ignore fd-entry
))
439 ;;; Returns a list of fd/result pairs which have one of these forms:
442 ;;; (fd (:read :write))
444 (defgeneric harvest-events
(mux timeout
))
446 (defgeneric close-multiplexer
(mux)
447 (:method-combination progn
:most-specific-last
)
448 (:method progn
((mux multiplexer
))
449 (when (slot-value mux
'fd
)
450 (nix:close
(fd-of mux
))
451 (setf (slot-value mux
'fd
) nil
))
454 (defmethod monitor-fd :around
((mux multiplexer
) fd-entry
)
455 (if (ignore-and-print-errors (call-next-method))
457 (warn "FD monitoring failed for FD ~A."
458 (fd-entry-fd fd-entry
))))
460 (defmethod update-fd :around
((mux multiplexer
) fd-entry
)
461 (if (ignore-and-print-errors (call-next-method))
463 (warn "FD status update failed for FD ~A."
464 (fd-entry-fd fd-entry
))))
466 (defmethod unmonitor-fd :around
((mux multiplexer
) fd-entry
)
467 (if (ignore-and-print-errors (call-next-method))
469 (warn "FD unmonitoring failed for FD ~A."
470 (fd-entry-fd fd-entry
))))
472 (defmacro define-multiplexer
(name priority superclasses slots
&rest options
)
474 (defclass ,name
,superclasses
,slots
,@options
)
475 (pushnew (cons ,priority
',name
)
476 *available-multiplexers
*)))
480 ;;; FIXME: Until a way to autodetect platform features is implemented
482 (defconstant nix
::pollrdhup
0)
484 (define-condition poll-error
(error)
485 ((fd :initarg
:fd
:reader poll-error-fd
)
486 (identifier :initarg
:identifier
:initform
"<Unknown error>"
487 :reader poll-error-identifier
))
488 (:report
(lambda (condition stream
)
489 (format stream
"Error caught while polling file descriptor ~A: ~A"
490 (poll-error-fd condition
)
491 (poll-error-identifier condition
))))
493 "Signaled when an error occurs while polling for I/O readiness
494 of a file descriptor."))
496 ;;; This should probably be moved elsewhere. Also, it's quite a mess.
499 (load-foreign-library "User32.dll")
500 (load-foreign-library "msvcrt.dll")
501 (load-foreign-library "Ws2_32.dll")
503 (defctype dword
:unsigned-long
)
504 (defctype bool
(:boolean
:int
))
506 (cl-posix-ffi:defsyscall
"get_osfhandle" :long
509 (defconstant +wait-failed
+ #xffffffff
)
510 (defconstant +wait-abandoned
+ #x80
)
511 (defconstant +wait-object-0
+ 0)
512 (defconstant +wait-timeout
+ #x102
)
513 (defconstant +true
+ 1)
514 (defconstant +fd-read
+ 1)
515 (defconstant +fd-write
+ 2)
516 (defconstant +socket-error
+ -
1)
517 (defconstant +wsaenotsock
+ 10038)
519 (defcfun ("MsgWaitForMultipleObjects" %wait
:cconv
:stdcall
) dword
525 (defcfun ("WSAGetLastError" wsa-get-last-error
:cconv
:stdcall
) :int
)
527 (defcfun ("WSAEventSelect" wsa-event-select
:cconv
:stdcall
) :int
532 (defcfun ("WSACreateEvent" wsa-create-event
:cconv
:stdcall
) :int
)
534 (defcfun ("WSACloseEvent" wsa-close-event
:cconv
:stdcall
) bool
537 ;; this one is probably completely broken
538 (defun %wait-for-single-object
(handle timeout
)
539 (let ((ret (with-foreign-object (phandle :int
)
540 (setf (mem-ref phandle
:int
) handle
)
541 (%wait
1 phandle t
(timeout->milisec timeout
)))))
542 (when (or (eql ret
+wait-failed
+)
543 (eql ret
+wait-abandoned
+))
545 (let ((ready (= ret
+wait-object-0
+)))
547 (values ready ready
))))
549 ;; wasn't handling :read-write properly so won't pretend to support it
550 (defun %wait-until-fd-ready
(fd event-type timeout
)
551 (let ((handle (get-osfhandle fd
))
552 (ev (wsa-create-event)))
554 (let ((ret (wsa-event-select handle ev
(ecase event-type
556 (:write
+fd-write
+)))))
557 (if (eql ret
+socket-error
+)
558 (if (= (wsa-get-last-error) +wsaenotsock
+)
559 (wait-for-multiple-objects handle timeout
)
560 (error 'poll-error
:fd fd
))
561 (let ((ret (%wait-for-single-object ev timeout
)))
563 (:read
(values ret nil
))
564 (:write
(values nil ret
))))))
565 (wsa-close-event ev
)))))
568 (defun %wait-until-fd-ready
(fd event-type timeout
)
569 (flet ((choose-poll-flags (type)
571 (:read
(logior nix
::pollin nix
::pollrdhup nix
::pollpri
))
572 (:write
(logior nix
::pollout nix
::pollhup
))
573 (:read-write
(logior nix
::pollin nix
::pollrdhup nix
::pollpri
574 nix
::pollout nix
::pollhup
))))
575 (poll-error (unix-err)
576 (error 'poll-error
:fd fd
577 :identifier
(osicat-sys:system-error-identifier unix-err
))))
578 (let ((readp nil
) (writep nil
))
579 (with-foreign-object (pollfd 'nix
::pollfd
)
580 (nix:bzero pollfd nix
::size-of-pollfd
)
581 (with-foreign-slots ((nix::fd nix
::events nix
::revents
)
584 nix
::events
(choose-poll-flags event-type
))
586 (let ((ret (nix:repeat-upon-condition-decreasing-timeout
587 ((nix:eintr
) tmp-timeout timeout
)
588 (nix:poll pollfd
1 (timeout->milisec timeout
)))))
590 (return-from %wait-until-fd-ready
(values nil nil
))))
591 (nix:posix-error
(err) (poll-error err
)))
592 (flags-case nix
::revents
593 ((nix::pollin nix
::pollrdhup nix
::pollpri
)
595 ((nix::pollout nix
::pollhup
) (setf writep t
))
596 ((nix::pollerr nix
::pollnval
) (error 'poll-error
:fd fd
)))
597 (values readp writep
))))))
599 (defun wait-until-fd-ready (fd event-type
&optional timeout
)
600 "Poll file descriptor `FD' for I/O readiness. `EVENT-TYPE' must be
601 :READ, :WRITE or :READ-WRITE which means \"either :READ or :WRITE\".
602 `TIMEOUT' must be either a non-negative integer measured in seconds,
603 or `NIL' meaning no timeout at all."
604 (%wait-until-fd-ready fd event-type timeout
))
606 (defun fd-ready-p (fd &optional
(event-type :read
))
607 "Tests file-descriptor `FD' for I/O readiness. `EVENT-TYPE'
608 must be :READ, :WRITE or :READ-WRITE which means \"either :READ
610 (multiple-value-bind (readp writep
)
611 (wait-until-fd-ready fd event-type
0)
615 (:read-write
(or readp writep
)))))
617 (defun fd-readablep (fd)
618 (nth-value 0 (wait-until-fd-ready fd
:read
0)))
620 (defun fd-writablep (fd)
621 (nth-value 1 (wait-until-fd-ready fd
:write
0)))