Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
127 lines (106 sloc) 4.11 KB
(in-package #:tpd2.io)
(defstruct (epoll (:include mux) (:constructor %make-epoll))
fd
events
postpone-registration
postponed-registrations)
(my-defun epoll max-events ()
1024)
(my-defun epoll init ()
(assert (not (my fd)))
(let ((fd (syscall-epoll_create 10)))
(setf (my fd) fd)
(finalize me (lambda() (ignore-errors (syscall-close fd))))
(let ((events-mem (cffi:foreign-alloc 'epoll-event :count (my max-events))))
(setf (my events) events-mem)
(cancel-finalization me)
(finalize me
(lambda()
(ignore-errors (syscall-close fd))
(ignore-errors
(cffi:foreign-free events-mem)))))))
(defun make-epoll ()
(let ((e (%make-epoll)))
(epoll-init e)
e))
(my-defun epoll ctl (ctl fd-wanted events-wanted)
(with-foreign-object-and-slots ((events data) event epoll-event)
(setf events
(logior
events-wanted
+POLLHUP+
+POLLERR+))
(cffi:with-foreign-slots ((fd) data epoll-data)
(setf fd fd-wanted))
(syscall-epoll_ctl (my fd) ctl fd-wanted event))
(values))
(my-defun epoll handle-postponed-registrations ()
(assert (not (my postpone-registration)))
(loop for (fd . con) in (my postponed-registrations) do
(my 'mux-add fd con))
(setf (my postponed-registrations) nil))
(my-defun epoll wait (timeout)
(debug-assert (not (my postponed-registrations)) (me (my postponed-registrations) (my postpone-registration)))
(setf (my postpone-registration) t)
(let ((nevents
(syscall-retry-epoll_wait (my fd) (my events) (my max-events)
(if timeout
(floor (* 1000 timeout))
-1))))
(debug-assert (>= (my max-events) nevents) (me nevents))
(loop repeat nevents
for event = (my events) then (cffi:inc-pointer event (cffi:foreign-type-size '(:struct epoll-event)))
do
(cffi:with-foreign-slots ((events data) event epoll-event)
(cffi:with-foreign-slots ((fd) data epoll-data)
(awhen (my 'mux-find-fd fd)
(unless (zerop (logand (logior +POLLIN+ +POLLOUT+) events))
(con-run it))
(unless (and (zerop (logand (logior +POLLERR+ +POLLHUP+) events))
(or (zerop (logand +POLLRDHUP+ events))
(not (zerop (logand +POLLIN+ events)))))
(con-fail it))))))
(debug-assert (my postpone-registration))
(setf (my postpone-registration) nil)
(my handle-postponed-registrations)
(not (zerop nevents))))
(defvar *epoll* (make-epoll))
(defun register-fd (fd events con)
(with-shorthand-accessor (my epoll *epoll*)
(cond ((my 'mux-find-fd fd)
(debug-assert (eq con (my 'mux-find-fd fd)) (*epoll* con fd))
(my ctl +EPOLL_CTL_MOD+ fd events))
(t
(if (my postpone-registration)
(push (cons fd con) (my postponed-registrations))
(my 'mux-add fd con))
(my ctl +EPOLL_CTL_ADD+ fd events)))))
(defun deregister-fd (fd)
(declare (optimize speed))
(with-shorthand-accessor (my epoll *epoll*)
(my 'mux-del fd)))
(defun-speedy events-pending-p ()
(not (mux-empty *epoll*)))
(defun wait-for-next-event (&optional timeout)
(with-shorthand-accessor (my epoll *epoll*)
(my wait timeout)))
(defun event-loop ()
(setf (epoll-postpone-registration *epoll*) nil)
(epoll-handle-postponed-registrations *epoll*)
(loop for timeout = (next-timeout)
while (or timeout (events-pending-p)) do
(wait-for-next-event timeout)
(let ((start-time (get-timeout-time)))
(loop do (wait-for-next-event 1)
thereis (/= start-time (get-timeout-time))))))
(defun event-loop-reset ()
(setf (epoll-postpone-registration *epoll*) nil)
(epoll-handle-postponed-registrations *epoll*)
(mux-close-all *epoll*)
(forget-timeouts)
(setf *epoll*
(make-epoll)))
(defmacro with-independent-event-loop (() &body body)
`(with-independent-timeouts ()
(let ((*epoll* (make-epoll)) (*recvbufs* nil))
,@body)))