render: shader: Decouple uniform serialization with uniform setting.

2 files changed, 104 insertions, 38 deletions

diff --git a/chickadee/render.scm b/chickadee/render.scm
index f502369..b898cb5 100644
--- a/chickadee/render.scm
+++ b/chickadee/render.scm
@@ -136,7 +136,7 @@
        (with-syntax ((sname (datum->syntax x (keyword->string
                                               (syntax->datum #'name)))))
          #'(begin
-             (set-uniform-value! (shader-uniform shader sname) value)
+             (shader-uniform-set! shader sname value)
              (uniform-apply shader rest)))))))
 
 (define-syntax-rule (gpu-prepare shader vertex-array uniforms)
@@ -154,9 +154,12 @@
         (texture-set! i (current-texture i))
         (loop (1+ i))))
     (uniform-apply shader uniforms)
+    ;; Sampler2D values aren't explicitly passed as uniform values via
+    ;; gpu-apply, so we have to set their values correctly behind the
+    ;; scenes.
     (hash-for-each (lambda (name uniform)
                      (when (eq? 'sampler-2d (uniform-type uniform))
-                       (set-uniform-value! uniform (uniform-value uniform))))
+                       (shader-uniform-set! shader (uniform-name uniform) (uniform-value uniform))))
                    (shader-uniforms shader))))
 
 (define-syntax-rule (gpu-apply* shader vertex-array count . uniforms)
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index bdbd08a..91d363c 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -41,11 +41,11 @@
             shader-uniform
             shader-uniforms
             shader-attributes
+            shader-uniform-set!
             uniform?
             uniform-name
             uniform-type
             uniform-value
-            set-uniform-value!
             attribute?
             attribute-name
             attribute-location
@@ -58,82 +58,130 @@
 ;;;
 
 (define-record-type <shader-data-type>
-  (%make-shader-data-type name setter null)
+  (%make-shader-data-type name size serializer setter null)
   shader-data-type?
   (name shader-data-type-name)
+  (size shader-data-type-size)
+  (serializer shader-data-type-serializer)
   (setter shader-data-type-setter)
   (null shader-data-type-null))
 
-(define* (make-shader-data-type #:key name setter null)
-  (%make-shader-data-type name setter null))
+(define* (make-shader-data-type #:key name size serializer setter null)
+  (%make-shader-data-type name size serializer setter null))
+
+(define (shader-data-type-serialize type bv data)
+  (let ((serialize (shader-data-type-serializer type)))
+    (if (vector? data)
+        (let ((size (shader-data-type-size type)))
+          (let loop ((i 0))
+            (when (< i (vector-length data))
+              (serialize bv (* i size) (vector-ref data i))
+              (loop (+ i 1)))))
+        (serialize bv 0 data))))
+
+(define (shader-data-type-apply-uniform type location count pointer)
+  ((shader-data-type-setter type) location count pointer))
 
 ;; Primitive types:
 (define %bool
   (make-shader-data-type
    #:name 'bool
-   #:setter (lambda (location bool)
-              (gl-uniform1i location (if bool 1 0)))
+   #:size 4
+   #:serializer
+   (lambda (bv i bool)
+     (bytevector-s32-native-set! bv i (if bool 1 0)))
+   #:setter gl-uniform1iv
    #:null #false))
 
 (define %int
   (make-shader-data-type
    #:name 'int
-   #:setter (lambda (location n)
-              (gl-uniform1i location n))
+   #:size 4
+   #:serializer
+   (lambda (bv i n)
+     (bytevector-s32-native-set! bv i n))
+   #:setter gl-uniform1iv
    #:null 0))
 
 (define %unsigned-int
   (make-shader-data-type
    #:name 'unsigned-int
-   #:setter (lambda (location u)
-              (gl-uniform1ui location u))
+   #:size 4
+   #:serializer
+   (lambda (bv i u)
+     (bytevector-u32-native-set! bv i u))
+   #:setter gl-uniform1uiv
    #:null 0))
 
 (define %float
   (make-shader-data-type
    #:name 'float
-   #:setter (lambda (location f)
-              (gl-uniform1f location f))
+   #:size 4
+   #:serializer
+   (lambda (bv i f)
+     (bytevector-ieee-single-native-set! bv i f))
+   #:setter gl-uniform1fv
    #:null 0.0))
 
 (define %float-vec2
   (make-shader-data-type
    #:name 'float-vec2
-   #:setter (lambda (location v)
-              (gl-uniform2fv location 1 (vec2->pointer v)))
+   #:size 8 ; 8 bytes = 2 floats = 1 vec2
+   #:serializer
+   (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2)))
+     (lambda (bv i v)
+       (bytevector-copy! (unwrap-vec2 v) 0 bv i 8)))
+   #:setter gl-uniform2fv
    #:null (vec2 0.0 0.0)))
 
 (define %float-vec3
   (make-shader-data-type
    #:name 'float-vec3
-   #:setter (lambda (location v)
-              (gl-uniform3fv location 1 (vec3->pointer v)))
+   #:size 12 ; 12 bytes = 3 floats = 1 vec3
+   #:serializer
+   (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3)))
+     (lambda (bv i v)
+       (bytevector-copy! (unwrap-vec3 v) 0 bv i 12)))
+   #:setter gl-uniform3fv
    #:null (vec3 0.0 0.0 0.0)))
 
 (define %float-vec4
   (make-shader-data-type
    #:name 'float-vec4
-   #:setter (lambda (location v)
-              (gl-uniform4f location
-                            (color-r v)
-                            (color-g v)
-                            (color-b v)
-                            (color-a v)))
+   #:size 16 ; 16 bytes = 4 floats = 1 vec4
+   #:serializer
+   (lambda (bv i v)
+     ;; As of now, there is no vec4 Scheme type, but we do want to
+     ;; accept colors as vec4s since there is no special color type in
+     ;; GLSL.
+     (bytevector-ieee-single-native-set! bv i (color-r v))
+     (bytevector-ieee-single-native-set! bv (+ i 4) (color-g v))
+     (bytevector-ieee-single-native-set! bv (+ i 8) (color-b v))
+     (bytevector-ieee-single-native-set! bv (+ i 12) (color-a v)))
+   #:setter gl-uniform4fv
    #:null (color 0.0 0.0 0.0 0.0)))
 
 (define %mat4
   (make-shader-data-type
    #:name 'mat4
-   #:setter (let ((matrix4-ptr (@@ (chickadee math matrix) matrix4-ptr)))
-              (lambda (location m)
-                (gl-uniform-matrix4fv location 1 #f (matrix4-ptr m))))
+   #:size 64 ; 4 rows x 4 columns = 16 floats x 4 bytes each = 64 bytes
+   #:serializer
+   (let ((matrix4-bv (@@ (chickadee math matrix) matrix4-bv)))
+     (lambda (bv i m)
+       ;; 4 rows x 4 columns x 4 bytes per float = 4^3
+       (bytevector-copy! (matrix4-bv m) 0 bv i (* 4 4 4))))
+   #:setter (lambda (location count ptr)
+              (gl-uniform-matrix4fv location count #f ptr))
    #:null (make-identity-matrix4)))
 
 (define %sampler-2d
   (make-shader-data-type
    #:name 'sampler-2d
-   #:setter (lambda (location texture-unit)
-              (gl-uniform1i location texture-unit))
+   #:size 4
+   #:serializer
+   (lambda (bv i texture-unit)
+     (bytevector-s32-native-set! bv i texture-unit))
+   #:setter gl-uniform1iv
    #:null 0))
 
 
@@ -142,11 +190,16 @@
 ;;;
 
 (define-record-type <shader>
-  (%make-shader id attributes uniforms)
+  (%make-shader id attributes uniforms scratch scratch-pointer)
   shader?
   (id shader-id)
   (attributes shader-attributes)
-  (uniforms shader-uniforms))
+  (uniforms shader-uniforms)
+  ;; Scratch space for serializing uniform values.
+  (scratch shader-scratch)
+  ;; Create the pointer once and hold onto it to reduce needless
+  ;; garbage creation.
+  (scratch-pointer shader-scratch-pointer))
 
 (define-record-type <uniform>
   (make-uniform name location type value)
@@ -163,7 +216,7 @@
   (location attribute-location)
   (type attribute-type))
 
-(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table)))
+(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table) #f #f))
 
 (define <<shader>> (class-of null-shader))
 
@@ -319,12 +372,16 @@ them into a GPU shader program."
           (gl-delete-shader id) ; clean up GPU resource.
           (error "failed to compile shader" error-log)))
       id))
-
   (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
                                       vertex-port))
         (fragment-id (make-shader-stage (version-2-0 fragment-shader)
                                         fragment-port))
-        (id (gl-create-program)))
+        (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)))
     (gl-attach-shader id vertex-id)
     (gl-attach-shader id fragment-id)
     (gl-link-program id)
@@ -334,7 +391,9 @@ 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)))))
+    (gpu-guard
+     (%make-shader id (extract-attributes id) (extract-uniforms id)
+                   scratch (bytevector->pointer scratch)))))
 
 (define (load-shader vertex-source-file fragment-source-file)
   "Compile the GLSL source code within VERTEX-SOURCE-FILE and
@@ -360,10 +419,14 @@ shader program."
   (let ((uniform (hash-ref (shader-uniforms shader) name)))
     (or uniform (error "no such uniform" name))))
 
-(define (set-uniform-value! uniform x)
+(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."
-  ((shader-data-type-setter (uniform-type uniform)) (uniform-location uniform) x)
-  (%set-uniform-value! uniform x))
+  (let* ((uniform (shader-uniform shader uniform-name))
+         (type (uniform-type uniform)))
+    ;; 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))
+    (%set-uniform-value! uniform x)))