x11-wm/stumpwm.stumpwm
1
0
Fork 0
mirror of https://github.com/stumpwm/stumpwm.git synced 2026-09-10 07:26:20 -04:00
Code Issues Actions Packages Projects Releases Wiki Activity
stumpwm.stumpwm/ioloop.lisp
Jim Greenleaf 943127d11f Fix the ioloop timeout 
1451b05 fixed the issues with unix-fast-select returning nil, however,
it replace a call to `multiple-value-call' to one with
`multiple-value-bind' to get the errno. However, (compute-timeouts)
returns multiple values: seconds and milliseconds remanining in the
timeout. 1451b05 passed the seconds value, and set the milliseconds to
nil, resulting in waiting for 0 seconds and 0 milliseconds whenever
the timeout was supposed to be less than a second

I also made the syscall-level errors from this debug level 1 instead
of 5
2022-08-17 14:27:44 -04:00

390 lines
20 KiB
Common Lisp
Raw Blame History

;;;; Copyright (C) 2016 Fredrik Tolf <fredrik@dolda2000.com>
;;;;
;;;; This file is part of stumpwm.
;;;;
;;;; stumpwm is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; stumpwm is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, see
;;;; <http://www.gnu.org/licenses/>.
(in-package :stumpwm)
;;;; This file implements a generic multiplexing I/O loop for listening
;;;; to I/O events from multiple sources. The model is as follows:
;;;;
;;;; An I/O multiplexer is represented as an object, with which I/O
;;;; channels can be registered to be monitored for events when the I/O
;;;; loop runs. An I/O channel is any object for which the generic
;;;; functions IO-CHANNEL-IOPORT, IO-CHANNEL-EVENTS and
;;;; IO-CHANNEL-HANDLE are implemented.
;;;;
;;;; IO-CHANNEL-IOPORT, given an I/O multiplexer and an I/O channel,
;;;; should return the underlying system I/O facility that the channel
;;;; operates on. The actual objects used to represent an I/O facility
;;;; depends on the Lisp implementation, operating system and the
;;;; specific I/O loop implementation, but, for example, on Unix
;;;; implementations they will likely be numeric file descriptors. The
;;;; I/O loop implementation implements IO-CHANNEL-IOPORT methods for
;;;; the facilities it understands (such as FD-STREAMs on SBCL), so
;;;; user-implemented channels should simply call IO-CHANNEL-IOPORT
;;;; recursively on whatever it operates on.
;;;;
;;;; IO-CHANNEL-EVENTS, given an I/O channel, should return a list of
;;;; the events that the channel is interested in. See the
;;;; documentation for IO-CHANNEL-EVENTS for further details.
;;;;
;;;; The I/O loop guarantees that it will check what events a channel
;;;; is interested in when it is first registered, and also at any time
;;;; the channel has been notified of an event. If the channel changes
;;;; its mind at any other point in time, it should use the
;;;; IO-LOOP-UPDATE function to notify the I/O loop of such
;;;; changes. The I/O loop may very well also update spuriously at
;;;; other times, but such updates are not guaranteed.
;;;;
;;;; IO-CHANNEL-HANDLE is called by the I/O loop to notify a channel of
;;;; an event.
;;;;
;;;; An I/O multiplexer is created with a MAKE-INSTANCE call on the
;;;; class of the desired multiplexer implementation. If the code using
;;;; the multiplexer has no certain preferences on an implementation
;;;; (which should be the usual case), the variable *DEFAULT-IO-LOOP*
;;;; points to a class that should be generally optimal given the
;;;; current Lisp implementation and operating system.
;;;;
;;;; Given a multiplexer, channels can be registered with it using
;;;; IO-LOOP-ADD, unregistered with IO-LOOP-REMOVE, and updated with
;;;; IO-LOOP-UPDATE (as described above). Call IO-LOOP on the
;;;; multiplexer to actually run it.
(export '(io-channel-ioport io-channel-events io-channel-handle
*default-io-loop* *current-io-loop* *current-io-channel*
io-loop io-loop-add io-loop-remove io-loop-update
callback-channel callback-channel-stream callback-channel-events))
;;; General interface
(defgeneric io-channel-ioport (io-loop channel)
(:documentation
"Returns the I/O facility operated on by CHANNEL, in a
representation understood by IO-LOOP. CHANNEL may be either an I/O
channel or an object representing an underlying I/O facility, such
as a stream object. An I/O loop implementation should implement
methods for any primitive I/O facilities that it can monitor for
events, and abstract channels should return whatever
IO-CHANNEL-IOPORT returns for the primitive facility that it
operates on.
An I/O channel may also return NIL to indicate that it is only
interested in purely virtual events, such as :TIMEOUT or :LOOP."))
(defgeneric io-channel-events (channel)
(:documentation
"Returns a list of events that CHANNEL is interested in. An event
specification may be a simple symbol, or a list of a symbol and
additional data for the event. Specific I/O loop implementations may
implement additional events, but the following event specifications
should be supported by all I/O loops:
:READ -- The channel will be notified when its I/O port can be
read from without blocking.
:WRITE -- The channel will be notified when its I/O port can
be written to without blocking.
(:TIMEOUT TIME-SPEC) -- TIME-SPEC is a point in time in the
same units as from (GET-INTERNAL-REAL-TIME), at which point
the channel will be notified. It is permissible for TIME-SPEC
to be a real number of any representation, but the system does
not guarantee any particular level of accuracy.
:LOOP -- The channel will be notifed for each iteration of the
I/O loop, just before blocking for incoming events. This should
be considered a hack to be avoided, but may be useful for
certain libraries (such as XLIB).
If, at any time, an empty list is returned, the channel is
unregistered with the I/O loop.
The I/O loop will check what events a channel is interested in when
it is first registered with the loop, and whenever the channel has
been notified of an event. If the channel changes its mind at any
other point in time, it should use the IO-LOOP-UPDATE function to
notify the I/O loop of such changes. The I/O loop may also update
spuriously at any time, but such updates are not guaranteed."))
(defgeneric io-channel-handle (channel event &key &allow-other-keys)
(:documentation
"Called by the I/O loop to notify a channel that an event has
occurred. EVENT is the symbol corresponding to the event
specification from IO-CHANNEL-EVENTS (that is, :READ, :WRITE,
:TIMEOUT or :LOOP). A number of keyword arguments with additional
data specific to a certain event may also be passed, but no such
arguments are currently defined."))
(defgeneric io-loop-add (io-loop channel)
(:documentation "Add a channel to the given I/O multiplexer to be monitored."))
(defgeneric io-loop-remove (io-loop channel)
(:documentation "Unregister a channel from the I/O multiplexer."))
(defgeneric io-loop-update (io-loop channel)
(:documentation "Make the I/O loop update its knowledge of what
events CHANNEL is interested in. See the documentation for
IO-CHANNEL-EVENTS for more information."))
(defgeneric io-loop (io-loop &key &allow-other-keys)
(:documentation "Run the given I/O multiplexer, watching for events
on any channels registered with it. IO-LOOP will return when it has
no channels left registered with it."))
(defvar *default-io-loop* 'sbcl-io-loop
"The default I/O loop implementation. Should be generically optimal
for the given LISP implementation and operating system.")
(defvar *current-io-loop* nil
"Dynamically bound to the I/O loop currently running, providing an
easy way for event callbacks to register new channels.")
(defvar *current-io-channel* nil
"While processing an I/O channel, this variable is dynamically bound
to the channel in question. This is provided primarily for
error-handling code.")
;; Default methods for the above
(defmethod io-channel-handle (channel event &key &allow-other-keys)
(declare (ignore channel event)))
;;; SBCL implementation
;;;
;;; It would be generally nice if SBCL supported epoll/kqueue, but it
;;; doesn't. The general I/O loop interface is consistent with such
;;; implementations, however, so if support is added at any time, it
;;; could be supported fairly easily.
;;;
;;; If need should arise, it should also be quite simple to add
;;; thread-safe operation.
(defclass sbcl-io-loop ()
((channels :initform '()))
(:documentation
"Implements a select(2)-based I/O loop for SBCL. The
implementation is not particularly optimal, mostly because any
efficiency ambitions are mostly pointless as long as SBCL lacks
support for epoll/kqueue, but should work well enough for I/O loops
with relatively few channels.
The implementation currently supports monitoring SB-SYS:FD-STREAM
and XLIB:DISPLAY objects."))
(defmethod io-loop-add ((info sbcl-io-loop) channel)
(with-slots (channels) info
(when (find channel channels)
(error "I/O channel is already registered"))
(push channel channels)))
(defmethod io-loop-remove ((info sbcl-io-loop) channel)
(with-slots (channels) info
(when (not (find channel channels))
(error "I/O channel is not currently registered"))
(setf channels (delete channel channels))))
(defmethod io-loop-update ((info sbcl-io-loop) channel)
(declare (ignore info channel)))
(defmethod io-loop ((info sbcl-io-loop) &key description)
(let ((*current-io-loop* info))
(with-simple-restart (:quit-ioloop "Quit I/O loop~A"
(if description
(format nil " (~A)" description)
""))
(block io-loop
(sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))
(wfds (sb-alien:struct sb-unix:fd-set))
(efds (sb-alien:struct sb-unix:fd-set)))
(loop
:do
(with-simple-restart (:restart-ioloop "Restart at I/O loop~A"
(if description
(format nil " (~A)" description)
""))
(macrolet ((with-channel-restarts ((channel &optional remove-code) &body body)
(let ((ch (gensym "CHANNEL")))
`(let* ((,ch ,channel)
(*current-io-channel* ,ch))
(restart-case
(progn ,@body)
(:skip-channel ()
:report (lambda (s)
(format s "Continue as if without channel ~S" ,ch))
nil)
(:remove-channel ()
:report (lambda (s)
(format s "Unregister channel ~S and continue" ,ch))
,(or remove-code `(io-loop-remove info ,ch))
nil))))))
(let ((ch-map (make-hash-table :test 'eql))
(timeouts '())
(loop-ch '())
(maxfd 0))
;; Since it is select(2)-based, this implementation
;; updates the entire set of interesting events once
;; every iteration.
(let ((remove '()))
(sb-unix:fd-zero rfds)
(sb-unix:fd-zero wfds)
(sb-unix:fd-zero efds)
(dolist (channel (slot-value info 'channels))
(with-channel-restarts (channel (push channel remove))
(let ((fd (io-channel-ioport info channel)))
(let ((events (io-channel-events channel)))
(if events
(dolist (event events)
(multiple-value-bind (event data)
(if (consp event)
(values (car event) (cdr event))
(values event nil))
(case event
(:read
(setf maxfd (max maxfd fd))
(sb-unix:fd-set fd rfds)
(push (cons :read channel)
(gethash fd ch-map '())))
(:write
(setf maxfd (max maxfd fd))
(sb-unix:fd-set fd wfds)
(push (cons :write channel)
(gethash fd ch-map '())))
(:timeout
(let ((timeout (car data)))
(check-type timeout real)
(push (cons timeout channel) timeouts)))
(:loop
(push channel loop-ch)))))
(push channel remove))))))
(dolist (channel remove)
(io-loop-remove info channel))
(unless (slot-value info 'channels)
(return-from io-loop)))
;; Call any :LOOP channels
(dolist (channel loop-ch)
(with-channel-restarts (channel)
(io-channel-handle channel :loop)))
(setf timeouts (sort timeouts '< :key 'car))
(flet ((compute-timeout ()
(if timeouts
(let* ((internal-time-of-timeout (car (first timeouts)))
(remaining-internal-time (- internal-time-of-timeout
(get-internal-real-time)))
(remaining-seconds (/ remaining-internal-time
internal-time-units-per-second))
(s-to-ms 1000000)
(remaining-ms (max
(round (* remaining-seconds
s-to-ms))
0)))
(floor remaining-ms 1000000))
(values nil nil))))
;; Actually block for events
(multiple-value-bind (rval errno)
(multiple-value-call #'sb-unix:unix-fast-select
(1+ maxfd)
(sb-alien:addr rfds)
(sb-alien:addr wfds)
(sb-alien:addr efds)
(compute-timeout))
(declare (ignore rval))
(cond ((and errno (plusp errno))
(unless (eql errno sb-unix:eintr)
(dformat 1
"Unexpected ~S error: ~A~%"
'sb-unix:unix-fast-select
(sb-int:strerror errno))))
(t
;; Notify channels for transpired events
(maphash (lambda (fd evs)
(let ((r (sb-unix:fd-isset fd rfds))
(w (sb-unix:fd-isset fd wfds))
(e (sb-unix:fd-isset fd efds)))
(dolist (ev evs)
(with-channel-restarts ((cdr ev))
(cond ((and (eq (car ev) :read)
(or r e))
(io-channel-handle (cdr ev) :read))
((and (eq (car ev) :write)
w)
(io-channel-handle (cdr ev) :write)))))))
ch-map)))))
;; Check for timeouts
(when timeouts
(block timeouts
(let ((now (get-internal-real-time)))
(dolist (to timeouts)
(if (<= (car to) now)
(with-channel-restarts ((cdr to))
(io-channel-handle (cdr to) :timeout))
(return-from timeouts)))))))))))))))
;;; IO-CHANNEL-IOPORT methods for support facilities
(defmethod io-channel-ioport (io-loop (channel sb-sys:fd-stream))
(declare (ignore io-loop))
(sb-sys:fd-stream-fd channel))
(defmethod io-channel-ioport ((io-loop sbcl-io-loop) (channel xlib:display))
(io-channel-ioport io-loop (xlib::display-input-stream channel)))
;;; Default methods for widely supported objects
(defmethod io-channel-ioport (io-loop (channel synonym-stream))
(io-channel-ioport io-loop (symbol-value (synonym-stream-symbol channel))))
;;; Callback channel implementation
(defclass callback-channel ()
((current :initform nil)
(stream :initarg :stream :reader callback-channel-stream)
(read-function :initform nil :initarg :read)
(write-function :initform nil :initarg :write)
(events :initform :auto :initarg :events :accessor callback-channel-events))
(:documentation
"Implements a convenience I/O channel which takes an underlying I/O
facility and calls the given callback functions when an event
occurs on the channel. The :STREAM init-argument specifies the I/O
facility to monitor, :READ specifies a function to be called back
when a read event occurs, and :WRITE a corresponding function for
write events. Timeouts are not supported.
By default, the channel will listen for read events iff a read
callback function is given and correspondingly for write events,
but CALLBACK-CHANNEL-EVENTS can be SETF'd to specify events
explicitly in case certain events are only interesting
sporadically. To restore default behavior, set it to :AUTO."))
(defmethod io-loop-add :before (info (channel callback-channel))
(when (slot-value channel 'current)
(error "Callback channel is already registered with an I/O loop")))
(defmethod io-loop-add :after (info (channel callback-channel))
(setf (slot-value channel 'current) info))
(defmethod io-loop-remove :after (info (channel callback-channel))
(setf (slot-value channel 'current) nil))
(defmethod io-channel-ioport (io-loop (channel callback-channel))
(io-channel-ioport io-loop (slot-value channel 'stream)))
(defmethod io-channel-events ((channel callback-channel))
(with-slots (events) channel
(if (eq events :auto)
(let ((ret '()))
(when (slot-value channel 'read-function)
(push :read ret))
(when (slot-value channel 'write-function)
(push :write ret))
ret)
events)))
(defmethod io-channel-handle ((channel callback-channel) (event (eql :read)) &key)
(funcall (slot-value channel 'read-function) channel))
(defmethod (setf callback-channel-events) (events channel)
(setf (slot-value channel 'events) events)
(with-slots (current) channel
(when current (io-loop-update current channel))))
Reference in a new issue View git blame Copy permalink