render: shader: Support primitive array uniform variables.

1 files changed, 52 insertions, 47 deletions

diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index 6eeb76d..02f0e12 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -202,11 +202,12 @@
   (scratch-pointer shader-scratch-pointer))
 
 (define-record-type <uniform>
-  (make-uniform name location type value)
+  (make-uniform name location type size value)
   uniform?
   (name uniform-name)
   (location uniform-location)
   (type uniform-type)
+  (size uniform-size)
   (value uniform-value %set-uniform-value!))
 
 (define-record-type <attribute>
@@ -293,42 +294,49 @@ them into a GPU shader program."
      ((= type (version-2-0 sampler-2d)) %sampler-2d)
      (else
       (error "unsupported OpenGL type" type))))
+  (define (parse-name name)
+    ;; Primitive array uniform names have a suffix of "[0]" that needs
+    ;; to be removed to produce the actual uniform variable name.
+    (if (string-suffix? "[0]" name)
+        (substring name 0 (- (string-length name) 3))
+        name))
   (define (extract-uniforms id)
     (let ((total (uniform-count id))
           (table (make-hash-table)))
       (let loop ((i 0)
-                 (texture-unit 0))
-        (unless (= i total)
-          (let ((length-bv (make-u32vector 1))
-                (size-bv (make-u32vector 1))
-                (type-bv (make-u32vector 1))
-                (name-bv (make-bytevector 255)))
-            (gl-get-active-uniform id i
-                                   (bytevector-length name-bv)
-                                   (bytevector->pointer length-bv)
-                                   (bytevector->pointer size-bv)
-                                   (bytevector->pointer type-bv)
-                                   (bytevector->pointer name-bv))
-            (let* ((name-length (u32vector-ref length-bv 0))
-                   (name (utf8->string* name-bv name-length))
-                   (location (gl-get-uniform-location id name))
-                   (size (u32vector-ref size-bv 0))
-                   (type (parse-data-type (u32vector-ref type-bv 0)))
-                   (sampler? (eq? type %sampler-2d))
-                   (default (if sampler?
-                                texture-unit
-                                (shader-data-type-null type))))
-              ;; TODO: Handle uniform arrays.
-              (unless (= size 1)
-                (error "unsupported uniform size" name size))
-              (hash-set! table
-                         name
-                         (make-uniform name location type default))
-              (loop (1+ i)
-                    (if sampler?
-                        (1+ texture-unit)
-                        texture-unit))))))
-      table))
+                 (texture-unit 0)
+                 (scratch-size 0))
+        (if (< i total)
+            (let ((length-bv (make-u32vector 1))
+                  (size-bv (make-u32vector 1))
+                  (type-bv (make-u32vector 1))
+                  (name-bv (make-bytevector 255)))
+              (gl-get-active-uniform id i
+                                     (bytevector-length name-bv)
+                                     (bytevector->pointer length-bv)
+                                     (bytevector->pointer size-bv)
+                                     (bytevector->pointer type-bv)
+                                     (bytevector->pointer name-bv))
+              (let* ((name-length (u32vector-ref length-bv 0))
+                     (name (utf8->string* name-bv name-length))
+                     (location (gl-get-uniform-location id name))
+                     (size (u32vector-ref size-bv 0))
+                     (type (parse-data-type (u32vector-ref type-bv 0)))
+                     (sampler? (eq? type %sampler-2d))
+                     (default (if sampler?
+                                  texture-unit
+                                  (shader-data-type-null type))))
+                (hash-set! table
+                           (parse-name name)
+                           (make-uniform name location type size default))
+                (loop (1+ i)
+                      (if sampler?
+                          (1+ texture-unit)
+                          texture-unit)
+                      (max scratch-size
+                           (* size
+                              (shader-data-type-size type))))))
+            (values table scratch-size)))))
   (define (attribute-count id)
     (let ((bv (make-u32vector 1)))
       (gl-get-programiv id
@@ -357,7 +365,6 @@ them into a GPU shader program."
                    (location (gl-get-attrib-location id name)))
               (unless (= size 1)
                 (error "unsupported attribute size" name size))
-
               (hash-set! table name (make-attribute name location type))))
           (loop (1+ i))))
       table))
@@ -365,12 +372,7 @@ them into a GPU shader program."
                                       vertex-port))
         (fragment-id (make-shader-stage (version-2-0 fragment-shader)
                                         fragment-port))
-        (id (gl-create-program))
-        ;; For now, make the scratch space the size of the largest
-        ;; primitive data type: mat4.  The size of this space will
-        ;; need to be dynamically determined when support for arrays
-        ;; and user-defined structs is added.
-        (scratch (make-bytevector 64)))
+        (id (gl-create-program)))
     (gl-attach-shader id vertex-id)
     (gl-attach-shader id fragment-id)
     (gl-link-program id)
@@ -380,9 +382,13 @@ them into a GPU shader program."
         (error "failed to link shader" error-log)))
     (gl-delete-shader vertex-id)
     (gl-delete-shader fragment-id)
-    (gpu-guard
-     (%make-shader id (extract-attributes id) (extract-uniforms id)
-                   scratch (bytevector->pointer scratch)))))
+    (call-with-values
+        (lambda () (extract-uniforms id))
+      (lambda (uniforms scratch-size)
+        (let ((scratch (make-bytevector scratch-size)))
+          (gpu-guard
+           (%make-shader id (extract-attributes id) uniforms
+                         scratch (bytevector->pointer scratch))))))))
 
 (define (load-shader vertex-source-file fragment-source-file)
   "Compile the GLSL source code within VERTEX-SOURCE-FILE and
@@ -409,12 +415,11 @@ shader program."
     (or uniform (error "no such uniform" name))))
 
 (define (shader-uniform-set! shader uniform-name x)
-  "Change the value of UNIFORM to X.  This procedure assumes that the
-shader where UNIFORM is defined is currently bound in the OpenGL
-context.  The behavior of this procedure under any other circumstance
-is undefined."
   (let* ((uniform (shader-uniform shader uniform-name))
          (type (uniform-type uniform)))
+    (when (and (> (uniform-size uniform) 1)
+               (not (= (uniform-size uniform) (vector-length x))))
+      (error "vector size mismatch for uniform" uniform-name))
     ;; TODO: Figure out a way to avoid unnecessary uniform updates.
     (shader-data-type-serialize type (shader-scratch shader) x)
     (shader-data-type-apply-uniform type (uniform-location uniform) 1 (shader-scratch-pointer shader))