graphics: Factor GL calls out of buffer module.

2 files changed, 215 insertions, 165 deletions

diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm
index 50b6d1c..179ae4d 100644
--- a/chickadee/graphics/buffer.scm
+++ b/chickadee/graphics/buffer.scm
@@ -27,13 +27,11 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
-  #:use-module (gl)
   #:use-module (system foreign)
   #:use-module (chickadee math matrix)
   #:use-module (chickadee math vector)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics engine)
-  #:use-module (chickadee graphics gl)
   #:use-module (chickadee graphics gpu)
   #:export (make-buffer
             buffer?
@@ -46,7 +44,6 @@
             buffer-usage
             buffer-data
             null-buffer
-            g:buffer
             current-buffer
             map-buffer!
             unmap-buffer!
@@ -70,7 +67,6 @@
             vertex-array-attributes
             vertex-array-mode
             null-vertex-array
-            g:vertex-array
             current-vertex-array
             render-vertices
             render-vertices/instanced
@@ -112,7 +108,7 @@
 ;;;
 
 (define-record-type <buffer>
-  (%make-buffer id name length stride target usage data stream-cache)
+  (%make-buffer id name length stride target usage data)
   buffer?
   (id buffer-id)
   (name buffer-name)
@@ -120,8 +116,7 @@
   (stride buffer-stride)
   (target buffer-target)
   (usage buffer-usage)
-  (data buffer-data set-buffer-data!)
-  (stream-cache buffer-stream-cache))
+  (data buffer-data set-buffer-data!))
 
 (define (print-buffer buffer port)
   (format port
@@ -136,24 +131,12 @@
 (set-record-type-printer! <buffer> print-buffer)
 
 (define null-buffer
-  (%make-buffer 0 "null" 0 0 'vertex 'static #f #f))
+  (%make-buffer 0 "null" 0 0 'vertex 'static #f))
 
 (define (index-buffer? buffer)
   "Return #t if VIEW is an index buffer view."
   (eq? (buffer-target buffer) 'index))
 
-(define (buffer-usage-gl buffer)
-  (case (buffer-usage buffer)
-    ((static)
-     (version-1-5 static-draw))
-    ((stream)
-     (version-1-5 stream-draw))))
-
-(define (buffer-target-gl buffer)
-  (if (index-buffer? buffer)
-      (version-1-5 element-array-buffer)
-      (version-1-5 array-buffer)))
-
 (define* (make-buffer data #:key
                       (name "anonymous")
                       (length (if data (bytevector-length data) 0))
@@ -184,74 +167,33 @@ never sent to the GPU."
   (assert-current-graphics-engine)
   ;; Weird bugs will occur when creating a new vertex buffer while a
   ;; vertex array is bound.
-  (with-graphics-state! ((vertex-array gpu-vertex-array:null))
-    (let ((buffer (%make-buffer (fresh-gpu-buffer (current-gpu) target)
-                                name length stride target usage #f
-                                (and (eq? usage 'stream)
-                                     (make-hash-table)))))
-      (with-graphics-state! ((buffer (buffer-id buffer)))
-        (gl-buffer-data (buffer-target-gl buffer)
-                        length
-                        (if data
-                            (bytevector->pointer data offset)
-                            %null-pointer)
-                        (buffer-usage-gl buffer))
-        buffer))))
+  (let ((gpu (current-gpu)))
+    (set-gpu-vertex-array! gpu gpu-vertex-array:null)
+    (let* ((id (fresh-gpu-buffer gpu target usage))
+           (buffer (%make-buffer id name length stride target usage #f)))
+      (gpu-buffer-upload gpu id usage data length offset)
+      buffer)))
 
 (define (buffer-mapped? buffer)
   "Return #t if buffer data has been mapped from GPU."
   (if (buffer-data buffer) #t #f))
 
-;; For streaming buffers, we use buffer re-specification to achieve
-;; good throughput.  However, it requires getting a new data pointer
-;; every frame and allocating a Scheme bytevector for that memory
-;; region.  Allocating this bytevector every frame causes significant
-;; GC pressure.  It turns out that GPU drivers tend to return the same
-;; set of pointers over and over, or at least the driver I'm using
-;; does this.  So, by caching bytevectors for those memory regions we
-;; avoid bytevector allocation after a frame or two of warmup.
-(define (pointer->bytevector/cached buffer pointer length)
-  (let* ((cache (buffer-stream-cache buffer))
-         (address (pointer-address pointer))
-         (cached (hashv-ref cache address)))
-    ;; It could be that there is a cached bytevector for the address,
-    ;; but the bytevector is a different length.  We must treat this
-    ;; as a cache miss and allocate a new bytevector.
-    (if (and cached (= (bytevector-length cached) length))
-        cached
-        (let ((bv (pointer->bytevector pointer length)))
-          (hashv-set! cache address bv)
-          bv))))
-
 (define* (map-buffer! buffer #:optional (mode 'read-write))
   "Map the memory space for BUFFER from the GPU to the CPU, allowing
 the vertex buffer to be updated with new vertex data.  The
 'unmap-buffer!' procedure must be called to submit the new
 vertex buffer data back to the GPU."
-  (unless (buffer-mapped? buffer) ;; Don't map a buffer that is already mapped!
-    (let ((target (buffer-target-gl buffer))
-          (length (buffer-length buffer)))
-      (with-graphics-state! ((buffer (buffer-id buffer)))
-        (when (eq? (buffer-usage buffer) 'stream)
-          ;; Orphan the buffer to avoid implicit synchronization.
-          ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
-          (gl-buffer-data target length %null-pointer (buffer-usage-gl buffer)))
-        (let* ((ptr (gl-map-buffer target
-                                   (case mode
-                                     ((read-write)
-                                      (version-1-5 read-write))
-                                     ((read-only)
-                                      (version-1-5 read-only))
-                                     ((write-only)
-                                      (version-1-5 write-only)))))
-               (bv (pointer->bytevector/cached buffer ptr length)))
-          (set-buffer-data! buffer bv))))))
+  (unless (buffer-mapped? buffer)
+    (let ((bv (gpu-buffer-map (current-gpu)
+                              (buffer-id buffer)
+                              (buffer-length buffer)
+                              mode)))
+      (set-buffer-data! buffer bv))))
 
 (define (unmap-buffer! buffer)
   "Return the mapped vertex buffer data for BUFFER to the GPU."
-  (with-graphics-state! ((buffer (buffer-id buffer)))
-    (gl-unmap-buffer (buffer-target-gl buffer))
-    (set-buffer-data! buffer #f)))
+  (gpu-buffer-unmap (current-gpu) (buffer-id buffer))
+  (set-buffer-data! buffer #f))
 
 (define (resize-buffer! buffer length)
   "Resize BUFFER to LENGTH bytes, preserving all existing mapped data
@@ -299,13 +241,12 @@ resized."
     ((double) 8)))
 
 (define-record-type <vertex-attribute>
-  (%make-vertex-attribute name buffer offset offset-pointer component-type
+  (%make-vertex-attribute name buffer offset component-type
                           normalized? length type divisor)
   vertex-attribute?
   (name vertex-attribute-name)
   (buffer vertex-attribute->buffer)
   (offset vertex-attribute-offset)
-  (offset-pointer vertex-attribute-offset-pointer)
   (component-type vertex-attribute-component-type)
   (normalized? vertex-attribute-normalized?)
   (length vertex-attribute-length)
@@ -367,9 +308,8 @@ divisor of 0 means that a single element is used for every instance
 and is used for the data being instanced.  A divisor of 1 means that
 each element is used for 1 instance.  A divisor of 2 means that each
 element is used for 2 instances, and so on."
-  (let ((offset-ptr (make-pointer offset)))
-    (%make-vertex-attribute name buffer offset offset-ptr component-type
-                            normalized? length type divisor)))
+  (%make-vertex-attribute name buffer offset component-type
+                          normalized? length type divisor))
 
 (define (display-vertex-attribute vertex-attribute port)
   (format port "#<vertex-attribute name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>"
@@ -389,33 +329,6 @@ element is used for 2 instances, and so on."
 (define (vertex-attribute-data vertex-attribute)
   (buffer-data (vertex-attribute->buffer vertex-attribute)))
 
-(define (vertex-attribute-type-gl vertex-attribute)
-  (case (vertex-attribute-component-type vertex-attribute)
-    ((byte) (data-type byte))
-    ((unsigned-byte) (data-type unsigned-byte))
-    ((short) (data-type short))
-    ((unsigned-short) (data-type unsigned-short))
-    ((int) (data-type int))
-    ((unsigned-int) (data-type unsigned-int))
-    ((float) (data-type float))
-    ((double) (data-type double))))
-
-(define (apply-vertex-attribute vertex-attribute attribute-index)
-  (with-graphics-state! ((buffer (buffer-id (vertex-attribute->buffer vertex-attribute))))
-    ;; If there is no attribute-index, we assume this is being bound for
-    ;; use as an index buffer.
-    (when attribute-index
-      (gl-enable-vertex-attrib-array attribute-index)
-      (gl-vertex-attrib-pointer attribute-index
-                                (vertex-attribute-type-size vertex-attribute)
-                                (vertex-attribute-type-gl vertex-attribute)
-                                (vertex-attribute-normalized? vertex-attribute)
-                                (vertex-attribute-stride vertex-attribute)
-                                (vertex-attribute-offset-pointer vertex-attribute))
-      (let ((divisor (vertex-attribute-divisor vertex-attribute)))
-        (when divisor
-          (gl-vertex-attrib-divisor attribute-index divisor))))))
-
 
 ;;;
 ;;; Vertex Arrays
@@ -439,6 +352,23 @@ element is used for 2 instances, and so on."
 
 (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
 
+(define (apply-vertex-attribute array attribute index)
+  ;; If there is no attribute-index, we assume this is being bound for
+  ;; use as an index buffer.
+  (when index
+    (match attribute
+      (($ <vertex-attribute> _ buffer offset type normalized? _ _ divisor)
+       (gpu-vertex-array-apply-attribute (current-gpu)
+                                         (vertex-array-id array)
+                                         (buffer-id buffer)
+                                         index
+                                         (vertex-attribute-type-size attribute)
+                                         type
+                                         normalized?
+                                         (vertex-attribute-stride attribute)
+                                         offset
+                                         divisor)))))
+
 (define* (make-vertex-array #:key indices attributes (mode 'triangles))
   "Return a new vertex array using the index data within the typed
 buffer INDICES and the vertex attribute data within ATTRIBUTES, an
@@ -457,62 +387,47 @@ argument may be overridden.  The following values are supported:
 - triangle-strip
 - triangle-fan"
   (assert-current-graphics-engine)
-  (let ((array (%make-vertex-array (fresh-gpu-vertex-array (current-gpu))
-                                   indices
-                                   attributes
-                                   mode)))
-    (with-graphics-state! ((vertex-array (vertex-array-id array)))
-      (for-each (match-lambda
-                  ((index . vertex-attribute)
-                   (apply-vertex-attribute vertex-attribute index)))
-                attributes)
-      (when indices (apply-vertex-attribute indices #f))
-      array)))
-
-(define (vertex-array-mode-gl array)
-  (case (vertex-array-mode array)
-    ((points) (begin-mode points))
-    ((lines) (begin-mode lines))
-    ((line-loop) (begin-mode line-loop))
-    ((line-strip) (begin-mode line-strip))
-    ((triangles) (begin-mode triangles))
-    ((triangle-strip) (begin-mode triangle-strip))
-    ((triangle-fan) (begin-mode triangle-fan))))
+  (let* ((gpu (current-gpu))
+         (id (fresh-gpu-vertex-array gpu))
+         (array (%make-vertex-array id indices attributes mode)))
+    (for-each (match-lambda
+                ((index . attribute)
+                 (apply-vertex-attribute array attribute index)))
+              attributes)
+    (when indices (apply-vertex-attribute array indices #f))
+    array))
 
 (define (render-vertices array count offset)
   (with-graphics-state! ((vertex-array (vertex-array-id array)))
-    (let ((indices (vertex-array-indices array)))
-      (if indices
-          (begin
-            ;; This shouldn't be here but I get weird rendering issues
-            ;; otherwise whyyyyyy??
-            (apply-vertex-attribute indices #f)
-            (gl-draw-elements (vertex-array-mode-gl array)
-                              (or count
-                                  (vertex-attribute-length indices))
-                              (vertex-attribute-type-gl indices)
-                              (vertex-attribute-offset-pointer indices)))
-          (gl-draw-arrays (vertex-array-mode-gl array)
-                          offset
-                          (or count
-                              (vertex-attribute-length
-                               (assv-ref (vertex-array-attributes array)
-                                         0))))))))
+    (let ((gpu (current-gpu))
+          (indices (vertex-array-indices array))
+          (mode (vertex-array-mode array)))
+      (match (vertex-array-indices array)
+        (#f
+         (let ((count* (or count
+                           (vertex-attribute-length
+                            (assv-ref (vertex-array-attributes array)
+                                      0)))))
+           (gpu-draw gpu mode count* offset)))
+        (($ <vertex-attribute> _ buffer offset type normalized? length)
+         (gpu-draw/indexed gpu (buffer-id buffer) type mode
+                           (or count length) offset))))))
 
 (define (render-vertices/instanced array instances count offset)
   (with-graphics-state! ((vertex-array (vertex-array-id array)))
-    (let ((indices (vertex-array-indices array)))
-      (if indices
-          (begin
-            (apply-vertex-attribute indices #f)
-            (gl-draw-elements-instanced (vertex-array-mode-gl array)
-                                        (or count
-                                            (vertex-attribute-length indices))
-                                        (vertex-attribute-type-gl indices)
-                                        (vertex-attribute-offset-pointer indices)
-                                        instances))
-          (gl-draw-arrays-instanced (vertex-array-mode-gl array)
-                                    offset count instances)))))
+    (let ((gpu (current-gpu))
+          (indices (vertex-array-indices array))
+          (mode (vertex-array-mode array)))
+      (match (vertex-array-indices array)
+        (#f
+         (let ((count* (or count
+                           (vertex-attribute-length
+                            (assv-ref (vertex-array-attributes array)
+                                      0)))))
+           (gpu-draw/instanced gpu mode count* offset instances)))
+        (($ <vertex-attribute> _ buffer offset type normalized? length)
+         (gpu-draw/instanced+indexed gpu (buffer-id buffer) type mode
+                                     (or count length) offset instances))))))
 
 
 ;;;
diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm
index cf922e3..3832256 100644
--- a/chickadee/graphics/gpu.scm
+++ b/chickadee/graphics/gpu.scm
@@ -25,6 +25,7 @@
   #:use-module (chickadee math rect)
   #:use-module (gl)
   #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
   #:use-module (system foreign)
   #:export (blend-mode?
@@ -123,6 +124,9 @@
             free-gpu-buffer
             gpu-buffer?
             gpu-buffer-id
+            gpu-buffer-upload
+            gpu-buffer-map
+            gpu-buffer-unmap
             gpu-buffer-target
             gpu-buffer:null
 
@@ -130,6 +134,7 @@
             free-gpu-vertex-array
             gpu-vertex-array?
             gpu-vertex-array-id
+            gpu-vertex-array-apply-attribute
             gpu-vertex-array:null
 
             fresh-gpu-texture
@@ -208,7 +213,11 @@
             set-gpu-program!
             set-gpu-texture!
             gpu-gc
-            gpu-reset!))
+            gpu-reset!
+            gpu-draw
+            gpu-draw/indexed
+            gpu-draw/instanced
+            gpu-draw/instanced+indexed))
 
 
 ;;;
@@ -259,6 +268,45 @@
       (->scheme (%eaccessor obj)))
     ...))
 
+(define-enum-converters begin-mode
+  symbol->begin-mode
+  begin-mode->symbol
+  (points)
+  (lines)
+  (line-loop)
+  (line-strip)
+  (triangles)
+  (triangle-strip)
+  (triangle-fan))
+
+(define-enum-converters data-type
+  symbol->data-type
+  data-type->symbol
+  (byte)
+  (unsigned-byte)
+  (short)
+  (unsigned-short)
+  (int)
+  (unsigned-int)
+  (float)
+  (double))
+
+(define (symbol->buffer-target target)
+  (match target
+    ('vertex (version-1-5 array-buffer))
+    ('index (version-1-5 element-array-buffer))))
+
+(define (symbol->buffer-usage usage)
+  (match usage
+    ('static (version-1-5 static-draw))
+    ('stream (version-1-5 stream-draw))))
+
+(define (symbol->access-mode mode)
+  (match mode
+    ('read-write (version-1-5 read-write))
+    ('read-only (version-1-5 read-only))
+    ('write-only (version-1-5 write-only))))
+
 (define-enum-converters texture-min-filter
   symbol->texture-min-filter
   texture-min-filter->symbol
@@ -709,17 +757,20 @@
   (id gpu-renderbuffer-id))
 
 (define-gpu-type <gpu-buffer>
-  (make-gpu-buffer (target)
+  (make-gpu-buffer (target usage)
                    (gl-generate-buffer)
-                   (match target
-                     ('index (version-1-5 element-array-buffer))
-                     ('vertex (version-1-5 array-buffer))))
+                   (symbol->buffer-target target)
+                   (symbol->buffer-usage usage)
+                   (and (eq? usage 'stream) (make-hash-table)))
   (free-gpu-buffer (gl-delete-buffer id))
   (bind-gpu-buffer (gl-bind-buffer target id))
-  (gpu-buffer:null 0 (version-1-5 array-buffer))
+  (gpu-buffer:null 0 (symbol->buffer-target 'vertex)
+                   (symbol->buffer-usage 'static) #f)
   gpu-buffer?
   (id gpu-buffer-id)
-  (target gpu-buffer-target))
+  (target gpu-buffer-target)
+  (usage gpu-buffer-usage)
+  (stream-cache gpu-buffer-stream-cache))
 
 (define-gpu-type <gpu-vertex-array>
   (make-gpu-vertex-array () (gl-generate-vertex-array))
@@ -910,7 +961,7 @@
 
 (define-fresh fresh-gpu-framebuffer make-gpu-framebuffer)
 (define-fresh fresh-gpu-renderbuffer make-gpu-renderbuffer)
-(define-fresh fresh-gpu-buffer make-gpu-buffer target)
+(define-fresh fresh-gpu-buffer make-gpu-buffer target usage)
 (define-fresh fresh-gpu-vertex-array make-gpu-vertex-array)
 (define-fresh fresh-gpu-texture make-gpu-texture target)
 (define-fresh fresh-gpu-shader make-gpu-shader type)
@@ -1072,3 +1123,87 @@
   (set-gpu-texture! gpu 0 texture)
   (set-active-texture-unit! 0)
   (gl-generate-mipmap (gpu-texture-target texture)))
+
+(define (gpu-buffer-upload gpu buffer usage data length offset)
+  (set-gpu-buffer! gpu buffer)
+  (gl-buffer-data (gpu-buffer-target buffer)
+                  length
+                  (if data
+                      (bytevector->pointer data offset)
+                      %null-pointer)
+                  (symbol->buffer-usage usage)))
+
+;; For streaming buffers, we use buffer re-specification to achieve
+;; good throughput.  However, it requires getting a new data pointer
+;; every frame and allocating a Scheme bytevector for that memory
+;; region.  Allocating this bytevector every frame causes significant
+;; GC pressure.  It turns out that GPU drivers tend to return the same
+;; set of pointers over and over, or at least the driver I'm using
+;; does this.  So, by caching bytevectors for those memory regions we
+;; avoid bytevector allocation after a frame or two of warmup.
+(define (pointer->bytevector/cached buffer pointer length)
+  (let* ((cache (gpu-buffer-stream-cache buffer))
+         (address (pointer-address pointer))
+         (cached (hashv-ref cache address)))
+    ;; It could be that there is a cached bytevector for the address,
+    ;; but the bytevector is a different length.  We must treat this
+    ;; as a cache miss and allocate a new bytevector.
+    (if (and cached (= (bytevector-length cached) length))
+        cached
+        (let ((bv (pointer->bytevector pointer length)))
+          (hashv-set! cache address bv)
+          bv))))
+
+(define (gpu-buffer-map gpu buffer length mode)
+  (let ((target (gpu-buffer-target buffer))
+        (usage (gpu-buffer-usage buffer)))
+    (set-gpu-buffer! gpu buffer)
+    (when (= usage (version-1-5 stream-draw))
+      ;; Orphan the buffer to avoid implicit synchronization.
+      ;; https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
+      (gl-buffer-data target length %null-pointer (gpu-buffer-usage buffer)))
+    (let ((ptr (gl-map-buffer target (symbol->access-mode mode))))
+      (pointer->bytevector/cached buffer ptr length))))
+
+(define (gpu-buffer-unmap gpu buffer)
+  (set-gpu-buffer! gpu buffer)
+  (gl-unmap-buffer (gpu-buffer-target buffer)))
+
+(define *offset-cache* (make-hash-table))
+
+(define (offset->pointer offset)
+  (or (hashv-ref *offset-cache* offset)
+      (let ((ptr (make-pointer offset)))
+        (hashv-set! *offset-cache* offset ptr)
+        ptr)))
+
+(define (gpu-vertex-array-apply-attribute gpu array buffer index size type
+                                          normalized? stride offset divisor)
+  (set-gpu-vertex-array! gpu array)
+  (set-gpu-buffer! gpu buffer)
+  (gl-enable-vertex-attrib-array index)
+  (gl-vertex-attrib-pointer index size (symbol->data-type type) normalized?
+                            stride (offset->pointer offset))
+  (when divisor
+    (gl-vertex-attrib-divisor index divisor)))
+
+(define (gpu-draw gpu mode count offset)
+  (gl-draw-arrays (symbol->begin-mode mode) offset count))
+
+(define (gpu-draw/indexed gpu indices type mode count offset)
+  (set-gpu-buffer! gpu indices)
+  (gl-draw-elements (symbol->begin-mode mode)
+                    count
+                    (symbol->data-type type)
+                    (offset->pointer offset)))
+
+(define (gpu-draw/instanced gpu mode count offset instances)
+  (gl-draw-arrays-instanced (symbol->begin-mode mode) offset count instances))
+
+(define (gpu-draw/instanced+indexed gpu indices type mode count offset instances)
+  (set-gpu-buffer! gpu indices)
+  (gl-draw-elements-instanced (symbol->begin-mode mode)
+                              count
+                              (symbol->data-type type)
+                              (offset->pointer offset)
+                              instances))