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"
"libudev.so"))
(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))
fd))
(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
libinput::close-restricted)
interface
(:struct libinput::libinput-interface))
(setf libinput::open-restricted (cffi:callback open-restricted))
(setf libinput::close-restricted (cffi:callback close-restricted)))
interface))
;; 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)
(interface))
;; 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
(handler-case
(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))
(cffi:null-pointer)
udev))
;; 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:~%")
(loop
do (libinput:dispatch context)
;; loop over all available events
(loop
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
(#.libinput:device-added
;; 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))))
(#.libinput:device-removed
(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)
1.0d-6))
(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
(libinput:event-touch-get-x-tranformed
ev2 800)
(libinput:event-touch-get-y-transformed
ev2 480))))
((#.libinput:touch-up
;; touch-frame event is used to group
;; multiple events when there are multiple
;; touches at once.
#.libinput:touch-frame)
(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)
1.0d-6))))
(otherwise
;; 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)
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@tty1then add
[Service]
ExecStart=
ExecStart=-/sbin/agetty --autologin username --noclear %Iand 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
fi
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@tty1Getting 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))
,@body))
(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)))
,@forms)))
Now we can make some calls and see if things are working:
(with-dbus ()
(with-object (o call "/org/freedesktop/login1"
"org.freedesktop.login1")
(call "org.freedesktop.login1.Manager"
"ListSessions")))
;; 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"
"org.freedesktop.login1")
(call "org.freedesktop.login1.Manager"
"ListSeats")))
;; 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"
"org.freedesktop.login1")
(call "org.freedesktop.login1.Manager"
"GetSessionByPID" (nix:getpid))))
;; ->
"/org/freedesktop/login1/session/_314"
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*)
"/org/freedesktop/login1"
"org.freedesktop.login1")))
(flet ((,lcall (interface-name method-name &rest args)
(apply #'dbus:object-invoke ,login
interface-name method-name args))
(,lprop (property)
(dbus:get-property *bus*
"org.freedesktop.login1"
"/org/freedesktop/login1"
"org.freedesktop.login1.Manager"
property)))
(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*)
,session-name
"org.freedesktop.login1")))
(flet ((,scall (method-name &rest args)
(apply #'dbus:object-invoke ,session
"org.freedesktop.login1.Session"
method-name args))
(,sprop (property)
(dbus:get-property *bus*
"org.freedesktop.login1"
,session-name
"org.freedesktop.login1.Session"
property)))
(declare (ignorable #',scall #',sprop))
,@body)))))))
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?
(unwind-protect
(multiple-value-bind (,fd paused)
(apply #'sc "TakeDevice"
(path-device "/dev/dri/card0"))
(when ,fd
(unwind-protect
(progn
;; if the session is paused, we can try activating it
(when paused
(sc "Activate"))
,@body))
;; 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:
;;caps:
;; :DUMB-BUFFER = 1
;; :VBLANK-HIGH-CRTC = 1
;; :DUMB-PREFERRED-DEPTH = 0
;; :DUMB-PREFER-SHADOW = 0
;; :PRIME = 3
;; :TIMESTAMP-MONOTONIC = 1
;; :ASYNC-PAGE-FLIP = 0
;; :CURSOR-WIDTH = 64
;; :CURSOR-HEIGHT = 64
;; :ADDFB2-MODIFIERS = 0
;; :PAGE-FLIP-TARGET = 0
;;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
drm:vblank-handler
drm:page-flip-handler)
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)))
p))
(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
gbm
(cffi:null-pointer))))
;; 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
:none))
;; we'll just use the first one here
(config (car configs))
;; create a context, ask for GLES2
(context (egl:create-context display
config
(cffi:null-pointer)
:context-major-version 2
:none))
;; 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
event-context
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
context)))
;; 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)
crtc
(:struct drm:mode-crtc))
(drm:mode-set-crtc fd
drm:crtc-id drm:buffer-id drm:x drm:y
connector-id 1
(cffi:foreign-slot-pointer
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
event-context
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
(cffi:null-pointer))
;; 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.
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.
sbcl32andclisp32are supported as nicknames ofsbclandclisprespectively, 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, orcmuclthere.The
clispbinary on MacOS doesn't support FFI, so is skipped.sbcl-binon MacOS is too old, so skip that as wellSome implementations don't install properly on the windows VM, so
allegro,cmucl,abcl,ecl, andclispare skipped there.
As far as I could tell, we need to explicitly list each combination we don't want, which is a bit verbose.
jobs:
test:
name: ${{ matrix.lisp }} on ${{ matrix.os }}
strategy:
matrix:
lisp: [sbcl-bin,sbcl,ccl,ccl32,ecl,clisp,allegro,cmucl,abcl]
os: [ubuntu-latest, macos-latest, windows-latest]
exclude:
# 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
- https://github.com/actions/virtual-environments/issues/1525
- https://github.com/actions/virtual-environments/issues/1572
- https://github.com/actions/toolkit/issues/318
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:
defaults:
run:
# 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
with:
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)
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.
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
with:
# 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
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)"
Test frameworks
Prove
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
Parachute
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"
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.
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.
on:
push:
pull_request:
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.
jobs:
test:
name: ${{ matrix.lisp }} on ${{ matrix.os }}
strategy:
matrix:
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: falseNext we specify the steps needed to run the job:
steps:- 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
.roswelldir if possible. The cache will be keyed on the OS, implementation, and hash of all.asdfiles. 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
with:
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.lispis the value from the matrix defined above for the particular instance of the job, so that is passed to the roswell CI script in theLISPenvironment var to specify what it should install.
- name: install roswell
shell: bash
env:
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 
If we then push some bad changes to a branch, it will show up with
failed tests
,
and similarly a
pull request will show
"Some checks were not successful"