io-multiplex/wait.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; wait.lisp --- WaitForMultipleObjects()-based multiplexer.
   4 ;;;
   5 ;;; Copyright (C) 2007, Luis Oliveira  <loliveira@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 ;;; <http://msdn2.microsoft.com/en-us/library/ms687025.aspx> has some
  27 ;;; suggestions on how to work around this limitation.
  28 (defconstant +maximum-wait-objects+ 64)
  29
  30 (defconstant +wait-priority+ 3)
  31
  32 (define-multiplexer wait-multiplexer +wait-priority+ (multiplexer)
  33   ((read-fds :initform nil :accessor mux-read-fds)
  34    (write-fds :initform nil :accessor mux-write-fds))
  35   (:default-initargs :fd-limit +maximum-wait-objects+))
  36
  37 (defmethod print-object ((mux wait-multiplexer) stream)
  38   (print-unreadable-object (mux stream :type nil :identity nil)
  39     (format stream "WaitForMultipleObjects() multiplexer")))
  40
  41 (defmethod close-multiplexer progn ((mux wait-multiplexer))
  42   (setf (mux-read-fds mux) nil
  43         (mux-write-fds mux) nil))
  44
  45 (defmethod monitor-fd ((mux wait-multiplexer) fd-entry)
  46   (unless (queue-empty-p (fd-entry-read-events fd-entry))
  47     (push (fd-entry-fd fd-entry) (mux-read-fds mux)))
  48   (unless (queue-empty-p (fd-entry-write-events fd-entry))
  49     (push (fd-entry-fd fd-entry) (mux-read-fds mux)))
  50   t)
  51
  52 (defmethod update-fd ((mux wait-multiplexer) fd-entry)
  53   (if (queue-empty-p (fd-entry-read-events fd-entry))
  54       (alexandria:deletef (mux-read-fds mux) (fd-entry-fd fd-entry))
  55       (push (fd-entry-fd fd-entry) (mux-read-fds mux)))
  56   (if (queue-empty-p (fd-entry-write-events fd-entry))
  57       (alexandria:deletef (mux-write-fds mux) (fd-entry-fd fd-entry))
  58       (push (fd-entry-fd fd-entry) (mux-write-fds mux)))
  59   t)
  60
  61 (defmethod unmonitor-fd ((mux wait-multiplexer) fd-entry)
  62   (alexandria:deletef (mux-read-fds mux) (fd-entry-fd fd-entry))
  63   (alexandria:deletef (mux-write-fds mux) (fd-entry-fd fd-entry))
  64   t)
  65
  66 (defctype bool (:boolean :int))
  67
  68 (defcfun ("WaitForMultipleObjects" %wait :cconv :stdcall) dword
  69   (count    dword)
  70   (handles  :pointer)
  71   (wait-all bool)
  72   (millis   dword))
  73
  74 ;;; FIXME: can we get WAIT_ABANDONED+X?  What to do in that case?
  75 (defun wait-for-multiple-objects (fds timeout)
  76   ;; with a constant size we can do stack allocation.
  77   (with-foreign-object (handles :intptr +maximum-wait-objects+)
  78     (loop for i from 0 and fd in fds
  79           do (setf (mem-aref handles :intptr i)
  80                    (get-osfhandle fd)))
  81     (let ((ret (%wait (length fds) handles nil (timeout->milisec timeout))))
  82       (assert (not (eql ret +wait-failed+)))
  83       (if (< ret +wait-abandoned+)
  84           ret
  85           nil))))
  86
  87 (defmethod harvest-events ((mux wait-multiplexer) timeout)
  88   (let ((ret (wait-for-multiple-objects (mux-read-fds mux) timeout))
  89         (found nil))
  90     (nconc (loop for i from 0 and fd in (mux-write-fds mux) collect
  91                  (list fd (if (eql ret i)
  92                               (progn (setq found t)
  93                                      (list :write :read))
  94                               (list :write))))
  95            (unless found
  96              (list ret (list :read))))))