Some time ago I wrote a single-threaded server implementation in SBCL using its serve-event abstraction. However recently I’ve been working with ECL, which has some interesting possibilities due to its small size. However currently there is no abstraction of non-blocking IO, so I spent a bit of time porting the SBCL/CMUCL serve-event across. The hardest part about this was working out how to declare opaque C-structs with ECL lisp blocks in a robust way. In the end the old stalwart unsigned-char that saved the day, a technique I’ve documented elsewhere. But without further ado, the code:
(Update: This is now in ECL trunk; you can view an updated version here)
[lisp]
(defpackage “serve-event”
(:use “CL” “FFI” “UFFI”))
(in-package “serve-event”)
(clines “#include “)
(defstruct (handler
(:constructor make-handler (direction descriptor function))
(:copier nil))
;; Reading or writing…
(direction nil :type (member :input :output))
;; File descriptor this handler is tied to.
;; FIXME: Should be based on FD_SETSIZE
(descriptor 0)
;; Function to call.
(function nil :type function)
;; T if this descriptor is bogus.
bogus)
(defvar *descriptor-handlers* nil
#!+sb-doc
“List of all the currently active handlers for file descriptors”)
;;; Add a new handler to *descriptor-handlers*.
(defun add-fd-handler (fd direction function)
“Arrange to call FUNCTION whenever FD is usable. DIRECTION should be
either :INPUT or :OUTPUT. The value returned should be passed to
SYSTEM:REMOVE-FD-HANDLER when it is no longer needed.”
(unless (member direction ‘(:input :output))
;; FIXME: should be TYPE-ERROR?
(error “Invalid direction ~S, must be either :INPUT or :OUTPUT” direction))
(let ((handler (make-handler direction fd function)))
(push handler *descriptor-handlers*)
handler))
;;; Remove an old handler from *descriptor-handlers*.
(defun remove-fd-handler (handler)
#!+sb-doc
“Removes HANDLER from the list of active handlers.”
(setf *descriptor-handlers*
(delete handler *descriptor-handlers*)))
;;; Add the handler to *descriptor-handlers* for the duration of BODY.
(defmacro with-fd-handler ((fd direction function) &rest body)
“Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
use, and FUNCTION is the function to call whenever FD is usable.”
(let ((handler (gensym)))
`(let (,handler)
(unwind-protect
(progn
(setf ,handler (add-fd-handler ,fd ,direction ,function))
,@body)
(when ,handler
(remove-fd-handler ,handler))))))
(defmacro fd-zero(fdset)
`(c-inline (,fdset) (:object) :void
“FD_ZERO((fd_set*)#0->foreign.data)”
:one-liner t
:side-effects t))
(defmacro fd-set (fd fdset)
`(c-inline (,fd ,fdset) (:int :object) :void
“FD_SET(#0, (fd_set*)#1->foreign.data);”
:one-liner t
:side-effects t))
(defmacro fd-isset (fd fdset)
`(c-inline (,fd ,fdset) (:int :object) :int
“FD_ISSET(#0, (fd_set*)#1->foreign.data)”
:one-liner t
:side-effects t))
(defun fdset-size ()
(c-inline () () :int “sizeof(fd_set)” :one-liner t :side-effects nil))
(defun serve-event (&optional (seconds 0))
“Receive pending events on all FD-STREAMS and dispatch to the appropriate
handler functions. If timeout is specified, server will wait the specified
time (in seconds) and then return, otherwise it will wait until something
happens. Server returns T if something happened and NIL otherwise. Timeout
0 means polling without waiting.”
;; fd_set is an opaque typedef, so we can’t declare it locally.
;; However we can fine out its size and allocate a char array of
;; the same size which can be used in its place.
(let ((fsize (fdset-size)))
(with-foreign-objects ((rfd `(:array :unsigned-char ,fsize))
(wfd `(:array :unsigned-char ,fsize)))
(fd-zero rfd)
(fd-zero wfd)
(let ((maxfd 0))
;; Load the descriptors into the relevant set
(dolist (handler *descriptor-handlers*)
(let ((fd (handler-descriptor handler)))
(ecase (handler-direction handler)
(:input (fd-set fd rfd))
(:output (fd-set fd wfd)))
(when (> fd maxfd)
(setf maxfd fd))))
(let ((retval
(c-inline (rfd wfd (1+ maxfd) seconds)
(:object :object :int :int) :int
“{ struct timeval tv;
tv.tv_sec = #3;
tv.tv_usec = 0;
@(return) = select(#2, #0->foreign.data,
#1->foreign.data,
NULL, &tv); }”
:one-liner nil
:side-effects t)))
(cond ((zerop retval) nil)
((minusp retval)
(error “Error during select”))
(t
(dolist (handler *descriptor-handlers*)
(let ((fd (handler-descriptor handler)))
(if (plusp (ecase (handler-direction handler)
(:input (fd-isset fd rfd))
(:output (fd-isset fd wfd))))
(funcall (handler-function handler)
(handler-descriptor handler))))))))))))
;;; Wait for up to timeout seconds for an event to happen. Make sure all
;;; pending events are processed before returning.
(defun serve-all-events (&optional (timeout 0))
“SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
T if SERVE-EVENT did something and NIL if not.”
(do ((res nil)
(sval (serve-event timeout) (serve-event 0)))
((null sval) res)
(setq res t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test Example
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (defun test-stdin ()
;; (format t “DOING STDIN~%”)
;; (with-fd-handler (0 :input #’(lambda (fd) (declare (ignore fd))
;; (format t “Got data~%”)
;; (read-char)))
;; (loop ;; FIXME: End condition
;; (format t “Entering serve-all-events…~%”)(force-output)
;; (serve-all-events 5)
;; (format t “Events served~%”))))
[/lisp]
I’ve submitted a patch to the ECL list, and there’s been some interest in integrating it so it should be part of it soon.
Update: This was added in the ECL 0.9j release.
