[insert blog here]
Linux Console Graphics with, DRM , GBM , EGL , GLES , logind , libinput , etc. in CLMon, 22 Feb 2021 15:35:49 CST

Continuing from Part 1, the next step is input.

Just commented code this time...

;; osicat wants pointers, but some of the ioctls we use want ints, so
;; add a wrapper
(defun ioctl/p (fd req arg)
  (nix:ioctl fd req (cffi:make-pointer arg)))
;; some ioctl constants i couldn't find in osicat
(defconstant +KDGKBMODE+ #x4B44)
(defconstant +KDSKBMODE+ #x4B45)
(defconstant +K-OFF+ #x04)
(defconstant +KDSKBMUTE+ #x4B51)
(defconstant +KDSETMODE+ #x4B3A)
(defconstant +KD-TEXT+ #x00)
(defconstant +KD-GRAPHICS+ #x01)

;; minimal udev bindings to use libinput udev backend

(cffi:define-foreign-library libudev
  (:unix (:or "libudev.so.1"
  (t (:default "libudev")))

(cffi:use-foreign-library libudev)

(cffi:defcfun ("udev_new" udev-new) :pointer)

(cffi:defcfun ("udev_ref" udev-ref) :pointer
  (udev :pointer))

(cffi:defcfun ("udev_unref" udev-unref) :pointer
  (udev :pointer))

;; store some closure to let us open/close devices from outside
;; lexical scope of the WITH-DBUS* macro
(defvar *take-device*)
(defvar *release-device*)

;; callbacks that let us handle opening devices for libinput
(cffi:defcallback open-restricted :int
    ((path :string) (flags :int) (user-data :pointer))
  (declare (ignorable flags user-data))
  (format t "Called open-restricted path = ~s = ~s~%" path (path-device path))
  (let ((fd (funcall *take-device* path)))
    (format t "File descriptor ~A~%" fd)
    (when (< fd 0)
      (warn "Failed to open ~A" path))

(cffi:defcallback close-restricted :void ((fd :int) (user-data :pointer))
  (declare (ignorable user-data))
  (funcall *release-device* fd))

;; allocate struct used to pass our callbacks to libinput
(defun make-libinput-interface ()
  (let ((interface (cffi:foreign-alloc
                    '(:struct libinput::libinput-interface))))
    (cffi:with-foreign-slots ((libinput::open-restricted
                              (:struct libinput::libinput-interface))
      (setf libinput::open-restricted (cffi:callback open-restricted))
      (setf libinput::close-restricted (cffi:callback close-restricted)))

;; variable to tell it to exit event loop
(defparameter *stop* t)

;; we need major/minor for an open FD to use in close callback
(defun fd-device (fd)
  ;; return device major/minor for a given fd
  (let ((rdev (nix:stat-rdev (nix:fstat fd))))
    (list (ldb (byte 8 8) rdev) (ldb (byte 8 0) rdev))))

(with-dbus* (l lc lp s sc sp)
  ;; we need to be in control of the session
  (sc "TakeControl" nil)
  ;; set our callbacks to open/close files using logind
  (setf *take-device* (lambda (path)
                        (apply #'sc "TakeDevice"
                               (path-device path))))
  (setf *release-device* (lambda (fd)
                           (format t "release device ~s = ~s~%"
                                   fd (fd-device fd))
                           ;; apparently we should close the fd before
                           ;; releasing it?
                           (let ((dev (fd-device fd)))
                             (nix:close fd)
                             (apply #'sc "ReleaseDevice" dev))))

  (let* ((tty (sp "TTY"))
         (tty-path (format nil "/dev/~a" tty))
         (seat (car (sp "Seat")))
         ;; o-noctty since we don't care about the state of the
         ;; terminal itself. TakeControl gives us permissions to open
         ;; the tty, so normal nix:open works for this.
         (tty-fd (nix:open tty-path (logior nix:o-rdwr nix:o-noctty)))
         ;; state we will initialize below
         (old-keyboard-mode nil)
         (udev nil)
         (context nil)
         (libinput-fd nil)
    ;; next we try to mute the tty, or otherwise set mode to off.
    ;; Handler-case is needed since osicat negative return to errors,
    ;; and here failure of the first ioctl is OK
        (ioctl/p tty-fd +kdskbmute+ 1)
      (nix:posix-error ()
        (cffi:with-foreign-object (old-mode :int)
          (nix:ioctl tty-fd +kdgkbmode+ old-mode)
          (setf old-keyboard-mode (cffi:mem-ref old-mode :int)))))
    ;; set terminal to graphics mode to avoid it trying to draw any
    ;; text or cursor over our graphics
    (ioctl/p tty-fd +kdsetmode+ +kd-graphics+)

    ;; we will use the udev backend of libinput, so we don't need to
    ;; manually find devices and track hotplug

    ;; first get a udev device
    (setf udev (udev-new))
    ;; create a libinput context, passing it our custom open/close functions
    (setf context (libinput:udev-create-context
                   (setf interface (make-libinput-interface))
    ;; optional: set libinput to send verbose log info to
    ;; console. Getting log output from CL would require callbacks
    ;; with support for variadic arguments, which isn't supported by
    ;; cffi or libffi, so would need a C wrapper lib or ABI specific
    ;; hacks.
    (libinput:log-set-priority context :debug)
    ;; tell libinput to use devices from our seat (will find all
    ;; usable devices and call our callbacks to open them)
    (libinput:udev-assign-seat context seat)
    ;; grab the FD from libinput so we can poll it for events
    (setf libinput-fd (libinput:get-fd context))
    (format t "got fd ~s from libinput~%" libinput-fd)
    ;; run initial event dispatch. Does some internal state
    ;; processing and adds `device-notify` events to libinput's
    ;; internal event queue
    (libinput:dispatch context)

    ;; now we are ready to do some input:

    ;; again, we should be using select/poll/epoll/etc to watch
    ;; LIBINPUT-FD for events, but will just busy wait. In particular,
    ;; while events can sit in the queue for a bit without any
    ;; problem, LIBINPUT:DISPATCH needs to be called immediately after
    ;; FD is readable for its internal state processing to work
    ;; correctly.
    (setf *stop* nil)
    (format t "waiting for input:~%")
      do (libinput:dispatch context)
         ;; loop over all available events
           for ev = (libinput:get-event context)
           until (or *stop*
                     ;; get-event returns null pointer if no events
                     ;; available, at which point we go back to outer
                     ;; loop and call dispatch again
                     (cffi:null-pointer-p ev))
           do (unwind-protect
                   ;; get some info common to all events
                   (let* ((et (libinput:event-get-type ev))
                          (dev (libinput:event-get-device ev)))
                     ;; handle some of the events I will see on my device
                     (case et
                        ;; we get one of these for every input device
                        ;; connected to the seat when we created
                        ;; context, and any that are added later
                        (format t "added device ~s ~s (~s)~%"
                                (libinput:device-get-name dev)
                                (libinput:device-get-output-name dev)
                                (libinput:device-get-sysname dev))
                        ;; print out what ssort events the new device
                        ;; can generate
                        (loop with caps = '(0 :keyboard
                                            1 :pointer
                                            2 :touch
                                            3 :tablet-tool
                                            4 :tablet-pad
                                            5 :gesture
                                            6 :switch)
                              for i below 8
                              when (plusp (libinput:device-has-capability
                                           dev i))
                                do (format t "  has capability ~s~%"
                                           (getf caps i))))
                        (format t "removed device ~s ~s (~s)~%"
                                (libinput:device-get-name dev)
                                (libinput:device-get-output-name dev)
                                (libinput:device-get-sysname dev)))
                       ;; I don't have a keyboard or mouse on this
                       ;; system, so just handling touch events see
                       ;; libinput docs for full list of events
                       ((#.libinput:touch-down #.libinput:touch-motion)
                        ;; for most events, we need to get
                        ;; device-specific event data from generic
                        ;; event to get details
                        (let ((ev2 (libinput:event-get-touch-event ev)))
                          (format t "~%touch ~s @ ~5,3f~%"
                                  (if (= et libinput:touch-down)
                                      "down" "motion")
                                  ;; most input events have timestamps
                                  ;; in usec, not guaranteed to always
                                  ;; be increasing though
                                  (* (libinput:event-touch-get-time-usec ev2)
                          (format t "~&   ~s, ~s @ ~5,3f,~5,3f || ~5,3f,~5,3f~%"
                                  (libinput:event-touch-get-slot ev2)
                                  (libinput:event-touch-get-seat-slot ev2)
                                  ;; this is supposedly in mm, but i get
                                  ;; device coords from 0 to 4096 from my
                                  ;; touchscreen
                                  (libinput:event-touch-get-x ev2)
                                  (libinput:event-touch-get-y ev2)
                                  ;; to get screen coordinates, we need to
                                  ;; pass screen size to these, 800x480 in
                                  ;; my case
                                   ev2 800)
                                   ev2 480))))
                         ;; touch-frame event is used to group
                         ;; multiple events when there are multiple
                         ;; touches at once.
                        (let ((ev2 (libinput:event-get-touch-event ev)))
                          (format t "~%touch ~a @ ~5,3f~%"
                                  (if (eql et libinput:touch-up)
                                      "up" "frame")
                                  ;; most input events have timestamps
                                  ;; in usec, not guaranteed to always
                                  ;; be increasing though
                                  (* (libinput:event-touch-get-time-usec ev2)
                        ;; there are also keyboard, pointer, switch,
                        ;; tablet and gesture (for things like
                        ;; multitouch pinch/rotate etc) which are
                        ;; similar.
                        (format t "got event type ~s from device ~s~%"
                                et dev))))
                ;; clean up the event when we are done with it
                (libinput:event-destroy ev)))
      until *stop*)

    ;; finally, clean everything up

    ;; reset TTY state
    (if old-keyboard-mode
        (ioctl/p tty-fd +kdskbmode+ old-keyboard-mode)
        (ioctl/p tty-fd +kdskbmute+ 0))
    (ioctl/p tty-fd +kdsetmode+ +kd-text+)
    ;; and close fd
    (nix:close tty-fd)
    ;;(apply #'sc "ReleaseDevice" (fd-device tty-fd))
    ;; close libinput context (will call our callbacks to close devices)
    (libinput:unref context)
    ;; close udev device
    (udev-unref udev)
    ;; delete foreign mem for callback struct
    (cffi:foreign-free interface)
    ;; stop keeping bus/etc vars live with closures in global variables
    (setf *take-device* nil)
    (setf *release-device* nil)
    (sc "ReleaseControl")))

gives output like

Called open-restricted path = "/dev/input/event0" = (13 64)
File descriptor 15
Called open-restricted path = "/dev/input/event2" = (13 66)
File descriptor 16
Called open-restricted path = "/dev/input/event3" = (13 67)
File descriptor 17
Called open-restricted path = "/dev/input/event1" = (13 65)
File descriptor 18
got fd 12 from libinput
waiting for input:
 added device "gpio_keys" NIL ("event0")
 has capability :KEYBOARD
 added device "WaveShare WS170120" NIL ("event2")
 has capability :TOUCH
 added device "RC for dw_hdmi" NIL ("event3")
 has capability :KEYBOARD
 added device "sunxi-ir" NIL ("event1")
 has capability :KEYBOARD

touch "down" @ 160006.352
   0, 0 @ 1658.000,1725.000 || 323.828,202.148

touch frame @ 160006.352

touch "motion" @ 160006.362
   0, 0 @ 1626.000,1755.000 || 317.578,205.664

touch frame @ 160006.362

touch "motion" @ 160006.372
   0, 0 @ 1623.000,1775.000 || 316.992,208.008

touch frame @ 160006.372

<more motion events skipped>

touch "motion" @ 160006.420
   0, 0 @ 1613.000,1810.000 || 315.039,212.109

touch frame @ 160006.420

touch up @ 160006.424

touch frame @ 160006.424
release device 15 = (13 64)
release device 16 = (13 66)
release device 17 = (13 67)
release device 18 = (13 65)

Linux Console Graphics with, DRM , GBM , EGL , GLES , logind , libinput , etc. in CLSun, 21 Feb 2021 01:56:47 CST

I want glop2 to support running directly on Linux console without X or Wayland or whatever, and happened to want to run some code on an arm board with flaky X drivers, so spent some time trying to figure out how to get that running. This post is my notes on what I've figure out so far, for when I get around to actually implementing glop2.

Device permissions

The image I had on the arm board is Ubuntu, using systemd, so I use logind to manage devices instead of opening them directly. This simplifies some aspects of permissions, since if you are running on a particular seat, you can automatically access any devices associated with that seat. In other ways, it is more complicated, since if you connect over ssh you don't have a seat and can't access anything.

On other systems, would probably want to add the user to whatever groups have access to the /dev/dri/card*/ and /dev/input/event* devices, and open them manually.

Since I was too lazy to go find a keyboard to plug into the device to control a seat, and also because I wanted to boot directly into the program when it was done, I ended up configuring the getty@tt1 service to login automatically (and tell systemd not to start X as well).

$ sudo systemctl disable lightdm
$ sudo systemctl edit getty@tty1

then add

ExecStart=-/sbin/agetty --autologin username --noclear %I

and tell ~/.profile to automatically run a lisp image running a swank swank server when run on tty1. Also send all output to a file since we can't see console while running graphics, and can't scroll up in console output without a keyboard.

tty=`ps -p $$ -o tty=`
if [ "$tty" = tty1 ]; then
    ~/bin/foo > ~/debug-log 2>&1

Then it boots I can just restart the getty to restart the image when I get things in a bad state, or want to see if my program works correctly when started directly.

$ sudo systemctl restart getty@tty1

Getting access to the seat

Once the system is set up, the next step is talking to logind to get access to the seat, activate it, etc. For that, we need to use DBUS. I used the dbus library. We'll also need a few other libraries, so load all of those as well (or add them to dependencies in an .asd file and load that).

(ql:quickload '(:alexandria :cffi :osicat :dbus :cl-drm :cl-gbm :cl-egl :cl-libinput :cl-opengl/es2))
;; Might need to manually download cl-libinput from
;;  https://github.com/malcolmstill/cl-libinput if it isn't in QL yet.

;; Parts of this might also need my forks from https://github.com/3b/
;; if I haven't gotten them cleaned up enuogh to submit upstream yet, or
;; from upstream sources if I have but they haven't hit QL yet.

;; Substitute normal :cl-opengl if desired if it is available on your
;; system.

For real use, would want to store a single dbus connection, and reuse the objects, but for interactive examples, lets define some helper macros.

(defvar *bus*)

(defmacro with-dbus (() &body body)
  `(dbus:with-open-bus (*bus* (dbus:system-server-addresses))

(defmacro with-object ((object call path destination)
                                    &body forms)
  `(let ((,object (dbus:make-object-from-introspection
                   (dbus:bus-connection *bus*) ,path ,destination)))
     (flet ((,call (interface-name method-name &rest args)
              (apply #'dbus:object-invoke ,object
                     interface-name method-name args)))

Now we can make some calls and see if things are working:

(with-dbus ()
  (with-object (o call "/org/freedesktop/login1"
    (call "org.freedesktop.login1.Manager"

;; Here I have 2 SSH sessions open, with seat = "", and one console
;; session, "seat0"

;; session id, uid, username, seat name, session name
(("4" 1001 "3b" "" "/org/freedesktop/login1/session/_34")
 ("14" 1001 "3b" "seat0" "/org/freedesktop/login1/session/_314")
 ("3" 1001 "3b" "" "/org/freedesktop/login1/session/_33"))

(with-dbus ()
  (with-object (o call "/org/freedesktop/login1"
    (call "org.freedesktop.login1.Manager"

;; There is one seat
(("seat0" "/org/freedesktop/login1/seat/seat0"))

;; but what we really want to know is which one we are currently using:

(with-dbus ()
  (with-introspected-object (o call "/org/freedesktop/login1"
    (call "org.freedesktop.login1.Manager"
       "GetSessionByPID" (nix:getpid))))

;; ->

See https://www.freedesktop.org/software/systemd/man/org.freedesktop.login1.html for the full list of APIs available from logind.

Most of the rest will be using the Manager or Session interfaces, so lets wrap that up into another macro.

(defmacro with-dbus* ((login lcall lprop session scall sprop)
                      &body body)
  (alexandria:with-gensyms (session-name)
    `(dbus:with-open-bus (*bus* (dbus:system-server-addresses))
       (let ((,login (dbus:make-object-from-introspection
                      (dbus:bus-connection *bus*)
         (flet ((,lcall (interface-name method-name &rest args)
                  (apply #'dbus:object-invoke ,login
                         interface-name method-name args))
                (,lprop (property)
                  (dbus:get-property *bus*
           (declare (ignorable #',lcall #',lprop))
           (let* ((,session-name (,lcall "org.freedesktop.login1.Manager"
                                         "GetSessionByPID" (nix:getpid)))
                  (,session (dbus:make-object-from-introspection
                             (dbus:bus-connection *bus*)
             (flet ((,scall (method-name &rest args)
                      (apply #'dbus:object-invoke ,session
                             method-name args))
                    (,sprop (property)
                      (dbus:get-property *bus*
               (declare (ignorable #',scall #',sprop))

Add one more helper to translate paths to the major + minor device numbers logind wants, and we are ready to start doing graphics.

(defun path-device (path)
  ;; return device major/minor for a given path
  (let ((rdev (nix:stat-rdev (nix:stat path))))
    (assert (not (zerop rdev)))
    (list (ldb (byte 8 8) rdev) (ldb (byte 8 0) rdev))))

(defmacro with-card ((fd) &body body)
  ;; not bothering with gensyms here since we might want access to the
  ;; various bindings created here, and real code would probably be
  ;; factored out differently instead of using a macro like this
  `(with-dbus* (l lc lp s sc sp)
     ;; first we need to take control of the session
     (sc "TakeControl" nil)

     ;; then open the DRI device. Currently I just hard-code
     ;; "/dev/dri/card0", not sure what the "correct" way to find it is
     ;; yet. Possibly looking for "/run/udev/tags/<seat>/+drm*" and
     ;; parsing the name? (where <seat> is "seat" for seat0, otherwise
     ;; name of seat?) Maybe something with libudev?
          (multiple-value-bind (,fd paused)
              (apply #'sc "TakeDevice"
                     (path-device "/dev/dri/card0"))
            (when ,fd
                     ;; if the session is paused, we can try activating it
                     (when paused
                       (sc "Activate"))

              ;; Releasing the session below implicitly releases
              ;; devices, but we can do it manually too
              (apply #'sc "ReleaseDevice"
                     (path-device "/dev/dri/card0"))
              ;; but apparently we still need to close the FD
              ;; ourselves (don't see it mentioned in logind docs,
              ;; aside from needing to close old fd after Resume
              ;; events, but FDs stay open without it)
              (nix:close fd)))
       ;; when we are done, we need to release the session
       (sc "ReleaseControl"))))

(with-card (fd)
  (format t "got FD ~s for DRM device~%" fd))

For real code we should also watch for DBUS events indicating devices have been Paused/Resumed, screen has been Locked/Unlocked, changes in session Active or Idle state, or if the system is shutting down or sleeping.

Adding graphics

Once we have a DRM fd open, we can use it to switch to graphics mode and set up OpenGL ES (or normal GL if you have it).

We can query some capabilities with drm:get-cap:

(cffi:defcenum (drm-caps :uint64)
  (:dumb-buffer #x1)
  (:vblank-high-crtc #x2)
  (:dumb-preferred-depth #x3)
  (:dumb-prefer-shadow #x4)
  (:prime #x5)
  (:timestamp-monotonic #x6)
  (:async-page-flip #x7)

;;;; on my machine:
;;  :DUMB-BUFFER = 1
;;  :PRIME = 3
;;  :CURSOR-WIDTH = 64

In particular the :async-page-flip = 0 here means we need to use event-based page flipping rather than asynchronous.

Now we set up the various graphics libraries (drm, gbm, egl), handle page flipping, and then we can do some simple drawing.

;;; for double-buffered display wwith vsync, we need to set up some
;;; handlers for drm events

(cffi:defcallback vblank-handler :void ((fd :int)
                                        (seq :unsigned-int)
                                        (sec :unsigned-int)
                                        (usec :unsigned-int)
                                        (user-data (:pointer :void)))
  (declare (ignorable fd seq sec usec user-data))
  ;; vblank event seems not be sent by default, not sure how to enable
  ;; them

(defparameter *flipping* nil)
(cffi:defcallback page-flip-handler :void ((fd :int)
                                           (seq :unsigned-int)
                                           (sec :unsigned-int)
                                           (usec :unsigned-int)
                                           (user-data (:pointer :void)))
  (declare (ignorable fd seq sec usec user-data))
  (setf *flipping* nil))

(defun make-drm-event-context ()
  (let ((p (cffi:foreign-alloc '(:struct drm:event-context))))
    (cffi:with-foreign-slots ((drm:version
                              p (:struct drm:event-context))
      (setf drm:version 2)
      (setf drm:vblank-handler (cffi:callback vblank-handler))
      (setf drm:page-flip-handler (cffi:callback page-flip-handler)))

(with-card (fd)
  ;; drm:find-display-configuration picks a connector and mode for us,
  ;; which is good enough for my current needs. If you want to support
  ;; multiple monitors or change modes you might need to do it
  ;; yourself.
  (let* ((display-config (drm:find-display-configuration fd))
         ;; some slots from the display-config we will need later
         (mode-info (drm:mode-info display-config))
         (crtc (drm:crtc display-config))
         ;; To do any output, we need buffers in which to store it,
         ;; and from which the card can display them.  libgbm (Generic
         ;; Buffer Management) is responsible for managing those
         ;; buffers, so we need to initialize it as well.
         (gbm (gbm:create-device fd))
         ;; get an EGL display from the GBM device
         ;; (get-platform-display is in egl 1.5, but my board only has
         ;; 1.4. Should query versions and check extensions before
         ;; doing this...)
         (display (egl:get-platform-display-ext :platform-gbm-khr

    ;; initialize EGL on the display (returns major / minor version
    ;; numbers as 2 values)
    (format t "egl init ~s~%" (multiple-value-list (egl:initialize display)))
    ;; tell EGL which API we want to use, :opengl-api for desktop GL
    (egl:bind-api :opengl-es-api)
    ;; and verify we got it
    (format t "egl api ~s~%" (egl:query-api))

    ;; print out some information on available APIs, driver being
    ;; used, and available extensions
    (loop for i in '(:client-apis :vendor :version :extensions)
          do (format t "~s: ~s~%"
                     i (egl:query-string display i)))

    ;; set up a gles context
    (let* ((configs (egl::choose-config* display
                                         :buffer-size 32
                                         :depth-size :dont-care
                                         :stencil-size :dont-care
                                         :surface-type :window-bit
                                         :renderable-type :opengl-es2-bit
           ;; we'll just use the first one here
           (config (car configs))
           ;; create a context, ask for GLES2
           (context (egl:create-context display
                                        :context-major-version 2
           ;; get dimensions of the mode
           (width (drm:mode-width mode-info))
           (height (drm:mode-height mode-info))
           ;; create a GBM surface we can draw into
           (gbm-surface (gbm:surface-create gbm
                                            width height
                                            875713112 ;; xrgb8888
                                            5)) ;; scanout | rendering
           ;; create an egl surface from the gbm surface
           (egl-surface (egl:create-window-surface display config
                                                   gbm-surface :none))
           ;; configuration for drm event handler
           (event-context (make-drm-event-context))
           ;; page flipping code is a bit verbose, so we'll store some
           ;; state in a list to pass to it. Should all be in proper
           ;; classes or whatever for real code
           (flip-state (list nil nil ;; some state variables
                             fd display egl-surface gbm-surface
                             crtc width height)))
      ;; see what configs are available
      (loop for i from 0
            for c in configs
            do (format t "~%egl config ~s:~% ~s~%" i
                       (egl:get-config-attribs display c)))

      ;; print some info about the EGL surface we created
      (format t "~%~%EGL surface properties:~%")
      (loop for i in '(:width :height
                       :horizontal-resolution :vertical-resolution
                       :render-buffer :swap-behavior)
            do (format t "  ~s = ~s~%" i
                       (egl:query-surface display egl-surface i)))

      ;; make the egl context current
      (unless (zerop (egl:make-current display
                                       ;; we will read from and draw
                                       ;; to same surface
                                       egl-surface egl-surface
      ;; reset the page flip flag
      (setf *flipping* nil)

      ;; now we should be able to start drawing. Since gles2 requires
      ;; VBOs and shaders, we'll just clear the screen to random
      ;; colors for a few second...
      (loop repeat 3000
            do (gl:clear-color (random 1.0) (random 1.0) (random 1.0) 1)
               (gl:clear :color-buffer)
               (swap-buffers flip-state))

      ;; when we are done, clean everything up (should probably use a
      ;; few unwind-protects here)
      (when crtc
        ;; restore the original crtc settings
        (cffi:with-foreign-object (connector-id :uint32)
          (setf (cffi:mem-ref connector-id :uint32)
                (drm::connector-id display-config))
          (cffi:with-foreign-slots ((drm:crtc-id drm:buffer-id drm:x drm:y)
                                    (:struct drm:mode-crtc))
            (drm:mode-set-crtc fd
                               drm:crtc-id drm:buffer-id drm:x drm:y
                               connector-id 1
                                crtc '(:struct drm:mode-crtc) 'drm:mode))
            (drm:mode-free-crtc crtc))))
      ;; clean up buffers used for page flipping
      (when (car flip-state)
        (drm:mode-remove-framebuffer fd (first flip-state))
        (gbm:surface-release-buffer gbm-surface (second flip-state)))
      ;; destroy surfaces
      (egl:destroy-surface display egl-surface)
      (gbm:surface-destroy gbm-surface)
      ;; destroy context
      (egl:destroy-context display context)
      ;; close display
      (egl:terminate display)
      ;; close gbm device
      (gbm:device-destroy gbm)
      ;; free event-context
      (cffi:foreign-free event-context))))

(defun swap-buffers (flip-state)
  (destructuring-bind (old-fb old-bo
                       fd display egl-surface gbm-surface
                       crtc width height) flip-state
    ;; if we have scheduled a page flip, wait for the completion
    ;; event. Real code should use select/poll/epoll/etc to wait for
    ;; the FD to be readable instead of busy-waiting like this.
    (loop do (drm:handle-event fd event-context)
          while *flipping*
          do (sleep 0.001))
    ;; first swap the EGL buffers
    (egl:swap-buffers display egl-surface)
    ;; call surface-lock-front-buffer once per egl:swap-buffers to get
    ;; a gbm `bo` (buffer object) for the front buffer
    (let* ((bo (gbm:surface-lock-front-buffer gbm-surface))
           ;; get some slots from the BO we will be using later
           (handle (gbm:bo-get-handle bo))
           (stride (gbm:bo-get-stride bo)))

      (cffi:with-foreign-objects ((fb :uint32))
        ;; create a framebuffer using the bo associated with HANDLE for
        ;; storage
        (drm:mode-add-framebuffer fd width height
                                  24 32 stride handle fb)
        ;; set flag indicating we scheduled a page flip
        (setf *flipping* t)
        ;; schedule a page flip for next vblank to display the new
        ;; framebuffer, and request and event when the flip completes

        ;; if we wanted double-buffer without vsync, we could use
        ;; drm:mode-set-crtc instead to swap immediately. Probably can
        ;; also configure it to draw directly to a single framebuffer
        ;; for single-buffered display.
        (drm:mode-page-flip fd (drm:crtc-crtc-id crtc)
                            (cffi:mem-aref fb :uint32)
                            1 ;; 1 = event, 2 = async
        ;; after the first frame, we need to clean up the previous
        ;; frame
        (when old-bo
          (drm:mode-remove-framebuffer fd old-fb)
          (gbm:surface-release-buffer gbm-surface old-bo))

        ;; write state back into input list for next call
        (setf (first flip-state) (cffi:mem-ref fb :uint32)
              (second flip-state) bo)))))

Similar to the logind events, we should also be watching for lost contexts, etc in the graphics code.

Continuous Integration in Common Lisp with Github Actions , Part 3: portability testing, msys, misc hacksFri, 25 Sep 2020 14:41:17 CDT

edit 2020/09/27: Updated msys info

For pngload, we wanted it to run on as many implementations as possible. To test this, we run tests on every combinations of implementation and OS easily supported by the combination of github actions and roswell.

  • sbcl32 and clisp32 are supported as nicknames of sbcl and clisp respectively, but still install 64-bit binaries on 64-bit OS.

  • Roswell can build clasp, but that takes too long to run on github CI servers (and pngload doesn't run on clasp yet anyway), so that is skipped for now. Eventually, it could be modified to pull a pre-built binary from another repo.

  • The available MacOS version doesn't seem to run 32 bit binaries, so we can't test ccl32, allegro, or cmucl there.

  • The clisp binary on MacOS doesn't support FFI, so is skipped.

  • sbcl-bin on MacOS is too old, so skip that as well

  • Some implementations don't install properly on the windows VM, so allegro, cmucl, abcl, ecl, and clisp are skipped there.

As far as I could tell, we need to explicitly list each combination we don't want, which is a bit verbose.

    name: ${{ matrix.lisp }} on ${{ matrix.os }}
        lisp: [sbcl-bin,sbcl,ccl,ccl32,ecl,clisp,allegro,cmucl,abcl]
        os: [ubuntu-latest, macos-latest, windows-latest]
          # skip 32bit lisps on osx
            - os: macos-latest
              lisp: ccl32
            - os: macos-latest
              lisp: allegro
            - os: macos-latest
              lisp: cmucl
          # CFFI requires CLISP compiled with dynamic FFI support.
            - os: macos-latest
              lisp: clisp
          # sbcl-bin is too old on macos
            - os: macos-latest
              lisp: sbcl-bin
          # some implementations don't install properly on windows?
            - os: windows-latest
              lisp: allegro
            - os: windows-latest
              lisp: cmucl
            - os: windows-latest
              lisp: abcl
            - os: windows-latest
              lisp: ecl
            - os: windows-latest
              lisp: clisp
      fail-fast: false

To build latest sbcl release on windows, we need to configure the windows runner to use msys2 instead of the default git-bash normally used for shell: bash. (Actually we could probably build sbcl manually using whatever random combination of tools are in the PATH already, but Roswell will waste time trying to install msys anyway if it doesn't find it)

We will use the setup-msys2 action from msys2 to configure it, since manually installing things on top of the default installation is either slow or unreliable. (Status of msys2 on github actions is currently being worked on, so some of this will probably change in the near future. See

for more info on what is changing, and what the problems are.)

First we set the default shell on windows to msys2, which will be configured below.

# under jobs: test:
        # set "msys2" as default shell on windows
        # couldn't find any better way to do this, but seems to work?
        shell: ${{ fromJSON('[ "bash", "msys2 {0}" ]') [ matrix.os == 'windows-latest' ] }}

Then we use the msys2/setup-msys2@v2 action to configure msys2 on windows.

We want to build sbcl with mingw64, so set msystem to indicate that, and we want to see the $PATH entries added by ::add-path:: so set path-type to inherit.

If we need to install anything not included in the base image, or need to be sure it is the very latest (images are rebuilt every few weeks, so generally not very old anyway), we need to pass update: true. Usually we don't actually need everything installed by default, and updating everything would be slow, so usually we also want release: true when using update: true. Once it is updated, we can add install: 'whatever packages we need', but since we used release: true we need to specify everything we want that isn't in the base msysy2 install.

Installing without update: will usually work, but msys2 doesn't officially support installing things without updating the system first, so you will probably eventually get some random failures from that.

    - uses: msys2/setup-msys2@v2
        path-type: inherit
        msystem: MINGW64
        # set these to true if we want to install things from pacman
        release: false
        update: false
        # list all packages we want installed if using release&update true

        # for example the following would be enough for us to build sbcl
        # from git:
        # install: 'git base-devel unzip mingw-w64-x86_64-gcc mingw64/mingw-w64-x86_64-zlib'

In the windows specific config, we need to add the roswell bin dir under pwsh's $HOME to the $PATH, since it ends up there instead of under msys' home dir.

We also need to set MSYSCON so Roswell doesn't try to install its own copy of msys2.

    - name: windows specific settings
      if: matrix.os == 'windows-latest'
      shell: pwsh
      run: |
        git config --global core.autocrlf false
        echo "::add-path::$HOME/.roswell/bin"
        echo "::set-env name=MSYSCON::defterm"

Clisp doesn't currently build on ubuntu-latest ( https://sourceforge.net/p/clisp/bugs/688/ ), so manually install it

    - name: install clisp from apt
      if: matrix.lisp == 'clisp' && matrix.os == 'ubuntu-latest'
      run: |
        sudo apt install clisp
        ros use clisp/system
        ros install asdf

Unfortunately, while that gives us a runnable clisp, it still never finishes the CI run. It also doesn't give any indication of what is wrong, so clisp is disabled on linux too for now.

For pngload, there were some bugs that only showed up when compiled+loaded in one image, or when loaded from precompiled .fasl files, due to things like differences in handling of DEFCONSTANT or other compile-time side effects.

To test that, tests are run twice, once from a clean fasl cache, and again from cached fasls from previous run.

    - name: clear fasl cache
      run: |
        rm -rf ~/.cache/common-lisp/
        mkdir -p ~/.cache/common-lisp/

    - name: load code from clean fasl cache and run tests
      run: |
        run-test-forms -l pngload.test '(pngload.test:run-tests-for-ci)'

    - name: load code from fasls and run tests
      run: |
        run-test-forms -l pngload.test '(pngload.test:run-tests-for-ci)'

Finally, to hack around some libraries that work on cmucl but don't compile cleanly, compile it separately while ignoring errors so the compile+load during testing works.

    - name: cmucl hax
      # cmucl gets some build errors on deps we don't actually need, so try a few extra loads to get past that
      continue-on-error: true
      if: matrix.lisp == 'cmucl'
      run: |
        ros -e '(ql:quickload :skippy)'
        ros -e '(ql:quickload :skippy)'

(Had time to try a fix for that and send a PR, so actual pngload repo pulls a fork instead of the above workaround)

Continuous Integration in Common Lisp with Github Actions , Part 2: pulling code from github, Ci-utils , and test frameworks.Sun, 13 Sep 2020 15:36:23 CDT

In part 1, I described the basics of how I set up CI on github actions. This time, I'll use CI-Utils and show some examples of its scripts for using various testing frameworks.

repo for part 2

Manual git checkouts for dependencies

Sometimes we need to update multiple projects at once, and tests in one won't pass if we don't have the current version of the other. Or maybe we need things that aren't in Quicklisp to start with.

In that case, we can manually check out the other project until QL picks up the changes. (Adding an action to remind you to undo it in a month is left as an exercise for the reader).

Roswell's install-for-ci.sh script adds ~/lisp/ to the ASDF search path, so we just need to create that and check out other projects there.

See the readme for the checkout action for full details on how to configure it.

    - run: mkdir -p ~/lisp/

    - name: ci-utils fork
      uses: actions/checkout@v2
        # check out my fork of CI-Utils
        repository: 3b/ci-utils
        # on branch test2
        ref: test2
        # into a subdir of ~/lisp/
        path: ~/lisp/ci-utils


Ci-utils adds various things useful for CI, for example if your tests or build scripts need to distinguish whether it is running in CI etc. It also adds some convenient scripts for running tests using various test frameworks. We install it using roswell so it will install the scripts, and also tell github to add the script path to PATH.

    - name: install ci-utils
      run: |
        ros install ci-utils
        echo "::add-path::$HOME/.roswell/bin"

In my fork (will send PR soon) CI-Utils adds a wrapper for hand-made tests with no framework where you just want evaluate a form and see if it returns true or not, which simplifies the "load and run" step.

    - name: load code and run tests
      shell: bash
      run: |
        run-test-forms -l ci-examples2/test "(ci-example2.test:run-tests-for-ci)"
        run-test-forms -l ci-example2 "(= (ci-example2:run 3) 4)"

CI status

Test frameworks


Usually we want more structure to our tests, so use a test framework like Parachute, Prove, Rove, or FiveAM.

All of those have similar scripts, except FiveAM which is supported by a script in CI-Utils.

an example using Prove: repo on branch prove

First, install prove instead of CI-Utils

    - name: install prove
      run: |
        ros install prove
        echo "::add-path::$HOME/.roswell/bin"

then run the tests (run-prove seems to want tests in a separate .asd file?)

Prove's default output color scheme doesn't seem to go well with github actions log display, so disable colors.

    - name: load code and run tests
      shell: bash
      run: |
        run-prove --without-colors ci-example2-test.asd

Prove CI status


With run-parachute, we use -l to load a test system, then pass a list of test names to run.

(example from 3b-hdr )

    - name: install parachute
      run: |
        ros install parachute
        echo "::add-path::$HOME/.roswell/bin"

For the list of tests, we can just pass the name of the package containing the tests, or actual names of tests (package qualified, i think?)

Here we load the 3b-hdr/test system, and run all tests from 3b-hdr/test package.

    - name: load code and run tests
      shell: bash
      run: |
        run-parachute --quickload "3b-hdr/test" "3b-hdr/test"

3b-hdr CI status

Continuous Integration in Common Lisp with Github ActionsFri, 11 Sep 2020 18:00:02 CDT

edit 2020/09/13: switched back to upstream install-for-ci.sh since it merged my patches.

This is the first part of a series of posts about how i set up CI for CL code using github actions.

repo for example

The first thing we need to do is add an action. Either click the actions tab in the github UI and then Set up this workflow on the Simple workflow and change the name to CI.yml, or just manually create .github/workflows/CI.yml.

For this example, we will use roswell to install and run lisp implementations, and test 64-bit SBCL and ccl on Linux, Windows, and OSX.

First this we need to do is specify when we want to run the tests. We will run on pushes to any branch, and pull requests to master. (lots of other options are available, see here for details.

    branches: [ master ]

Next we need to specify what combinations of OS and lisp implementations to test:

lisp here can be any implementation name roswell recognizes, like sbcl-bin, sbcl, ccl, ccl32, ecl, clisp, allegro, cmucl, abcl.

os can be any of the workflow labels listed here (and possibly ubuntu 16.04 and windows server 2016 )

We will test on sbcl-bin, the latest released SBCL binary, and ccl, the latest ccl release, 64 bit in both cases. Both will be tested on Ubuntu, MacOS and windows. (more complex setups will be showin in a later part)

Note that github actions come with a limited amount of free CPU time for running actions, and windows and osx cost 2x and 10x as much cpu time respectively compared to linux, so if your tests are slow, you might want to limit those, and possibly disable them when debugging the initial actions setup and test suite. Full details on billing here.

    name: ${{ matrix.lisp }} on ${{ matrix.os }}
        lisp: [sbcl-bin ,ccl]
        os: [ windows-latest, ubuntu-latest, macos-latest]

    runs-on: ${{ matrix.os }}

Optionally we can specify that we want the action to let all jobs finish, even if some fail. For this example we will let it kill unfinished jobs if any fail, but this option is useful when we are explicitly testing portability and want to see which implementations can or cannot run it rather than just that some can't.

#      fail-fast: false

Next we specify the steps needed to run the job:

  • first we turn off CRLF conversion on windows, since that might confuse sbcl. Also, change where roswell installs its binary and add that to the path, since it can't find it otherwise.
    - name: windows specific settings
      if: matrix.os == 'windows-latest'
      run: |
        git config --global core.autocrlf false
        echo "::set-env name=ROSWELL_INSTALL_DIR::~/ros"
        echo "::add-path::~/ros/bin"
  • then check out the repository
    - uses: actions/checkout@v2
  • To save time if we run tests frequently, we cache the .roswell dir if possible. The cache will be keyed on the OS, implementation, and hash of all .asd files. If there isn't an exact match, it will try restoring a match of just os+lisp or just OS, and then save a cache with full key.

    - name: cache .roswell
      id: cache-dot-roswell
      uses: actions/cache@v1
        path: ~/.roswell
        key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }}
        restore-keys: |
          ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-
          ${{ runner.os }}-dot-roswell-
  • We still run the roswell install even if the install was cached, since it makes some global changes as well, like installing system packages if needed. The matrix.lisp is the value from the matrix defined above for the particular instance of the job, so that is passed to the roswell CI script in the LISP environment var to specify what it should install.
    - name: install roswell
      shell: bash
       LISP: ${{ matrix.lisp }}
      run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh
  • once Roswell is installed, we run some commands to print out info about the install, which is useful when trying to match the setup if it finds a problem that doesn't show up on developer machines.

continue-on-error indicates that failures here shouldn't fail the entire run (though probably something is too broken for the real tests to pass).

   - name: run lisp
      continue-on-error: true
      shell: bash
      run: |
        ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))'
        ros -e '(format t " fixnum bits:~a~%" (integer-length most-positive-fixnum))'
        ros -e "(ql:quickload 'trivial-features)" -e '(format t "features = ~s~%" *features*)'
  • next we update any existing QL dist stored in the cached roswell

    - name: update ql dist if we have one cached
      shell: bash
      run: ros -e "(ql:update-all-dists :prompt nil)"
  • finally we load the system and run the tests.

In order for test results to show up as pass/fail in CI, we need to ensure we exit and return an appropriate value. For that we wrap loading and tests in a handler case to print the error then exit the lisp on errors.

Additionally, on implementations with recent ASDF, we might have problems with warnings about bad system names, so we muffle those.

    - name: load code and run tests
      shell: bash
      run: |
        ros -e '(handler-bind (#+asdf3.2(asdf:bad-SYSTEM-NAME (function MUFFLE-WARNING))) (handler-case (ql:quickload :ci-example.test) (error (a) (format t "caught error ~s~%~a~%" a a) (uiop:quit 123))))' -e '(ci-example.test:run-tests-for-ci)'

readable version of lisp form above:

(handler-bind (#+asdf3.2(asdf:bad-SYSTEM-NAME (function MUFFLE-WARNING)))
  (handler-case (ql:quickload :ci-example.test)
    (error (a)
      (format t "caught error ~s~%~a~%" a a)
      (uiop:quit 123))))

once we commit and push the .yml file it will try to run the action and probably fail since we haven't defined a test system yet (or because yaml is annoying and there are typos). In that case github will send an email with link to the failing action with details. (when doing a lot of testing of CI itself, you can 'ignore' the repo with the 'unwatch' button in github UI to avoid the mails, but don't forget to watch it again when you get done and want to see the results)

While the action runs, you can watch status and output from the actions tab in github UI.

If we add code to define the package ci-example.test and the function ci-example:run-tests-for-ci that exits with zero on success (or non-zero otherwise), it should pass the CI and we can add banners to the README like


which looks like CI

If we then push some bad changes to a branch, it will show up with failed tests CI, and similarly a pull request will show "Some checks were not successful"