io.multiplex/epoll.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- epoll(2) multiplexer implementation.
   4 ;;;
   5
   6 (in-package :io.multiplex)
   7
   8 (defconstant +epoll-priority+ 1)
   9
  10 (define-multiplexer epoll-multiplexer +epoll-priority+ (multiplexer)
  11   ())
  12
  13 (defmethod print-object ((mux epoll-multiplexer) stream)
  14   (print-unreadable-object (mux stream :type nil :identity nil)
  15     (format stream "epoll(4) multiplexer")))
  16
  17 (defconstant +epoll-default-size-hint+ 25)
  18 (defconstant +epoll-max-events+ 1024)
  19
  20 (defmethod initialize-instance :after ((mux epoll-multiplexer)
  21                                        &key (size +epoll-default-size-hint+))
  22   (setf (slot-value mux 'fd) (epoll-create size)))
  23
  24 (defun calc-epoll-flags (fd-entry)
  25   (logior (if (fd-entry-read-event fd-entry)
  26               epollin 0)
  27           (if (fd-entry-write-event fd-entry)
  28               epollout 0)
  29           epollpri))
  30
  31 (defmethod monitor-fd ((mux epoll-multiplexer) fd-entry)
  32   (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!")
  33   (let ((flags (calc-epoll-flags fd-entry))
  34         (fd (fd-entry-fd fd-entry)))
  35     (with-foreign-object (ev 'epoll-event)
  36       (bzero ev size-of-epoll-event)
  37       (setf (foreign-slot-value ev 'epoll-event 'events) flags)
  38       (setf (foreign-slot-value
  39              (foreign-slot-value ev 'epoll-event 'data) 'epoll-data 'fd)
  40             fd)
  41       (handler-case
  42           (epoll-ctl (fd-of mux) epoll-ctl-add fd ev)
  43         (nix:ebadf ()
  44           (warn "FD ~A is invalid, cannot monitor it." fd))
  45         (nix:eexist ()
  46           (warn "FD ~A is already monitored." fd))))))
  47
  48 (defmethod update-fd ((mux epoll-multiplexer) fd-entry event-type edge-change)
  49   (declare (ignore event-type edge-change))
  50   (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!")
  51   (let ((flags (calc-epoll-flags fd-entry))
  52         (fd (fd-entry-fd fd-entry)))
  53     (with-foreign-object (ev 'epoll-event)
  54       (bzero ev size-of-epoll-event)
  55       (setf (foreign-slot-value ev 'epoll-event 'events) flags)
  56       (setf (foreign-slot-value
  57              (foreign-slot-value ev 'epoll-event 'data) 'epoll-data 'fd)
  58             fd)
  59       (handler-case
  60           (epoll-ctl (fd-of mux) epoll-ctl-mod fd ev)
  61         (nix:ebadf ()
  62           (warn "FD ~A is invalid, cannot update its status." fd))
  63         (nix:enoent ()
  64           (warn "FD ~A was not monitored, cannot update its status." fd))))
  65     (values fd-entry)))
  66
  67 (defmethod unmonitor-fd ((mux epoll-multiplexer) fd-entry)
  68   (handler-case
  69       (epoll-ctl (fd-of mux)
  70                  epoll-ctl-del
  71                  (fd-entry-fd fd-entry)
  72                  (null-pointer))
  73     (nix:ebadf ()
  74       (warn "FD ~A is invalid, cannot unmonitor it." (fd-entry-fd fd-entry)))
  75     (nix:enoent ()
  76       (warn "FD ~A was not monitored, cannot unmonitor it."
  77             (fd-entry-fd fd-entry)))))
  78
  79 (defmethod harvest-events ((mux epoll-multiplexer) timeout)
  80   (with-foreign-object (events 'epoll-event +epoll-max-events+)
  81     (bzero events (* +epoll-max-events+ size-of-epoll-event))
  82     (let (ready-fds)
  83       (nix:repeat-upon-condition-decreasing-timeout
  84           ((nix:eintr) tmp-timeout timeout)
  85         (setf ready-fds (epoll-wait (fd-of mux) events +epoll-max-events+
  86                                     (timeout->milisec tmp-timeout))))
  87       (macrolet ((epoll-slot (slot-name)
  88                    `(foreign-slot-value (mem-aref events 'epoll-event i)
  89                                         'epoll-event ',slot-name)))
  90         (return-from harvest-events
  91           (loop :for i :below ready-fds
  92                 :for fd := (foreign-slot-value (epoll-slot data) 'epoll-data 'fd)
  93                 :for event-mask := (epoll-slot events)
  94                 :for epoll-event := (make-epoll-event fd event-mask)
  95                 :when epoll-event :collect epoll-event))))))
  96
  97 (defun make-epoll-event (fd mask)
  98   (let ((event ()))
  99     (flags-case mask
 100       ((epollout epollhup)
 101        (push :write event))
 102       ((epollin epollpri epollhup)
 103        (push :read event))
 104       (epollerr
 105        (push :error event)))
 106     (when event
 107       (list fd event))))