luv

Workshop wiki

ffi.lisp

hal/vulkan/ffi.lisp

system luv · 37 definitions · on GitHub

Binding machinery for luv's owned Vulkan vocabulary.

This file owns the loader, result translation, tagged-struct filler, temporary foreign argument helpers, and opt-in tracing. The actual Vulkan treaty text lives in defs.lisp.

in-package#:luv.vulkan
eval-when
:compile-toplevel:load-toplevel:execute
cffi:define-foreign-libraryvulkan-loader
:darwin
:or"libvulkan.1.dylib""libvulkan.dylib"
:unix
:or"libvulkan.so.1""libvulkan.so"
:windows"vulkan-1.dll"
cffi:use-foreign-libraryvulkan-loader

Conditions and result translation.

define-conditionvulkan-call-error
error
operation:initarg:operation:readervulkan-call-error-operation
result:initarg:result:readervulkan-call-error-result
:report
lambda
conditionstream
formatstream"Vulkan call ~S failed with VkResult ~D."
vulkan-call-error-operationcondition
vulkan-call-error-resultcondition
defvar*vulkan-operation*:unknown-vulkan-operation
defvar*accepted-results*'
:success
cffi:define-foreign-typechecked-result-type
:actual-type:int32
:simple-parserchecked-result
defmethodcffi:translate-from-foreign
declare
ignoretype
let
result
cffi:foreign-enum-keyword'resultvalue:errorpnil
unless
memberresult*accepted-results*
error'vulkan-call-error:operation*vulkan-operation*:resultvalue
result
defmacrowith-vulkan-results
operation&restaccepted-results
&bodybody
`
let
*accepted-results*',
oraccepted-results'
:success
,@body

Struct declarations remain explicit treaty text. defvkstruct supplies the standard tagged-struct header and retains the declaration as Lisp data for increasingly capable fillers later.

eval-when
:compile-toplevel:load-toplevel:execute
defvar*struct-descriptions*
make-hash-table
defmacrodefvkstruct
name
&keys-type
&bodyslots
let
all-slots
append
whens-type'
s-typestructure-type
p-next:pointer
slots
`
progn
cffi:defcstruct,name,@all-slots
eval-when
:compile-toplevel:load-toplevel:execute
setf
gethash',name*struct-descriptions*
',
list:s-types-type:slots
mapcar#'firstall-slots
defunclear-foreign-object
pointertype&optional
count1
loopforindexbelow
*count
cffi:foreign-type-sizetype
do
setf
cffi:mem-arefpointer:uint8index
0
pointer
defunfill-vk
pointertype&restfields
let*
description
or
gethashtype*struct-descriptions*
error"Unknown Vulkan struct ~S."type
foreign-type`
:struct,type
slots
getfdescription:slots
clear-foreign-objectpointerforeign-type
let
s-type
getfdescription:s-type
whens-type
setf
cffi:foreign-slot-valuepointerforeign-type's-type
s-type
cffi:foreign-slot-valuepointerforeign-type'p-next
cffi:null-pointer
loopfor
fieldvalue
onfieldsby#'cddrforslot=
find
symbol-namefield
slots:key#'symbol-name:test#'string=
unlessslotdo
error"~S is not a slot of Vulkan struct ~S."fieldtype
do
setf
cffi:foreign-slot-valuepointerforeign-typeslot
value
pointer
defmacrowith-vk
variabletype&restfields
&bodybody
`
cffi:with-foreign-object
,variable'
:struct,type
,@body

Arguments which own temporary foreign storage.

