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.

More admin stuff today.

One thing interesting diversion was that a researcher at CMU asked to use some SBCL Lisp code I posted a while ago. I found this particularly cool as SBCL originated at CMU via CMUCL (“Steel” and “Bank” in “Steel Bank Common Lisp” refer to the source of Carnegie and Mellon’s individual fortunes).

I did a bit of Lisp experimentation this weekend with CFFI and GTK+2. CFFI is an abstraction over the Foreign Function Interfaces (basically C calls and callbacks) of various lisp implementations, and a replacement for UFFI. Anyway, interfacing to the basic GTK calls is pretty easy:

(require 'cffi)
(use-package :cffi)

;; GTK2 interface definitions

(load-foreign-library "libgtk-x11-2.0.so")

(defcfun ("gtk_init" gtk-init)
    :void
  (argc :pointer)
  (argv :pointer))

(defcfun ("gtk_window_new" gtk-window-new)
    :pointer
  (wtype :int))

(defcfun ("gtk_widget_show" gtk-widget-show)
    :void
  (widget :pointer))

(defcfun ("gtk_widget_show_all" gtk-widget-show-all)
    :void
  (widget :pointer))

(defcfun ("gtk_main" gtk-main)
    :void)

(defcfun ("gtk_main_quit" gtk-main-quit)
    :void)

(defcfun ("gtk_container_set_border_width" gtk-container-set-border-width)
    :void
  (widget :pointer)
  (width :int))

(defcfun ("gtk_button_new_with_label" gtk-button-new-with-label)
    :pointer
  (label :string))

(defcfun ("gtk_container_add" gtk-container-add)
    :void
  (container :pointer) 
  (button :pointer))

(defcfun ("g_signal_connect_data" g-signal-connect-data)
    :void
  (instance :pointer)
  (sig :string)
  (callback :pointer)
  (data :pointer)
  (gclosurenotify :pointer)
  (gconnectflags :int))

; This is a macro in gobject/gsignal.h
(defun g-signal-connect (instance sig callback data)
  (g-signal-connect-data instance sig callback data (null-pointer) 0))


;; GTK tests

(defcallback delete-event :int 
    ((widget :pointer)
     (event :pointer)
     (data :pointer))
  (format t "Got delete event, quitting~%")
  (gtk-main-quit)
  0)

(defcallback click-event :void
    ((widget :pointer)
     (event :pointer)
     (data :pointer))
  (format t "Got click!~%"))

(defun gtk-button-test ()
  (with-foreign-object (win :pointer)
      (gtk-init (make-pointer 0) (make-pointer 0))

      (setf win (gtk-window-new 0)) ; FIXME: 0 -> GTK_WINDOW_TOPLEVEL
      (g-signal-connect win "delete_event" 
                        (callback delete-event) (null-pointer))

      (gtk-container-set-border-width win 10)

      (with-foreign-object (button :pointer)
        (setf button (gtk-button-new-with-label "Press Me"))
        (g-signal-connect button "clicked"
                          (callback click-event) (null-pointer))
        (gtk-container-add win button))

      (gtk-widget-show-all win)
      (gtk-main)))

http://weblog.hypotheticalabs.com/?p=59

… if a developer is already familiar with one Algol-based language how much benefit will they receive from learning another Algol-based language? Most likely the developer will pick up a new syntax without learning any new core concepts.

I’ve been saying something like this for a while. We need to teach something to break students out of a single way of thinking about problem. I suggested Lisp, Scheme or a functional language, Masa suggested Smalltalk, Nick suggested Objective-C, but it doesn’t really matter as long as it’s sufficiently different to force students (and staff come to that) to re-evaluate how they think about problems.

I spent some of yesterday starting work on an XMPP library for Lisp, mostly some low-level XML-parsing stuff, as I’ve been threatening to do that for a while. Come in Monday morning and Lemonodor posts about one that’s already in progress. Ho Hum.

Update: It appears that the library doesn’t support SASL or TLS, so that precludes its use for most servers currently.

I spent a bit of the weekend on lisp-hacking and revisited my lisp version of the ‘Lattice’ server. I’d started this at LinuxConf but continually ran into issues with implementing truely asyncronous reads in SBCL’s sockets. There are various fragments of code showing how to do this around, but they all use Lisp’s native read, and my experiments show it would block, which is potentially disastrous in real-world usage. However I eventually worked out that I should be using sb-bsd-sockets:socket-receive, which is implemented with recvfrom. After nailing-down the various error conditions that can be returned (it’s rather inconsistent there) I now have a toy single-threaded server implementation:

(Update: as somebody has asked to use this, I hearby place my portions of the code in the public domain)

(require 'sb-bsd-sockets)

;; Most of the following is cribbed from the trivial-sockets package
;; (http://www.cliki.net/trivial-sockets).  I've ripped it out as it's
;; not clear that the return values will remain the same in future
;; versions and I need to get at the underlying file descriptors for
;; serve-event.
(defun resolve-hostname (name)
  (cond
    ((eql name :any)  #(0 0 0 0))
    ((typep name '(vector * 4)) name)
    (t (car (sb-bsd-sockets:host-ent-addresses
	     (sb-bsd-sockets:get-host-by-name name))))))

(defun open-server (&key (host :any) (port 0)
		    (reuse-address t)
		    (backlog 1)
		    (protocol :tcp))
  "Returns a server socket"
  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket 
			     :type :stream
			     :protocol protocol)))
    (when reuse-address
      (setf (sb-bsd-sockets:sockopt-reuse-address sock) t))
    (sb-bsd-sockets:socket-bind  sock (resolve-hostname host) port)
    (sb-bsd-sockets:socket-listen sock backlog)
    sock))

(defmacro with-server ((name arguments) &body forms)
  `(let (,name)
    (unwind-protect 
	 (progn
	   (setf ,name (open-server ,@arguments))
	   ,@forms)
      (when ,name (sb-bsd-sockets:socket-close ,name)))))

;; ;; End trivial-sockets ;; ;;

;; Server implementation

(defconstant +buflen+ 16)		; Short for overrun testing
(defstruct server-session
  sock ;; Socket returned by accept
  fd ;; Raw file handle
  stream ;; Lisp stream
  buffer ;; Pre-allocated incoming buffer
  handler ;; serve-event handler
  )

(defun data-received-handler (session)
  "Reads all pending characters on a socket into the session buffer"
  (format t "Got incoming data event ... ~%")
  (let ((buffer (server-session-buffer session))
        (sock (server-session-sock session)))
    (do ((fin nil))
	(fin t)
      (setf (fill-pointer buffer) +buflen+)
      (multiple-value-bind (buf len raddr)
          (sb-bsd-sockets:socket-receive sock buffer nil)
        (declare (ignore raddr))
        (if (null buf)
            (setf fin t)
            (setf (fill-pointer buffer) len)))
      (cond ((= (length buffer) 0)
             (format t "  Got 0 bytes, closing socket and removing handler~%")
             (sb-bsd-sockets:socket-close sock)
             (sb-sys:remove-fd-handler (server-session-handler session))
             (setf fin t))
            (fin (format t "Got NIL, returning~%"))
            (t 
             (format t "  Read ~a bytes: ~a~%" (length buffer) buffer))))))

(defun accept-handler(socket)
  (format t "I've got a new connection on fd ~a~%" socket)
  (let* ((conn (sb-bsd-sockets:socket-accept socket))
         (fd (sb-bsd-sockets:socket-file-descriptor conn))
         (session (make-server-session 
		   :sock conn
		   :fd fd
		   :stream (sb-bsd-sockets:socket-make-stream  
			    conn :input t :output t
			    :element-type 'character
			    :buffering :none)
		   :buffer (make-array +buflen+ 
				       :element-type 'character
				       :adjustable nil
				       :fill-pointer t)))
         (handler (sb-sys:add-fd-handler 
		   fd :input 
		   #'(lambda (fd) (declare (ignore fd))
			     (data-received-handler session)))))
    (format t "New socket is ~a~%" conn)(force-output)
    (setf (sb-bsd-sockets:non-blocking-mode conn) t)
    (setf (server-session-handler session) handler)))


(defun start-server ()
  (with-server (socket (:port 8000 :reuse-address t))
    (sb-sys:with-fd-handler ((sb-bsd-sockets:socket-file-descriptor socket)
                             :input #'(lambda (fd) (declare (ignore fd))
					      (accept-handler socket)))
      (loop ;; FIXME: End condition
       (format t "Entering serve-all-events...~%")(force-output)
       (sb-sys:serve-all-events)
       (format t "Events served~%")))))

While hacking on erlang and python the following occurs to me:

On being introduced to Lisp people always complain about all the parentheses. But the parentheses are always there; it’s just that in other languages you’re expected to mentally insert them yourself.

Had Monday off as I needed to do some shopping and have lunch with a friend who’s off to work in Madrid. But it’s back to work now, but first some google-juice …

Dog-training in Sydney (Leichhardt); It’s a volunteer organisation so is cheap. Ph: 02-9797-0508.

More Erlang/Lisp fusion work, this time based around Scheme: Termite.

I’m currently mirroring Rainer Joswig’s live video tutorial on developing DSLs in lisp. DSLs are something of a hot topic at the moment and Martin Fowler weighed-in recently, and Rainer produced a lisp-specific example and accompanying video. It’s an interesting example of how lisp development can differ from other languages through the use of interaction with the lisp runtime.