From 022e1e7e4ebaa7c6f173137f2f20db1721a50cea Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 16 May 2023 18:59:10 -0400
Subject: graphics: shader: Reduce closure allocation.

---
 chickadee/graphics/shader.scm | 106 ++++++++++++++++++++++--------------------
 1 file changed, 55 insertions(+), 51 deletions(-)

diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm
index 5af2c7e..94c6bfc 100644
--- a/chickadee/graphics/shader.scm
+++ b/chickadee/graphics/shader.scm
@@ -804,64 +804,68 @@ shader program."
                                          (shader-scratch-pointer shader))
     (%set-uniform-value! uniform value)))
 
+(define (shader-uniform-for-each* proc shader thing)
+  (cond
+   ((uniform? thing)
+    (proc thing))
+   ((uniform-namespace? thing)
+    (uniform-namespace-for-each
+     (lambda (key uniform)
+       (shader-uniform-for-each* proc shader uniform))
+     thing))
+   ((uniform-array? thing)
+    (for-range ((i (uniform-array-size thing)))
+      (shader-uniform-for-each* proc shader (uniform-array-namespace-ref thing i))))))
+
 (define (shader-uniform-for-each proc shader)
-  (define (traverse thing)
-    (cond
-     ((uniform? thing)
-      (proc thing))
-     ((uniform-namespace? thing)
-      (uniform-namespace-for-each
-       (lambda (key uniform)
-         (traverse uniform))
-       thing))
-     ((uniform-array? thing)
-      (for-range ((i (uniform-array-size thing)))
-        (traverse (uniform-array-namespace-ref thing i))))))
-  (traverse (shader-uniforms shader)))
+  (shader-uniform-for-each* proc shader (shader-uniforms shader)))
 
 ;; TODO: This walks the entire tree every time, but it should instead
 ;; stop traversing once it finds the correct leaf node.
+(define (%shader-uniform-set shader uniform value)
+  (cond
+   ;; A leaf node of the uniform tree representing a single uniform
+   ;; location as determined by OpenGL.
+   ((uniform? uniform)
+    ;; A vector of a primitive type must be the exact size that
+    ;; the shader expects.
+    (when (and (> (uniform-size uniform) 1)
+               (not (= (uniform-size uniform) (vector-length value))))
+      (error "vector size mismatch for uniform" uniform-name))
+    (set-uniform-value! shader uniform value))
+   ;; A nested namespace indicates that this must be a struct.
+   ((uniform-namespace? uniform)
+    (if (shader-struct? value)
+        (uniform-namespace-for-each
+         (lambda (key uniform)
+           ;; Samplers are opaque types and you cannot pass them
+           ;; into the shader as uniform values like you can with
+           ;; most other values.  In the case of samplers, they are
+           ;; mapped to OpenGL's "texture units", so we need to
+           ;; ignore them here.
+           (unless (sampler? uniform)
+             (%shader-uniform-set shader uniform
+                                  (shader-struct-ref value key))))
+         uniform)
+        (error "expected shader struct" value)))
+   ;; A nested array namespace indicates that this must be an array
+   ;; of structs.
+   ((uniform-array? uniform)
+    (let ((size (uniform-array-size uniform)))
+      ;; Vector size must match what the shader expects.
+      (if (and (vector? value)
+               (= size (vector-length value)))
+          (for-range ((i size))
+            (%shader-uniform-set shader
+                                 (uniform-array-namespace-ref uniform i)
+                                 (vector-ref value i)))
+          (error "vector size mismatch for uniform"
+                 (uniform-array-name uniform)))))))
+
 (define (shader-uniform-set! shader uniform-name x)
-  (define (traverse uniform value)
-    (cond
-     ;; A leaf node of the uniform tree representing a single uniform
-     ;; location as determined by OpenGL.
-     ((uniform? uniform)
-      ;; A vector of a primitive type must be the exact size that
-      ;; the shader expects.
-      (when (and (> (uniform-size uniform) 1)
-                 (not (= (uniform-size uniform) (vector-length x))))
-        (error "vector size mismatch for uniform" uniform-name))
-      (set-uniform-value! shader uniform value))
-     ;; A nested namespace indicates that this must be a struct.
-     ((uniform-namespace? uniform)
-      (if (shader-struct? value)
-          (uniform-namespace-for-each
-           (lambda (key uniform)
-             ;; Samplers are opaque types and you cannot pass them
-             ;; into the shader as uniform values like you can with
-             ;; most other values.  In the case of samplers, they are
-             ;; mapped to OpenGL's "texture units", so we need to
-             ;; ignore them here.
-             (unless (sampler? uniform)
-               (traverse uniform (shader-struct-ref value key))))
-           uniform)
-          (error "expected shader struct" x)))
-     ;; A nested array namespace indicates that this must be an array
-     ;; of structs.
-     ((uniform-array? uniform)
-      (let ((size (uniform-array-size uniform)))
-        ;; Vector size must match what the shader expects.
-        (if (and (vector? value)
-                 (= size (vector-length value)))
-            (for-range ((i size))
-              (traverse (uniform-array-namespace-ref uniform i)
-                        (vector-ref value i)))
-            (error "vector size mismatch for uniform"
-                   (uniform-array-name uniform)))))))
   ;; Walk the uniform namespace tree until we get to a leaf node or
   ;; nodes.
-  (traverse (shader-uniform shader uniform-name) x))
+  (%shader-uniform-set shader (shader-uniform shader uniform-name) x))
 
 (define-syntax uniform-apply
   (lambda (x)
-- 
cgit v1.2.3