io-multiplex/epoll.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :io.multiplex)
  23
  24 (defconstant +epoll-priority+ 1)
  25
  26 (define-multiplexer epoll-multiplexer +epoll-priority+ (multiplexer)
  27   ())
  28
  29 (defmethod print-object ((mux epoll-multiplexer) stream)
  30   (print-unreadable-object (mux stream :type nil :identity nil)
  31     (format stream "epoll(4) multiplexer")))
  32
  33 (defconstant +epoll-default-size-hint+ 25)
  34 (defvar *epoll-max-events* 200)
  35
  36 (defmethod initialize-instance :after ((mux epoll-multiplexer)
  37                                        &key (size +epoll-default-size-hint+))
  38   (setf (slot-value mux 'fd) (et:epoll-create size)))
  39
  40 (defun calc-epoll-flags (fd-entry)
  41   (logior (if (not (queue-empty-p (fd-entry-read-events fd-entry))) et:epollin 0)
  42           (if (not (queue-empty-p (fd-entry-write-events fd-entry))) et:epollout 0)
  43           et:epollpri))
  44
  45 (defmethod monitor-fd ((mux epoll-multiplexer) fd-entry)
  46   (assert fd-entry)
  47   (let ((flags (calc-epoll-flags fd-entry))
  48         (fd (fd-entry-fd fd-entry)))
  49     (with-foreign-object (ev 'et:epoll-event)
  50       (et:memset ev 0 et:size-of-epoll-event)
  51       (setf (foreign-slot-value ev 'et:epoll-event 'et:events) flags)
  52       (setf (foreign-slot-value (foreign-slot-value ev 'et:epoll-event 'et:data)
  53                                 'et:epoll-data 'et:fd)
  54             fd)
  55       (handler-case
  56           (et:epoll-ctl (fd-of mux) et:epoll-ctl-add fd ev)
  57         (et:ebadf ()
  58           (warn "FD ~A is invalid, cannot monitor it." fd))
  59         (et:eexist ()
  60           (warn "FD ~A is already monitored." fd))))))
  61
  62 (defmethod update-fd ((mux epoll-multiplexer) fd-entry)
  63   (assert fd-entry)
  64   (let ((flags (calc-epoll-flags fd-entry))
  65         (fd (fd-entry-fd fd-entry)))
  66     (with-foreign-object (ev 'et:epoll-event)
  67       (et:memset ev 0 et:size-of-epoll-event)
  68       (setf (foreign-slot-value ev 'et:epoll-event 'et:events) flags)
  69       (setf (foreign-slot-value (foreign-slot-value ev 'et:epoll-event 'et:data)
  70                                 'et:epoll-data 'et:fd)
  71             fd)
  72       (handler-case
  73           (et:epoll-ctl (fd-of mux) et:epoll-ctl-mod fd ev)
  74         (et:ebadf ()
  75           (warn "FD ~A is invalid, cannot update its status." fd))
  76         (et:enoent ()
  77           (warn "FD ~A was not monitored, cannot update its status." fd))))
  78     (values fd-entry)))
  79
  80 (defmethod unmonitor-fd ((mux epoll-multiplexer) fd-entry)
  81   (handler-case
  82       (et:epoll-ctl (fd-of mux)
  83                     et:epoll-ctl-del
  84                     (fd-entry-fd fd-entry)
  85                     (null-pointer))
  86     (et:ebadf ()
  87       (warn "FD ~A is invalid, cannot unmonitor it." (fd-entry-fd fd-entry)))
  88     (et:enoent ()
  89       (warn "FD ~A was not monitored, cannot unmonitor it." (fd-entry-fd fd-entry)))))
  90
  91 (defmethod harvest-events ((mux epoll-multiplexer) timeout)
  92   (with-foreign-object (events 'et:epoll-event *epoll-max-events*)
  93     (et:memset events 0 (* *epoll-max-events* et:size-of-epoll-event))
  94     (let (ready-fds)
  95       (et:repeat-upon-condition-decreasing-timeout ((et:eintr)
  96                                                     tmp-timeout timeout)
  97         (setf ready-fds
  98               (et:epoll-wait (fd-of mux) events
  99                              *epoll-max-events*
 100                              (timeout->milisec tmp-timeout))))
 101       (macrolet ((epoll-slot (slot-name)
 102                    `(foreign-slot-value (mem-aref events 'et:epoll-event i)
 103                                         'et:epoll-event ',slot-name)))
 104         (return-from harvest-events
 105           (loop
 106              :for i :below ready-fds
 107              :for fd := (foreign-slot-value (epoll-slot et:data) 'et:epoll-data 'et:fd)
 108              :for event-mask := (epoll-slot et:events)
 109              :for epoll-event := (make-epoll-event fd event-mask)
 110              :when epoll-event :collect epoll-event))))))
 111
 112 (defun make-epoll-event (fd mask)
 113   (let ((event ()))
 114     (flags-case mask
 115       ((et:epollout et:epollhup)
 116        (push :write event))
 117       ((et:epollin et:epollpri et:epollhup)
 118        (push :read event))
 119       (et:epollerr
 120        (push :error event)))
 121     (when event
 122       (list fd event))))