cffi:define-foreign-typestring-list-type
:actual-type:pointer
:simple-parserstring-list
defmethodcffi:translate-to-foreign
declare
ignoretype
if
nullstrings
values
cffi:null-pointer
nil
let
pointersnil
arraynil
unwind-protect
progn
dolist
stringstrings
push
cffi:foreign-string-allocstring
pointers
setfpointers
nreversepointers
array
cffi:foreign-alloc:pointer:count
lengthpointers
loopforpointerinpointersforindexfrom0do
setf
cffi:mem-arefarray:pointerindex
pointer
valuesarraypointers
unlessarray
mapc#'cffi:foreign-string-freepointers
defmethodcffi:free-translated-object
pointerstrings
declare
ignoretype
mapc#'cffi:foreign-string-freestrings
unless
cffi:null-pointer-ppointer
cffi:foreign-freepointer
defmacrowith-translated-values
bindings&bodybody
if
nullbindings
`
progn,@body
destructuring-bind
firstbindings
let
parameter
gensym"PARAMETER"
`
multiple-value-bind
,variable,parameter
cffi:convert-to-foreign,value',type
unwind-protect
with-translated-values,
restbindings
,@body
cffi:free-converted-object,variable',type,parameter
defmacrowith-foreign-array
pointertypevalues
&bodybody
let
items
gensym"ITEMS"
index
gensym"INDEX"
item
gensym"ITEM"
`
let
,items,values
if
zerop
length,items
let
,pointer
cffi:null-pointer
,@body
cffi:with-foreign-object
,pointer',type
length,items
loopfor,indexbelow
length,items
for,item=
elt,items,index
do
setf
cffi:mem-aref,pointer',type,index
,item
,@body

Direct entry points with backend-local, opt-in trace events.

defstructvulkan-function-definitionnameforeign-namereturn-typeargumentscommand-p
defvar*vulkan-function-definitions*
make-hash-table:test#'eq
defstructvulkan-call-eventsequencetimestampdurationthreadnameforeign-nameargumentsvaluesstatuscondition
defstruct
vulkan-trace
:constructor%make-vulkan-trace
:conc-name%vulkan-trace-
started-at0.0d0
stopped-at
next-sequence0
events
make-array0:adjustablet:fill-pointer0
#+sb-thread
lock
sb-thread:make-mutex:name"luv Vulkan trace"
defvar*vulkan-trace*nil"The active Vulkan trace, or NIL on the ordinary direct FFI path."
defunvulkan-trace-now
/
get-internal-real-time
coerceinternal-time-units-per-second'double-float
defmacrowith-vulkan-trace-lock
trace
&bodybody
#+sb-thread`
sb-thread:with-mutex
%vulkan-trace-lock,trace
,@body
#-sb-thread `(progn ,@body)
defunmake-vulkan-trace
%make-vulkan-trace:started-at
defunfinish-vulkan-trace
trace
setf
%vulkan-trace-stopped-attrace
trace
defunvulkan-trace-events
trace

Return trace events in call-start order as a fresh list.

with-vulkan-trace-lock
trace
sort
coerce
copy-seq
%vulkan-trace-eventstrace
'list
#'<:key#'vulkan-call-event-sequence
defunvulkan-trace-thread-name
#+sb-thread
or
sb-thread:thread-namesb-thread:*current-thread*
"unnamed thread"
#-sb-thread "single thread"
defunsnapshot-vulkan-value
value&optional
depth0
cond
cffi:pointerpvalue
list:pointer
cffi:pointer-addressvalue
or
nullvalue
symbolpvalue
numberpvalue
characterpvalue
value
stringpvalue
copy-seqvalue
>=depth6
list:object
type-ofvalue
conspvalue
cons
snapshot-vulkan-value
carvalue
1+depth
snapshot-vulkan-value
cdrvalue
1+depth
vectorpvalue
map'vector
lambda
item
value
t
list:object
type-ofvalue
handler-case
princ-to-stringvalue
error
"<unprintable>"
defuncall-with-vulkan-trace-event
tracedefinitionargumentsfunction
let*
event
make-vulkan-call-event:sequence
with-vulkan-trace-lock
trace
prog1
%vulkan-trace-next-sequencetrace
incf
%vulkan-trace-next-sequencetrace
:timestamp
-started-at
%vulkan-trace-started-attrace
:thread:name
vulkan-function-definition-namedefinition
:foreign-name
vulkan-function-definition-foreign-namedefinition
:arguments
mapcar
lambda
argument
list
firstargument
arguments
:status:signaled
handler-bind
error
lambda
condition
setf
vulkan-call-event-conditionevent
list:type
type-ofcondition
:message
handler-case
princ-to-stringcondition
error
"<unprintable condition>"
unwind-protect
let
results
multiple-value-list
funcallfunction
setf
vulkan-call-event-statusevent
:returned
vulkan-call-event-valuesevent
mapcar#'snapshot-vulkan-valueresults
values-listresults
setf
vulkan-call-event-durationevent
with-vulkan-trace-lock
trace
vector-push-extendevent
%vulkan-trace-eventstrace
eval-when
:compile-toplevel:load-toplevel:execute
defunvulkan-lisp-name
foreign-name

Intern and export vkCamelCase foreign-name as luv.VK:CAMEL-CASE.

let
base
with-output-to-string
out
loopforindexfrom2below
lengthforeign-name
forchar=
charforeign-nameindex
do
when
and
>index2
upper-case-pchar
or
lower-case-p
charforeign-name
1-index
and
<
1+index
lengthforeign-name
lower-case-p
charforeign-name
1+index
write-char#\-out
write-char
char-upcasechar
out
let
symbol
internbase'#:luv.vk
exportsymbol'#:luv.vk
symbol
defunregister-vulkan-function-definition
nameforeign-namereturn-typeargument-specs
let
definition
make-vulkan-function-definition:namename:foreign-nameforeign-name:return-typereturn-type:argumentsargument-specs:command-p
and
>
lengthforeign-name
5
string="vkCmd"foreign-name:end25
definition
defunvulkan-function-description
name

