io-multiplex/kqueue.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; kqueue.lisp --- kequeue multiplexer implementation.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   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
  13 ;;;
  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.
  18 ;;;
  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
  23
  24 (in-package :io.multiplex)
  25
  26 (defconstant +kqueue-priority+ 1)
  27
  28 (define-multiplexer kqueue-multiplexer +kqueue-priority+ (multiplexer)
  29   ())
  30
  31 (defmethod print-object ((mux kqueue-multiplexer) stream)
  32   (print-unreadable-object (mux stream :type nil :identity nil)
  33     (format stream "kqueue(2) multiplexer")))
  34
  35 (defvar *kqueue-max-events* 200)
  36
  37 (defmethod initialize-instance :after ((mux kqueue-multiplexer) &key)
  38   (setf (slot-value mux 'fd) (nix:kqueue)))
  39
  40 (defun do-kqueue-event-request (kqueue-fd fd-entry filter request-type)
  41   (let ((fd (fd-entry-fd fd-entry)))
  42     (with-foreign-object (kev 'nix::kevent)
  43       (nix:bzero kev nix::size-of-kevent)
  44       (nix:ev-set kev fd filter request-type 0 0 (null-pointer))
  45       (nix:kevent kqueue-fd
  46                   kev 1
  47                   (null-pointer) 0
  48                   (null-pointer)))))
  49
  50 (defun calc-kqueue-monitor-filter (fd-entry)
  51   (if (null (fd-entry-read-event fd-entry))
  52       nix:evfilt-write
  53       nix:evfilt-read))
  54
  55 (defmethod monitor-fd ((mux kqueue-multiplexer) fd-entry)
  56   (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!")
  57   (handler-case
  58       (do-kqueue-event-request (fd-of mux) fd-entry
  59                                (calc-kqueue-monitor-filter fd-entry)
  60                                nix:ev-add)
  61     (nix:ebadf ()
  62       (warn "FD ~A is invalid, cannot monitor it." (fd-entry-fd fd-entry)))))
  63
  64 (defun calc-kqueue-update-filter-and-flags (event-type edge-change)
  65   (case event-type
  66     (:read
  67      (case edge-change
  68        (:add (values nix:evfilt-read nix:ev-add))
  69        (:del (values nix:evfilt-read nix:ev-delete))))
  70     (:write
  71      (case edge-change
  72        (:add (values nix:evfilt-write nix:ev-add))
  73        (:del (values nix:evfilt-write nix:ev-delete))))))
  74
  75 (defmethod update-fd ((mux kqueue-multiplexer) fd-entry event-type edge-change)
  76   (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!")
  77   (handler-case
  78       (multiple-value-call #'do-kqueue-event-request (fd-of mux) fd-entry
  79                            (calc-kqueue-update-filter-and-flags event-type edge-change))
  80     (nix:ebadf ()
  81       (warn "FD ~A is invalid, cannot update its status."
  82             (fd-entry-fd fd-entry)))
  83     (nix:enoent ()
  84       (warn "FD ~A was not monitored, cannot update its status."
  85             (fd-entry-fd fd-entry)))))
  86
  87 (defun calc-kqueue-unmonitor-filter (fd-entry)
  88   (if (null (fd-entry-read-event fd-entry))
  89       nix:evfilt-read
  90       nix:evfilt-write))
  91
  92 (defmethod unmonitor-fd ((mux kqueue-multiplexer) fd-entry)
  93   (handler-case
  94       (do-kqueue-event-request (fd-of mux) fd-entry
  95                                (calc-kqueue-unmonitor-filter fd-entry)
  96                                nix:ev-delete)
  97     (nix:ebadf ()
  98       (warn "FD ~A is invalid, cannot unmonitor it." (fd-entry-fd fd-entry)))
  99     (nix:enoent ()
 100       (warn "FD ~A was not monitored, cannot unmonitor it."
 101             (fd-entry-fd fd-entry)))))
 102
 103 (defmethod harvest-events ((mux kqueue-multiplexer) timeout)
 104   (with-foreign-objects ((events 'nix::kevent *kqueue-max-events*)
 105                          (ts 'nix::timespec))
 106     (nix:bzero events (* *kqueue-max-events* nix::size-of-kevent))
 107     (let (ready-fds)
 108       (nix:repeat-upon-condition-decreasing-timeout
 109           ((nix:eintr) tmp-timeout timeout)
 110         (when tmp-timeout
 111           (timeout->timespec tmp-timeout ts))
 112         (setf ready-fds
 113               (nix:kevent (fd-of mux) (null-pointer) 0
 114                           events *kqueue-max-events*
 115                           (if tmp-timeout ts (null-pointer)))))
 116       (macrolet ((kevent-slot (slot-name)
 117                    `(foreign-slot-value (mem-aref events 'nix::kevent i)
 118                                         'nix::kevent ',slot-name)))
 119         (loop for i below ready-fds
 120               for fd = (kevent-slot nix::ident)
 121               for flags = (kevent-slot nix::flags)
 122               for filter = (kevent-slot nix::filter)
 123               for data = (kevent-slot nix::data)
 124               for kqueue-event = (make-kqueue-event fd flags filter data)
 125               when kqueue-event collect kqueue-event)))))
 126
 127 ;;; TODO: do something with DATA
 128 (defun make-kqueue-event (fd flags filter data)
 129   (declare (ignore data))
 130   (let ((event ()))
 131     (case filter
 132       (#.nix:evfilt-write (push :write event))
 133       (#.nix:evfilt-read  (push :read event)))
 134     (flags-case flags
 135       ;; TODO: check what exactly EV_EOF means
 136       ;; (nix:ev-eof   (pushnew :read event))
 137       (nix:ev-error (push :error event)))
 138     (when event
 139       (list fd event))))