io-multiplex/common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; common.lisp --- Miscellaneous definitions.
   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 (eval-when (:compile-toplevel :load-toplevel :execute)
  27   (defvar *available-multiplexers* nil)
  28   (defvar *best-available-multiplexer* nil))
  29
  30 (defvar *maximum-event-loop-timeout* 1)
  31
  32 ;;;; EVENT-BASE
  33
  34 (defclass event-base ()
  35   ((mux :initform (make-instance *best-available-multiplexer*)
  36         :initarg :mux :reader mux-of)
  37    (fds :initform (make-hash-table :test 'eql)
  38         :reader fds-of)
  39    (timeouts :initform (make-queue)
  40              :reader timeouts-of)
  41    (exit :initform nil
  42          :accessor exit-p)
  43    (exit-when-empty :initarg :exit-when-empty
  44                     :accessor exit-when-empty-p))
  45   (:default-initargs :exit-when-empty nil)
  46   (:documentation "An event base ..."))
  47
  48 (defmethod print-object ((base event-base) stream)
  49   (print-unreadable-object (base stream :type nil :identity t)
  50     (format stream "event base, ~A FDs monitored, using: ~A"
  51             ;; kludge: quick fix for printing closed event bases
  52             (when (fds-of base) (hash-table-count (fds-of base)))
  53             (mux-of base))))
  54
  55 (defmethod initialize-instance :after ((base event-base) &key)
  56   (with-slots (mux) base
  57     (when (symbolp mux)
  58       (setq mux (make-instance mux)))))
  59
  60 ;;; KLUDGE: CLOSE is for streams. --luis
  61 ;;;
  62 ;;; Also, we might want to close FDs here.  Or have a version/argument
  63 ;;; that handles that.  Or... add finalizers to the fd streams.
  64 (defmethod close ((event-base event-base) &key abort)
  65   (declare (ignore abort))
  66   (with-accessors ((mux mux-of)) event-base
  67     (close-multiplexer mux)
  68     (dolist (slot '(fds timeouts exit))
  69       (setf (slot-value event-base slot) nil))
  70     event-base))
  71
  72 (defgeneric add-fd (base fd event-type function &key timeout persistent)
  73   (:documentation ""))
  74
  75 (defgeneric add-timeout (event-base function timeout &key persistent)
  76   (:documentation ""))
  77
  78 (defgeneric remove-event (event-base event)
  79   (:documentation ""))
  80
  81 (defgeneric remove-events (event-base event-list)
  82   (:documentation ""))
  83
  84 (defgeneric event-dispatch (event-base &key &allow-other-keys)
  85   (:documentation ""))
  86
  87 (defgeneric exit-event-loop (event-base &key delay)
  88   (:documentation "")
  89   (:method ((event-base event-base) &key (delay 0))
  90     (add-timeout event-base
  91                  #'(lambda (fd event-type)
  92                      (declare (ignore fd event-type))
  93                      (setf (exit-p event-base) t))
  94                  delay :persistent nil)))
  95
  96 (defgeneric event-base-empty-p (event-base)
  97   (:documentation "")
  98   (:method ((event-base event-base))
  99     (and (zerop (hash-table-count (fds-of event-base)))
 100          (queue-empty-p (timeouts-of event-base)))))
 101
 102 (defgeneric fd-entry-of (event-base fd)
 103   (:documentation "")
 104   (:method ((event-base event-base) fd)
 105     (gethash fd (fds-of event-base))))
 106
 107 (defun %add-event (event-base event &optional fd-entry)
 108   (with-accessors ((fds fds-of) (timeouts timeouts-of)) event-base
 109     (when (event-timeout event)
 110       ;; add the event to the timeout queue
 111       (queue-sorted-insert timeouts event #'< #'event-abs-timeout))
 112     (let ((fd (event-fd event)))
 113       ;; if it's an FD event add it to its fd-entry int the FDs hash-table
 114       ;; if there's no such fd-entry, create it
 115       (when fd
 116         (fd-entry-add-event fd-entry event)
 117         (setf (gethash fd fds) fd-entry))
 118       (values event))))
 119
 120 (defun %remove-event (event-base event)
 121   (with-accessors ((fds fds-of) (timeouts timeouts-of)) event-base
 122     (when (event-timeout event)
 123       ;; remove the event from the timeout queue
 124       (queue-delete timeouts event))
 125     (let ((fd (event-fd event)))
 126       ;; if it's an FD event remove it from its fd-entry
 127       ;; if the fd-emtry is then empty, remove it
 128       (when fd
 129         (let ((fd-entry (gethash fd fds)))
 130           (assert fd-entry)
 131           (fd-entry-del-event fd-entry event)
 132           (when (fd-entry-empty-p fd-entry)
 133             (remhash fd fds))))
 134       (values event))))
 135
 136 (defun calc-possible-edge-change-when-adding (fd-entry event-type)
 137   (cond ((and (eql event-type :read)
 138               (queue-empty-p (fd-entry-read-events fd-entry)))
 139          :read-add)
 140         ((and (eql event-type :write)
 141               (queue-empty-p (fd-entry-write-events fd-entry)))
 142          :write-add)))
 143
 144 (defmethod add-fd ((event-base event-base) fd event-type function
 145                    &key timeout persistent)
 146   (check-type fd unsigned-byte)
 147   (check-type event-type fd-event)
 148   (let ((fd-limit (fd-limit-of (mux-of event-base))))
 149     (when (and fd-limit (> fd fd-limit))
 150       (error "Cannot add such a large FD: ~A" fd)))
 151   (let ((current-entry (fd-entry-of event-base fd))
 152         (event (make-event fd event-type function persistent
 153                            (abs-timeout timeout)
 154                            (normalize-timeout timeout)))
 155         (edge-change nil))
 156     (if current-entry
 157         (progn
 158           (setf edge-change (calc-possible-edge-change-when-adding
 159                              current-entry event-type))
 160           (%add-event event-base event current-entry)
 161           (when edge-change
 162             (setf (fd-entry-edge-change current-entry) edge-change)
 163             (update-fd (mux-of event-base) current-entry)
 164             (setf (fd-entry-edge-change current-entry) nil)))
 165         (progn
 166           (setf current-entry (make-fd-entry fd))
 167           (%add-event event-base event current-entry)
 168           (unless (monitor-fd (mux-of event-base) current-entry)
 169             (%remove-event event-base event))))
 170     (values event)))
 171
 172 (defmethod add-timeout ((event-base event-base) function timeout
 173                         &key persistent)
 174   (assert timeout)
 175   (%add-event event-base (make-event nil :timeout function persistent
 176                                      (abs-timeout timeout)
 177                                      (normalize-timeout timeout))))
 178
 179 (defun calc-possible-edge-change-when-removing (fd-entry event-type)
 180   (cond ((and (eql event-type :read)
 181               (not (queue-empty-p (fd-entry-read-events fd-entry))))
 182          :read-del)
 183         ((and (eql event-type :write)
 184               (not (queue-empty-p (fd-entry-write-events fd-entry))))
 185          :write-del)))
 186
 187 (defmethod remove-event ((event-base event-base) event)
 188   (check-type (event-type event) event-type)
 189   (let* ((fd (event-fd event))
 190          (current-entry (fd-entry-of event-base fd))
 191          (edge-change nil))
 192     (if current-entry
 193         (progn
 194           (setf edge-change (calc-possible-edge-change-when-removing
 195                              current-entry (event-type event)))
 196           (%remove-event event-base event)
 197           (if (fd-entry-empty-p current-entry)
 198               (unmonitor-fd (mux-of event-base) current-entry)
 199               (when edge-change
 200                 (setf (fd-entry-edge-change current-entry) edge-change)
 201                 (update-fd (mux-of event-base) current-entry)
 202                 (setf (fd-entry-edge-change current-entry) nil))))
 203         (%remove-event event-base event)))
 204   (values event-base))
 205
 206 (defmacro with-fd-handler ((event-base fd event-type function &optional timeout)
 207                            &body body)
 208   ""
 209   (once-only (event-base)
 210     (with-unique-names (event)
 211       `(let (,event)
 212          (unwind-protect
 213               (progn
 214                 (setf ,event (add-fd ,event-base ,fd ,event-type ,function
 215                                      :persistent t
 216                                      :timeout ,timeout))
 217                 ,@body)
 218            (when ,event
 219              (remove-event ,event-base ,event)))))))
 220
 221 (defmethod event-dispatch :around ((event-base event-base)
 222                                    &key timeout only-once)
 223   (setf (exit-p event-base) nil)
 224   (when timeout
 225     (exit-event-loop event-base :delay timeout))
 226   (call-next-method event-base :only-once only-once))
 227
 228 (defun recalculate-timeouts (timeouts)
 229   (let ((now (osicat:get-monotonic-time)))
 230     (dolist (ev (queue-head timeouts))
 231       (event-recalc-abs-timeout ev now))))
 232
 233 (defun dispatch-timeouts (dispatch-list)
 234   (dolist (ev dispatch-list)
 235     (funcall (event-handler ev) nil :timeout)))
 236
 237 (defmethod remove-events ((event-base event-base) event-list)
 238   (dolist (ev event-list)
 239     (remove-event event-base ev)))
 240
 241 (defmethod event-dispatch ((event-base event-base) &key only-once)
 242   (with-accessors ((mux mux-of) (fds fds-of)
 243                    (exit-p exit-p) (exit-when-empty exit-when-empty-p)
 244                    (timeouts timeouts-of)) event-base
 245     (flet ((recalc-poll-timeout ()
 246              (calc-min-timeout (events-calc-min-rel-timeout timeouts)
 247                                *maximum-event-loop-timeout*)))
 248       (do ((poll-timeout (recalc-poll-timeout) (recalc-poll-timeout))
 249            (deletion-list () ())
 250            (dispatch-list () ()))
 251           ((or exit-p (and exit-when-empty (event-base-empty-p event-base))))
 252         (recalculate-timeouts timeouts)
 253         (when (dispatch-fd-events-once event-base poll-timeout)
 254           (and only-once (setf exit-p t)))
 255         (setf (values deletion-list dispatch-list)
 256               (filter-expired-events
 257                (expired-events timeouts (osicat:get-monotonic-time))))
 258         (dispatch-timeouts dispatch-list)
 259         (remove-events event-base deletion-list)
 260         (queue-sort timeouts #'< #'event-abs-timeout)))))
 261
 262 ;;; Waits for events and dispatches them.  Returns T if some events
 263 ;;; have been received, NIL otherwise.
 264 (defun dispatch-fd-events-once (event-base timeout)
 265   (with-accessors ((mux mux-of) (fds fds-of) (timeouts timeouts-of))
 266       event-base
 267     (let ((deletion-list ())
 268           (fd-events (harvest-events mux timeout)))
 269       (dolist (ev fd-events)
 270         (destructuring-bind (fd ev-types) ev
 271           (let ((fd-entry (fd-entry-of event-base fd)))
 272             (if fd-entry
 273                 (let ((errorp (member :error ev-types)))
 274                   (when errorp
 275                     (dispatch-error-events fd-entry)
 276                     (nconcf deletion-list
 277                             (fd-entry-all-events fd-entry)))
 278                   (when (member :read ev-types)
 279                     (dispatch-read-events fd-entry)
 280                     (or errorp
 281                         (nconcf deletion-list
 282                                 (fd-entry-one-shot-events fd-entry :read))))
 283                   (when (member :write ev-types)
 284                     (dispatch-write-events fd-entry)
 285                     (or errorp
 286                         (nconcf deletion-list
 287                                 (fd-entry-one-shot-events fd-entry :write)))))
 288                 (warn "Got spurious event for non-monitored FD: ~A" fd)))))
 289       (dolist (ev deletion-list)
 290         (remove-event event-base ev))
 291       (consp fd-events))))
 292
 293 (defun expired-events (queue now)
 294   (queue-filter queue
 295                 #'(lambda (to) (and to (<= to now)))
 296                 #'event-abs-timeout))
 297
 298 (defun filter-expired-events (events)
 299   (let ((deletion-list ())
 300         (dispatch-list ()))
 301     (dolist (ev events)
 302       (push ev dispatch-list)
 303       (unless (event-persistent-p ev)
 304         (push ev deletion-list)))
 305     (values deletion-list dispatch-list)))
 306
 307 (defun events-calc-min-rel-timeout (timeouts)
 308   (let* ((now (osicat:get-monotonic-time))
 309          (first-valid-event (find-if #'(lambda (to)
 310                                          (or (null to) (< now to)))
 311                                      (queue-head timeouts)
 312                                      :key #'event-abs-timeout)))
 313     (when (and first-valid-event
 314                (event-abs-timeout first-valid-event))
 315       (- (event-abs-timeout first-valid-event) now))))
 316
 317 (defun dispatch-error-events (fd-entry)
 318   (dolist (ev (queue-head (fd-entry-error-events fd-entry)))
 319     (funcall (event-handler ev) (fd-entry-fd fd-entry) :error)))
 320
 321 (defun dispatch-read-events (fd-entry)
 322   (dolist (ev (queue-head (fd-entry-read-events fd-entry)))
 323     (funcall (event-handler ev) (fd-entry-fd fd-entry) :read)))
 324
 325 (defun dispatch-write-events (fd-entry)
 326   (dolist (ev (queue-head (fd-entry-write-events fd-entry)))
 327     (funcall (event-handler ev) (fd-entry-fd fd-entry) :write)))
 328
 329 ;;;; FD-ENTRY
 330
 331 (deftype fd-event ()
 332   '(member :read :write :error))
 333
 334 (deftype event-type ()
 335   '(or fd-event (member :timeout)))
 336
 337 (defstruct (fd-entry (:constructor make-fd-entry (fd))
 338                      (:copier nil))
 339   (fd 0 :type unsigned-byte)
 340   (edge-change nil :type symbol)
 341   (read-events  (make-queue) :type queue)
 342   (write-events (make-queue) :type queue)
 343   (error-events (make-queue) :type queue))
 344
 345 (defun fd-entry-event-list (fd-entry event-type)
 346   (check-type fd-entry fd-entry)
 347   (check-type event-type fd-event)
 348   (case event-type
 349     (:read (fd-entry-read-events fd-entry))
 350     (:write (fd-entry-write-events fd-entry))
 351     (:error (fd-entry-error-events fd-entry))))
 352
 353 (defun (setf fd-entry-event-list) (fd-entry event-list event-type)
 354   (check-type fd-entry fd-entry)
 355   (check-type event-type fd-event)
 356   (case event-type
 357     (:read (setf (fd-entry-read-events fd-entry) event-list))
 358     (:write (setf (fd-entry-write-events fd-entry) event-list))
 359     (:error (setf (fd-entry-error-events fd-entry) event-list))))
 360
 361 (defun fd-entry-empty-p (fd-entry)
 362   (and (queue-empty-p (fd-entry-read-events fd-entry))
 363        (queue-empty-p (fd-entry-write-events fd-entry))
 364        (queue-empty-p (fd-entry-error-events fd-entry))))
 365
 366 (defun fd-entry-add-event (fd-entry event)
 367   (queue-enqueue (fd-entry-event-list fd-entry (event-type event))
 368                  event))
 369
 370 (defun fd-entry-del-event (fd-entry event)
 371   (queue-delete (fd-entry-event-list fd-entry (event-type event))
 372                 event))
 373
 374 (defun fd-entry-all-events (fd-entry)
 375   (append (queue-head (fd-entry-read-events fd-entry))
 376           (queue-head (fd-entry-write-events fd-entry))
 377           (queue-head (fd-entry-error-events fd-entry))))
 378
 379 (defun fd-entry-one-shot-events (fd-entry event-type)
 380   (remove-if #'event-persistent-p
 381              (queue-head (fd-entry-event-list fd-entry event-type))))
 382
 383 ;;;; Event
 384
 385 (defstruct (event (:constructor make-event (fd type handler persistent-p
 386                                                abs-timeout timeout))
 387                   (:copier nil))
 388   ;; a file descriptor or nil in case of a timeout
 389   (fd nil :type (or null unsigned-byte))
 390   (type nil :type (or null event-type))
 391   (handler nil :type (or null function))
 392   ;; if an event is not persistent it is removed
 393   ;; after it occurs or if it times out
 394   (persistent-p nil :type boolean)
 395   (abs-timeout nil :type (or null timeout))
 396   (timeout nil :type (or null timeout)))
 397
 398 (defun event-timed-out-p (event timeout)
 399   (let ((ev-to (event-abs-timeout event)))
 400     (when (and ev-to timeout)
 401       (< timeout ev-to))))
 402
 403 (defun event-recalc-abs-timeout (event now)
 404   (setf (event-abs-timeout event)
 405         (+ now (event-timeout event))))
 406
 407 ;;;; Multiplexer
 408
 409 #+windows
 410 (defcfun ("_getmaxstdio" get-fd-limit) :int)
 411
 412 #-windows
 413 (defun get-fd-limit ()
 414   (let ((fd-limit (nix:getrlimit nix::rlimit-nofile)))
 415     (unless (eql fd-limit nix::rlim-infinity)
 416       (1- fd-limit))))
 417
 418 (defclass multiplexer ()
 419   ((fd :reader fd-of)
 420    (fd-limit :initform (get-fd-limit)
 421              :initarg :fd-limit
 422              :reader fd-limit-of)))
 423
 424 (defgeneric monitor-fd (mux fd-entry)
 425   (:method ((mux multiplexer) fd-entry)
 426     (declare (ignore fd-entry))
 427     t))
 428
 429 (defgeneric update-fd (mux fd-entry)
 430   (:method ((mux multiplexer) fd-entry)
 431     (declare (ignore fd-entry))
 432     t))
 433
 434 (defgeneric unmonitor-fd (mux fd-entry)
 435   (:method ((mux multiplexer) fd-entry)
 436     (declare (ignore fd-entry))
 437     t))
 438
 439 ;;; Returns a list of fd/result pairs which have one of these forms:
 440 ;;;   (fd (:read))
 441 ;;;   (fd (:write))
 442 ;;;   (fd (:read :write))
 443 ;;;   (fd . :error)
 444 (defgeneric harvest-events (mux timeout))
 445
 446 (defgeneric close-multiplexer (mux)
 447   (:method-combination progn :most-specific-last)
 448   (:method progn ((mux multiplexer))
 449     (when (slot-value mux 'fd)
 450       (nix:close (fd-of mux))
 451       (setf (slot-value mux 'fd) nil))
 452     mux))
 453
 454 (defmethod monitor-fd :around ((mux multiplexer) fd-entry)
 455   (if (ignore-and-print-errors (call-next-method))
 456       t
 457       (warn "FD monitoring failed for FD ~A."
 458             (fd-entry-fd fd-entry))))
 459
 460 (defmethod update-fd :around ((mux multiplexer) fd-entry)
 461   (if (ignore-and-print-errors (call-next-method))
 462       t
 463       (warn "FD status update failed for FD ~A."
 464             (fd-entry-fd fd-entry))))
 465
 466 (defmethod unmonitor-fd :around ((mux multiplexer) fd-entry)
 467   (if (ignore-and-print-errors (call-next-method))
 468       t
 469       (warn "FD unmonitoring failed for FD ~A."
 470             (fd-entry-fd fd-entry))))
 471
 472 (defmacro define-multiplexer (name priority superclasses slots &rest options)
 473   `(progn
 474      (defclass ,name ,superclasses ,slots ,@options)
 475      (pushnew (cons ,priority ',name)
 476               *available-multiplexers*)))
 477
 478 ;;;; Misc
 479
 480 ;;; FIXME: Until a way to autodetect platform features is implemented
 481 #+darwin
 482 (defconstant nix::pollrdhup 0)
 483
 484 (define-condition poll-error (error)
 485   ((fd :initarg :fd :reader poll-error-fd)
 486    (identifier :initarg :identifier :initform "<Unknown error>"
 487                :reader poll-error-identifier))
 488   (:report (lambda (condition stream)
 489              (format stream "Error caught while polling file descriptor ~A: ~A"
 490                      (poll-error-fd condition)
 491                      (poll-error-identifier condition))))
 492   (:documentation
 493    "Signaled when an error occurs while polling for I/O readiness
 494 of a file descriptor."))
 495
 496 ;;; This should probably be moved elsewhere.  Also, it's quite a mess.
 497 #+windows
 498 (progn
 499   (load-foreign-library "User32.dll")
 500   (load-foreign-library "msvcrt.dll")
 501   (load-foreign-library "Ws2_32.dll")
 502
 503   (defctype dword :unsigned-long)
 504   (defctype bool (:boolean :int))
 505
 506   (cl-posix-ffi:defsyscall "get_osfhandle" :long
 507     (fd :int))
 508
 509   (defconstant +wait-failed+ #xffffffff)
 510   (defconstant +wait-abandoned+ #x80)
 511   (defconstant +wait-object-0+ 0)
 512   (defconstant +wait-timeout+ #x102)
 513   (defconstant +true+ 1)
 514   (defconstant +fd-read+ 1)
 515   (defconstant +fd-write+ 2)
 516   (defconstant +socket-error+ -1)
 517   (defconstant +wsaenotsock+ 10038)
 518
 519   (defcfun ("MsgWaitForMultipleObjects" %wait :cconv :stdcall) dword
 520     (count    dword)
 521     (handles  :pointer)
 522     (wait-all bool)
 523     (millis   dword))
 524
 525   (defcfun ("WSAGetLastError" wsa-get-last-error :cconv :stdcall) :int)
 526
 527   (defcfun ("WSAEventSelect" wsa-event-select :cconv :stdcall) :int
 528     (socket-handle :int)
 529     (event-handle :int)
 530     (event-mask :long))
 531
 532   (defcfun ("WSACreateEvent" wsa-create-event :cconv :stdcall) :int)
 533
 534   (defcfun ("WSACloseEvent" wsa-close-event :cconv :stdcall) bool
 535     (event :int))
 536
 537   ;; this one is probably completely broken
 538   (defun %wait-for-single-object (handle timeout)
 539     (let ((ret (with-foreign-object (phandle :int)
 540                  (setf (mem-ref phandle :int) handle)
 541                  (%wait 1 phandle t (timeout->milisec timeout)))))
 542       (when (or (eql ret +wait-failed+)
 543                 (eql ret +wait-abandoned+))
 544         (error 'poll-error))
 545       (let ((ready (= ret +wait-object-0+)))
 546         ;; is this right?
 547         (values ready ready))))
 548
 549   ;; wasn't handling :read-write properly so won't pretend to support it
 550   (defun %wait-until-fd-ready (fd event-type timeout)
 551     (let ((handle (get-osfhandle fd))
 552           (ev (wsa-create-event)))
 553       (unwind-protect
 554            (let ((ret (wsa-event-select handle ev (ecase event-type
 555                                                     (:read +fd-read+)
 556                                                     (:write +fd-write+)))))
 557              (if (eql ret +socket-error+)
 558                  (if (= (wsa-get-last-error) +wsaenotsock+)
 559                      (wait-for-multiple-objects handle timeout)
 560                      (error 'poll-error :fd fd))
 561                  (let ((ret (%wait-for-single-object ev timeout)))
 562                    (ecase event-type
 563                      (:read (values ret nil))
 564                      (:write (values nil ret))))))
 565         (wsa-close-event ev)))))
 566
 567 #-windows
 568 (defun %wait-until-fd-ready (fd event-type timeout)
 569   (flet ((choose-poll-flags (type)
 570            (ecase type
 571              (:read (logior nix::pollin nix::pollrdhup nix::pollpri))
 572              (:write (logior nix::pollout nix::pollhup))
 573              (:read-write (logior nix::pollin nix::pollrdhup nix::pollpri
 574                                   nix::pollout nix::pollhup))))
 575          (poll-error (unix-err)
 576            (error 'poll-error :fd fd
 577                   :identifier (osicat-sys:system-error-identifier unix-err))))
 578     (let ((readp nil) (writep nil))
 579       (with-foreign-object (pollfd 'nix::pollfd)
 580         (nix:bzero pollfd nix::size-of-pollfd)
 581         (with-foreign-slots ((nix::fd nix::events nix::revents)
 582                              pollfd nix::pollfd)
 583           (setf nix::fd fd
 584                 nix::events (choose-poll-flags event-type))
 585           (handler-case
 586               (let ((ret (nix:repeat-upon-condition-decreasing-timeout
 587                              ((nix:eintr) tmp-timeout timeout)
 588                            (nix:poll pollfd 1 (timeout->milisec timeout)))))
 589                 (when (zerop ret)
 590                   (return-from %wait-until-fd-ready (values nil nil))))
 591             (nix:posix-error (err) (poll-error err)))
 592           (flags-case nix::revents
 593             ((nix::pollin nix::pollrdhup nix::pollpri)
 594              (setf readp t))
 595             ((nix::pollout nix::pollhup) (setf writep t))
 596             ((nix::pollerr nix::pollnval) (error 'poll-error :fd fd)))
 597           (values readp writep))))))
 598
 599 (defun wait-until-fd-ready (fd event-type &optional timeout)
 600   "Poll file descriptor `FD' for I/O readiness. `EVENT-TYPE' must be
 601 :READ, :WRITE or :READ-WRITE which means \"either :READ or :WRITE\".
 602 `TIMEOUT' must be either a non-negative integer measured in seconds,
 603 or `NIL' meaning no timeout at all."
 604   (%wait-until-fd-ready fd event-type timeout))
 605
 606 (defun fd-ready-p (fd &optional (event-type :read))
 607   "Tests file-descriptor `FD' for I/O readiness. `EVENT-TYPE'
 608 must be :READ, :WRITE or :READ-WRITE which means \"either :READ
 609 or :WRITE\"."
 610   (multiple-value-bind (readp writep)
 611       (wait-until-fd-ready fd event-type 0)
 612     (ecase event-type
 613       (:read readp)
 614       (:write writep)
 615       (:read-write (or readp writep)))))
 616
 617 (defun fd-readablep (fd)
 618   (nth-value 0 (wait-until-fd-ready fd :read 0)))
 619
 620 (defun fd-writablep (fd)
 621   (nth-value 1 (wait-until-fd-ready fd :write 0)))