Return definition metadata retained by defvkfun for VK function name.

let
whendefinition
list:foreign-name
vulkan-function-definition-foreign-namedefinition
:return-type
vulkan-function-definition-return-typedefinition
:arguments
vulkan-function-definition-argumentsdefinition
:command-p
vulkan-function-definition-command-pdefinition
defmacrodefvkfun
foreign-namereturn-type&bodyarguments

Define a direct Vulkan entry point with opt-in trace instrumentation.

let*
lisp-name
vulkan-lisp-nameforeign-name
raw-name
intern
formatnil"%~A"lisp-name
'#:luv.vulkan
argument-names
mapcar#'firstarguments
definition-name
intern
formatnil"*~A-DEFINITION*"lisp-name
'#:luv.vulkan
`
progn
eval-when
:compile-toplevel:load-toplevel:execute
export',lisp-name'#:luv.vk
cffi:defcfun
,foreign-name,raw-name:libraryvulkan-loader
,return-type
,@arguments
defparameter,definition-name
register-vulkan-function-definition',lisp-name,foreign-name',return-type',arguments
defun,lisp-name,argument-names
flet
call
,raw-name,@argument-names
if*vulkan-trace*
call-with-vulkan-trace-event*vulkan-trace*,definition-name
list,@
loopfornameinargument-namescollect`
list',name,name
#'call
call
',lisp-name
defmacrodefvkproc
foreign-namereturn-type&bodyarguments

Define an instance extension command resolved through vkGetInstanceProcAddr.

let*
lisp-name
vulkan-lisp-nameforeign-name
argument-names
mapcar#'firstarguments
definition-name
intern
formatnil"*~A-DEFINITION*"lisp-name
'#:luv.vulkan
`
progn
eval-when
:compile-toplevel:load-toplevel:execute
export',lisp-name'#:luv.vk
defparameter,definition-name
register-vulkan-function-definition',lisp-name,foreign-name',return-type',arguments
defun,lisp-name,argument-names
flet
call
cffi:foreign-funcall-pointer
instance-procedure,
firstargument-names
,foreign-name
,@
loopfor
nametype
inargumentsappend
listtypename
,return-type
if*vulkan-trace*
call-with-vulkan-trace-event*vulkan-trace*,definition-name
list,@
loopfornameinargument-namescollect`
list',name,name
#'call
call
',lisp-name
defmacrodefvkdeviceproc
foreign-namereturn-type&bodyarguments

Define a device extension command resolved through vkGetDeviceProcAddr.

let*
lisp-name
vulkan-lisp-nameforeign-name
argument-names
mapcar#'firstarguments
device
firstargument-names
definition-name
intern
formatnil"*~A-DEFINITION*"lisp-name
'#:luv.vulkan
`
progn
eval-when
:compile-toplevel:load-toplevel:execute
export',lisp-name'#:luv.vk
defparameter,definition-name
register-vulkan-function-definition',lisp-name,foreign-name',return-type',arguments
defun,lisp-name,argument-names
flet
call
cffi:foreign-funcall-pointer
device-procedure,device,foreign-name
,@
loopfor
nametype
inargumentsappend
listtypename
,return-type
if*vulkan-trace*
call-with-vulkan-trace-event*vulkan-trace*,definition-name
list,@
loopfornameinargument-namescollect`
list',name,name
#'call
call
',lisp-name
defunstart-vulkan-trace

Start a process-wide structured trace of calls crossing into Vulkan.

when*vulkan-trace*
error"A Vulkan trace is already active."
defunstop-vulkan-trace

Stop and return the active Vulkan trace, or NIL when none is active.

defuncurrent-vulkan-trace

Return the active Vulkan trace, if any.

*vulkan-trace*
defmacrowith-vulkan-trace
trace
&bodybody

Run body with this thread's Vulkan calls recorded into a fresh trace.

Binds the backend-local trace only for body's dynamic extent.

`
let*
unwind-protect
progn,@body
defunvulkan-trace-presentation-intervals
trace&keyinclude-prefix

Return completed event intervals between vkQueuePresentKHR calls.

Each interval excludes its opening presentation and includes its closing presentation. include-prefix also returns the possibly partial interval from the beginning of trace through its first presentation.

let
intervalnil
intervalsnil
saw-presentationnil
dolist
event
nreverseintervals
pusheventinterval
when
string="vkQueuePresentKHR"
vulkan-call-event-foreign-nameevent
when
orsaw-presentationinclude-prefix
push
nreverseinterval
intervals
setfintervalnilsaw-presentationt