Browse files

Start work on uniform-buffer objects

  • Loading branch information...
Shinmera committed Jul 5, 2018
1 parent 3c9e7ad commit 447037e4559f31421b5e944165f120186f0ba7c6
Showing with 121 additions and 5 deletions.
  1. +111 −0 assets/uniform-buffer.lisp
  2. +7 −2 resources/shader-program.lisp
  3. +1 −2 resources/texture.lisp
  4. +2 −1 trial.asd
@@ -0,0 +1,111 @@
This file is a part of trial
(c) 2017 Shirakumo (
Author: Nicolas Hafner <>
(in-package #:org.shirakumo.fraf.trial)
(defclass uniform-buffer (gl-asset buffer-object)
((layout :initarg :layout :accessor layout)
(qualifiers :initarg :qualifiers :accessor qualifiers)
(binding :initarg :binding :accessor binding)
(offsets :initarg :offsets :initform NIL :accessor offsets))
:buffer-type :uniform-buffer
:layout :shared
:qualifiers ()))
(defmethod initialize-instance :after ((buffer uniform-buffer) &key name binding)
(unless binding
(setf (binding buffer) (cffi:translate-underscore-separated-name name))))
(defmethod gl-type ((buffer uniform-buffer))
(gl-type (gl-struct (input buffer))))
(defmethod fields ((buffer uniform-buffer))
(fields (gl-struct (input buffer))))
(defmethod gl-source ((buffer uniform-buffer))
,@(when (layout buffer)
,@(loop for id in (enlist (layout buffer))
collect `(glsl-toolkit:layout-qualifier-id ,@(enlist id))))))
,@(qualifiers buffer))
,(gl-type buffer)
,(if (binding buffer)
`(glsl-toolkit:instance-name ,(binding buffer))
,@(mapcar #'gl-source (fields buffer))))
(defmethod compute-offsets ((buffer uniform-buffer) (program shader-program))
(let* ((struct (gl-struct (input buffer)))
(index (gl:get-uniform-block-index (gl-name program) (gl-type struct)))
(size (gl:get-active-uniform-block (gl-name program) index :uniform-block-data-size))
(offsets (make-hash-table :test 'equal)))
(labels ((gather-fields (struct prefix)
(loop for field in (fields struct)
nconc (cond ((and (array-size field) (listp (gl-type field)))
(loop for i from 0 below (array-size field)
nconc (gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a[~d]" prefix (gl-name field) i))))
((array-size field)
(loop for i from 0 below (array-size field)
collect (format NIL "~a~a[~d]" prefix (gl-name field) i)))
((listp (gl-type field))
(gather-fields (gl-struct (second (gl-type field)))
(format NIL "~a~a." prefix (gl-name field))))
(list (format NIL "~a~a" prefix (gl-name field))))))))
(let ((fields (gather-fields struct (format NIL "~@[~a.~]" (binding buffer)))))
(cffi:with-foreign-objects ((names :pointer 1)
(indices :int 1)
(params :int 1))
(dolist (field fields)
(cffi:with-foreign-string (name field)
(setf (cffi:mem-ref names :pointer) name)
(%gl:get-uniform-indices (gl-name program) 1 names indices)
(%gl:get-active-uniforms-iv (gl-name program) 1 indices :uniform-offset params)
(setf (gethash field offsets) (cffi:mem-ref params :int)))))))
(values offsets size)))
(defmethod load ((buffer uniform-buffer))
;; If the layout is std140, we can compute the size and offsets without a program.
(when (find :std140 (enlist (layout buffer)))
(multiple-value-bind (offsets size) (compute-offsets (input buffer) :std140)
(setf (offsets buffer) offsets)
(setf (size buffer) size)))
(allocate buffer))
(defmethod bind ((buffer uniform-buffer) (program shader-program) (binding-point integer))
;; Calculate size and offsets now.
(unless (offsets buffer)
(multiple-value-bind (offsets size) (compute-offsets buffer program)
(setf (offsets buffer) offsets)
(setf (size buffer) size)))
;; FIXME: at this point we could compile an optimised accessor for the fields
;; that has the offsets and such rolled out so that there's no lookup
;; costs beyond calling the function from a slot.
;; Allocate the buffer with the correct sizing information.
(load buffer)
;; Bind the buffer to the program's specified binding point.
(let ((index (gl:get-uniform-block-index (gl-name program) (gl-type buffer))))
(%gl:uniform-block-binding (gl-name program) index binding-point)
(%gl:bind-buffer-base :uniform-buffer binding-point (gl-name buffer))))
(defmethod buffer-field ((buffer uniform-buffer) field)
(error "FIXME"))
(defmethod (setf buffer-field) (value (buffer uniform-buffer) field)
;; FIXME: wouldn't it be better to keep the C-memory block for the UBO around,
;; write the values in there ourselves, and then call an update call
;; instead of going through the slow, generic variants of buffer-object?
(let ((offset (gethash field (offsets buffer))))
;; FIXME: Feature tag to remove this check
(unless offset
(error "Field ~s not found in ~a." field buffer))
(update-buffer-data buffer value :buffer-start offset )))
@@ -8,9 +8,11 @@
(defclass shader-program (gl-resource)
((uniform-map :initform (make-hash-table :test 'equal) :accessor uniform-map)
(shaders :initarg :shaders :accessor shaders))
(shaders :initarg :shaders :accessor shaders)
(buffers :initarg :buffers :accessor buffers))
:shaders (error "SHADERS required.")))
:shaders (error "SHADERS required.")
:buffers ()))
(defun check-shader-compatibility (shaders)
(loop with table = (make-hash-table :test 'eql)
@@ -43,6 +45,9 @@
(error "Failed to link ~a: ~%~a"
program (gl:get-program-info-log prog)))
(v:debug :trial.asset "Linked ~a with ~a." program shaders)
(loop for buffer in (buffers program)
for i from 0
do (bind buffer program i))
(setf (data-pointer program) prog)))))
(defmethod deallocate :after ((program shader-program))
@@ -360,10 +360,9 @@
(8 8)
(16 16)
(32 32))
;; KLUDGE: If we have signed formats, the pixel-format needs to be *-integer
(ecase type
(:signed :i)
;; KLUDGE: For some fucking reason if I put :ui I here GL refuses
;; to upload the texture data with tex-image-2d.
(:unsigned "")
(:float :f)))
@@ -95,7 +95,8 @@
:depends-on ("package" "asset" "resources")
:components ((:file "font")
(:file "image")
(:file "mesh")))
(:file "mesh")
(:file "uniform-buffer")))
(:module "formats"
:depends-on ("package" "geometry" "static-vector")
:components ((:file "vertex-format")

0 comments on commit 447037e

Please sign in to comment.