Skip to content
Permalink
Browse files

Fix up buffer data changing to actually work again, make some other i…

…mprovements along the way
  • Loading branch information...
Shinmera committed Mar 22, 2019
1 parent 28e0333 commit f69325292b317481f000a19d56d2d85f5c40ea1c
Showing with 323 additions and 280 deletions.
  1. +1 −8 assets/image.lisp
  2. +112 −0 data-pointer.lisp
  3. +2 −1 features.lisp
  4. +3 −3 geometry.lisp
  5. +16 −84 resources/buffer-object.lisp
  6. +8 −0 resources/vertex-buffer.lisp
  7. +41 −169 toolkit.lisp
  8. +9 −15 trial.asd
  9. +131 −0 type-info.lisp
@@ -141,13 +141,6 @@
(let ((type (pathname-type path)))
(apply #'load-image path (intern (string-upcase type) "KEYWORD") args)))

(defun free-image-data (data)
(etypecase data
(cffi:foreign-pointer
(cffi:foreign-free data))
(vector
(maybe-free-static-vector data))))

(defmethod load ((image image))
(flet ((load-image (path)
(with-new-value-restart (path) (new-path "Specify a new image path.")
@@ -156,7 +149,7 @@
(let ((input (coerce-asset-input image T)))
(multiple-value-bind (bits width height pixel-type pixel-format) (load-image (unlist input))
(assert (not (null bits)))
(with-unwind-protection (mapcar #'free-image-data (enlist (pixel-data image)))
(with-unwind-protection (mapcar #'free-data (enlist (pixel-data image)))
;; FIXME: This whole crap needs to be revised to allow updates.
;; Maybe instead of setting things, we should pass an arglist
;; to ALLOCATE instead.
@@ -0,0 +1,112 @@
#|
This file is a part of trial
(c) 2017 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.fraf.trial)

(defun free-data (data)
(etypecase data
(cffi:foreign-pointer
(cffi:foreign-free data))
(vector
(maybe-free-static-vector data))))

(defmacro with-pointer-to-vector-data ((ptr data) &body body)
(let ((datag (gensym "DATA")) (thunk (gensym "THUNK"))
(type (gensym "TYPE")) (i (gensym "I")))
`(let ((,datag ,data))
(flet ((,thunk (,ptr)
(declare (type cffi:foreign-pointer ,ptr))
,@body))
(cond #+sbcl
((typep ,datag 'sb-kernel:simple-unboxed-array)
(sb-sys:with-pinned-objects (,datag)
(let ((,ptr (sb-sys:vector-sap ,datag)))
(,thunk ,ptr))))
((static-vector-p ,datag)
(let ((,ptr (static-vector-pointer ,datag)))
(,thunk ,ptr)))
(T
(let ((,type (cl-type->gl-type (array-element-type ,datag))))
(cffi:with-foreign-object (,ptr ,type (length ,datag))
(dotimes (,i (length ,datag))
(setf (cffi:mem-aref ,ptr ,type ,i) (aref ,datag ,i)))
(,thunk ,ptr)))))))))

(defgeneric call-with-data-ptr (function data &key offset &allow-other-keys))

(defmethod call-with-data-ptr (function data &key (offset 0))
#-elide-buffer-access-checks
(unless (typep data 'cffi:foreign-pointer)
(no-applicable-method #'call-with-data-ptr function data :offset offset))
(funcall function (cffi:inc-pointer data offset) most-positive-fixnum))

(defmethod call-with-data-ptr (function (data real) &key (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for reals."))
(let ((type (cl-type->gl-type (type-of data))))
(cffi:with-foreign-object (ptr type)
(setf (cffi:mem-ref ptr type) data)
(funcall function ptr (gl-type-size type)))))

(defmethod call-with-data-ptr (function (data vec2) &key (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 2)
(setf (cffi:mem-aref ptr :float 0) (vx2 data))
(setf (cffi:mem-aref ptr :float 1) (vy2 data))
(funcall function ptr (gl-type-size :vec2))))

(defmethod call-with-data-ptr (function (data vec3) &key (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 3)
(setf (cffi:mem-aref ptr :float 0) (vx3 data))
(setf (cffi:mem-aref ptr :float 1) (vy3 data))
(setf (cffi:mem-aref ptr :float 2) (vz3 data))
(funcall function ptr (gl-type-size :vec3))))

(defmethod call-with-data-ptr (function (data vec4) &key (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 4)
(setf (cffi:mem-aref ptr :float 0) (vx4 data))
(setf (cffi:mem-aref ptr :float 1) (vy4 data))
(setf (cffi:mem-aref ptr :float 2) (vz4 data))
(setf (cffi:mem-aref ptr :float 3) (vw4 data))
(funcall function ptr (gl-type-size :vec4))))

(defmethod call-with-data-ptr (function (data mat2) &key (offset 0))
(call-with-data-ptr function (marr2 data) :offset offset))

(defmethod call-with-data-ptr (function (data mat3) &key (offset 0))
(call-with-data-ptr function (marr3 data) :offset offset))

(defmethod call-with-data-ptr (function (data mat4) &key (offset 0))
(call-with-data-ptr function (marr4 data) :offset offset))

(defmethod call-with-data-ptr (function (data matn) &key (offset 0))
(call-with-data-ptr function (marrn data) :offset offset))

(defmethod call-with-data-ptr (function (data vector) &key (offset 0) gl-type)
(let* ((type (or gl-type (cl-type->gl-type (array-element-type data))))
(type-size (gl-type-size type))
(offset (* offset type-size))
(size (- (* (length data) type-size) offset)))
(with-pointer-to-vector-data (ptr data)
(funcall function (cffi:inc-pointer ptr offset) size))))

(defmethod call-with-data-ptr (function (data pathname) &key (offset 0))
(mmap:with-mmap (ptr fd size data)
(funcall function (cffi:inc-pointer ptr offset) size)))

(defmacro with-data-ptr ((ptr size data &rest args) &body body)
(let ((thunk (gensym "THUNK")))
`(flet ((,thunk (,ptr ,size)
(declare (type cffi:foreign-pointer ,ptr))
(declare (type fixnum ,size))
(declare (ignorable ,size))
,@body))
(call-with-data-ptr #',thunk ,data ,@args))))
@@ -8,7 +8,8 @@

(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *debug-features* '(:trial-debug-controller))
(defvar *optimize-features* '(:elide-buffer-access-checks))
(defvar *optimize-features* '(:elide-buffer-access-checks
:elide-coercion-size-checks))

#+trial-debug-all
(setf *features* (union *features* *debug-features*))
@@ -25,7 +25,7 @@
(defclass vertex-mesh ()
((face-length :initarg :face-length :initform 3 :accessor face-length)
(vertex-type :initform 'vertex :initarg :vertex-type :reader vertex-type)
(faces :initform (make-array 0 :element-type 'fixnum :adjustable T :fill-pointer T) :accessor faces)
(faces :initform (make-array 0 :element-type '(unsigned-byte 32) :adjustable T :fill-pointer T) :accessor faces)
(vertices :initform (make-array 0 :adjustable T :fill-pointer T) :accessor vertices)))

(defmethod update-vertices (function (mesh vertex-mesh))
@@ -207,10 +207,10 @@
;; Construct the buffers and specs
(let* ((vbo (make-instance 'vertex-buffer :buffer-data buffer :buffer-type :array-buffer
:data-usage data-usage :element-type :float
:size (* total-size #.(gl-type-size :float))))
:size (* total-size (gl-type-size :float))))
(ebo (make-instance 'vertex-buffer :buffer-data (faces mesh) :buffer-type :element-array-buffer
:data-usage data-usage :element-type :unsigned-int
:size (* total-size #.(gl-type-size :unsigned-int))))
:size (* (length (faces mesh)) (gl-type-size :unsigned-int))))
(specs (loop with stride = (reduce #'+ sizes)
for offset = 0 then (+ offset size)
for size in sizes
@@ -39,95 +39,28 @@
(%gl:buffer-sub-data buffer-type buffer-start count data)
(gl:bind-buffer buffer-type 0))))

(defun resize-buffer (buffer size &optional (data (cffi:null-pointer)))
(defun resize-buffer/ptr (buffer size &optional (data (cffi:null-pointer)))
(let ((buffer-type (buffer-type buffer)))
(gl:bind-buffer buffer-type (gl-name buffer))
(unwind-protect
(%gl:buffer-data buffer-type size data (data-usage buffer))
(gl:bind-buffer buffer-type 0))))

(defgeneric call-with-data-ptr (function data &optional offset))

(defmethod call-with-data-ptr (function data &optional (offset 0))
#-elide-buffer-access-checks
(unless (typep data 'cffi:foreign-pointer)
(no-applicable-method #'call-with-data-ptr function data :offset offset))
(funcall function (cffi:inc-pointer data offset) 0))

(defmethod call-with-data-ptr (function (data real) &optional (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for reals."))
(let ((type (cl-type->gl-type (type-of data))))
(cffi:with-foreign-object (ptr type)
(setf (cffi:mem-ref ptr type) data)
(funcall function ptr (gl-type-size type)))))

(defmethod call-with-data-ptr (function (data vec2) &optional (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 2)
(setf (cffi:mem-aref ptr :float 0) (vx2 data))
(setf (cffi:mem-aref ptr :float 1) (vy2 data))
(funcall function ptr (g-type-size :vec2))))

(defmethod call-with-data-ptr (function (data vec3) &optional (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 3)
(setf (cffi:mem-aref ptr :float 0) (vx3 data))
(setf (cffi:mem-aref ptr :float 1) (vy3 data))
(setf (cffi:mem-aref ptr :float 2) (vz3 data))
(funcall function ptr (g-type-size :vec3))))

(defmethod call-with-data-ptr (function (data vec4) &optional (offset 0))
#-elide-buffer-access-checks
(when (/= offset 0) (error "OFFSET must be zero for vectors."))
(cffi:with-foreign-object (ptr :float 4)
(setf (cffi:mem-aref ptr :float 0) (vx4 data))
(setf (cffi:mem-aref ptr :float 1) (vy4 data))
(setf (cffi:mem-aref ptr :float 2) (vz4 data))
(setf (cffi:mem-aref ptr :float 3) (vw4 data))
(funcall function ptr (g-type-size :vec4))))

(defmethod call-with-data-ptr (function (data mat2) &optional (offset 0))
(call-with-data-ptr function (marr2 data) offset))

(defmethod call-with-data-ptr (function (data mat3) &optional (offset 0))
(call-with-data-ptr function (marr3 data) offset))

(defmethod call-with-data-ptr (function (data mat4) &optional (offset 0))
(call-with-data-ptr function (marr4 data) offset))

(defmethod call-with-data-ptr (function (data matn) &optional (offset 0))
(call-with-data-ptr function (marrn data) offset))

(defmethod call-with-data-ptr (function (data vector) &optional (offset 0))
(let* ((type (cl-type->gl-type element-type))
(type-size (gl-type-size type))
(offset (* offset type-size))
(size (- (* (length data) type-size) offset)))
(cond #+sbcl
((typep data 'simple-array)
(sb-sys:with-pinned-objects (data)
(funcall function (sb-sys:sap+ (sb-sys:vector-sap data) offset) size)))
((static-vector-p data)
(funcall function (cffi:inc-pointer (static-vector-pointer data) offset) size))
(T
(cffi:with-foreign-array (ptr data type)
(funcall function (cffi:inc-pointer ptr offset) size))))))

(defmacro with-data-ptr ((ptr size data &rest args &optional offset) &body body)
(declare (ignore offset))
(let ((thunk (gensym "THUNK")))
`(flet ((,thunk (,ptr ,size)
(declare (type cffi:foreign-pointer ,ptr))
(declare (type fixnum ,size))
,@body))
(call-with-data-ptr #',thunk ,data ,@args))))
(defmethod update-buffer-data ((buffer buffer-object) data &key (buffer-start 0) (data-start 0) count gl-type)
(with-data-ptr (ptr data-size data :offset data-start :gl-type gl-type)
#-elide-buffer-access-checks
(when (and count (< data-size count))
(error "Attempting to update ~d bytes from ~a, when it has only ~d bytes available."
count data data-size))
(update-buffer-data/ptr buffer ptr (or count data-size) buffer-start)))

(defmethod update-buffer-data ((buffer buffer-object) data &key buffer-start data-start count)
(with-data-ptr (ptr size data data-start)
(update-buffer-data/ptr buffer ptr (or count size) buffer-start)))
(defmethod resize-buffer ((buffer buffer-object) size &key data (data-start 0) gl-type)
(with-data-ptr (ptr data-size (or data (cffi:null-pointer)) :offset data-start :gl-type gl-type)
#-elide-buffer-access-checks
(when (and size (< data-size size))
(error "Attempting to update ~d bytes from ~a, when it has only ~d bytes available."
size data data-size))
(resize-buffer/ptr buffer size ptr)))

(defmethod allocate ((buffer buffer-object))
(let ((vbo (gl:gen-buffer))
@@ -136,5 +69,4 @@
(setf (data-pointer buffer) NIL))
(setf (data-pointer buffer) vbo)
(assert (not (null (size buffer))))
(with-data-ptr (ptr buffer-data)
(resize-buffer vbo (size buffer) ptr)))))
(resize-buffer buffer (size buffer) :data buffer-data))))
@@ -15,6 +15,14 @@
(defmethod initialize-instance :before ((buffer vertex-buffer) &key element-type)
(check-vertex-buffer-element-type element-type))

(defmethod update-buffer-data ((buffer vertex-buffer) data &key (buffer-start 0) (data-start 0) count)
(call-next-method buffer data :buffer-start buffer-start :data-start data-start :count count
:gl-type (element-type buffer)))

(defmethod resize-buffer ((buffer vertex-buffer) size &key (data (cffi:null-pointer)) (data-start 0))
(call-next-method buffer size :data data :data-start data-start
:gl-type (element-type buffer)))

(defmethod allocate :before ((buffer buffer-object))
(let ((buffer-data (buffer-data buffer)))
(when (and (not (size buffer)) (vectorp buffer-data))
Oops, something went wrong.

0 comments on commit f693252

Please sign in to comment.
You can’t perform that action at this time.