summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/render/shader.scm241
1 files changed, 115 insertions, 126 deletions
diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm
index 91d363c..6eeb76d 100644
--- a/chickadee/render/shader.scm
+++ b/chickadee/render/shader.scm
@@ -228,135 +228,33 @@
(define *shader-state* (make-gpu-state apply-shader null-shader))
-(define (shader-compiled? id)
- (let ((status (make-u32vector 1)))
- (gl-get-shaderiv id (version-2-0 compile-status)
- (bytevector->pointer status))
- (= (u32vector-ref status 0) 1)))
-
-(define (shader-linked? id)
- (let ((status (make-u32vector 1)))
- (gl-get-programiv id (version-2-0 link-status)
- (bytevector->pointer status))
- (= (u32vector-ref status 0) 1)))
-
-(define (info-log length-proc log-proc id)
- (let ((log-length-bv (make-u32vector 1)))
- (length-proc id (version-2-0 info-log-length)
- (bytevector->pointer log-length-bv))
- (u32vector-ref log-length-bv 0)
- ;; Add one byte to account for the null string terminator.
- (let* ((log-length (u32vector-ref log-length-bv 0))
- (log (make-u8vector (1+ log-length))))
- (log-proc id log-length %null-pointer (bytevector->pointer log))
- (utf8->string log))))
-
-(define (compilation-error id)
- (info-log gl-get-shaderiv gl-get-shader-info-log id))
-
-(define (linking-error id)
- (info-log gl-get-programiv gl-get-program-info-log id))
-
-(define (uniform-count id)
- (let ((bv (make-u32vector 1)))
- (gl-get-programiv id
- (arb-shader-objects active-uniforms)
- (bytevector->pointer bv))
- (u32vector-ref bv 0)))
-
-(define (utf8->string* bv length)
- (let ((bv* (make-bytevector length)))
- (bytevector-copy! bv 0 bv* 0 length)
- (utf8->string bv*)))
-
-(define (parse-data-type type)
- (cond
- ((= type (version-2-0 bool)) %bool)
- ((= type (data-type int)) %int)
- ((= type (data-type unsigned-int)) %unsigned-int)
- ((= type (data-type float)) %float)
- ((= type (version-2-0 float-vec2)) %float-vec2)
- ((= type (version-2-0 float-vec3)) %float-vec3)
- ((= type (version-2-0 float-vec4)) %float-vec4)
- ((= type (version-2-0 float-mat4)) %mat4)
- ((= type (version-2-0 sampler-2d)) %sampler-2d)
- (else
- (error "unsupported OpenGL type" type))))
-
-(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))
-
-(define (attribute-count id)
- (let ((bv (make-u32vector 1)))
- (gl-get-programiv id
- (arb-shader-objects active-attributes)
- (bytevector->pointer bv))
- (u32vector-ref bv 0)))
-
-(define (extract-attributes id)
- (let ((total (attribute-count id))
- (table (make-hash-table)))
- (let loop ((i 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-attrib id i
- (bytevector-length name-bv)
- (bytevector->pointer length-bv)
- (bytevector->pointer size-bv)
- (bytevector->pointer type-bv)
- (bytevector->pointer name-bv))
- (let* ((length (u32vector-ref length-bv 0))
- (name (utf8->string* name-bv length))
- (size (u32vector-ref size-bv 0))
- (type (parse-data-type (u32vector-ref type-bv 0)))
- (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))
-
(define (make-shader vertex-port fragment-port)
"Read GLSL source from VERTEX-PORT and FRAGMENT-PORT and compile
them into a GPU shader program."
+ (define (shader-compiled? id)
+ (let ((status (make-u32vector 1)))
+ (gl-get-shaderiv id (version-2-0 compile-status)
+ (bytevector->pointer status))
+ (= (u32vector-ref status 0) 1)))
+ (define (shader-linked? id)
+ (let ((status (make-u32vector 1)))
+ (gl-get-programiv id (version-2-0 link-status)
+ (bytevector->pointer status))
+ (= (u32vector-ref status 0) 1)))
+ (define (info-log length-proc log-proc id)
+ (let ((log-length-bv (make-u32vector 1)))
+ (length-proc id (version-2-0 info-log-length)
+ (bytevector->pointer log-length-bv))
+ (u32vector-ref log-length-bv 0)
+ ;; Add one byte to account for the null string terminator.
+ (let* ((log-length (u32vector-ref log-length-bv 0))
+ (log (make-u8vector (1+ log-length))))
+ (log-proc id log-length %null-pointer (bytevector->pointer log))
+ (utf8->string log))))
+ (define (compilation-error id)
+ (info-log gl-get-shaderiv gl-get-shader-info-log id))
+ (define (linking-error id)
+ (info-log gl-get-programiv gl-get-program-info-log id))
(define (make-shader-stage type port)
(let ((id (gl-create-shader type))
(source (get-bytevector-all port)))
@@ -372,6 +270,97 @@ them into a GPU shader program."
(gl-delete-shader id) ; clean up GPU resource.
(error "failed to compile shader" error-log)))
id))
+ (define (uniform-count id)
+ (let ((bv (make-u32vector 1)))
+ (gl-get-programiv id
+ (arb-shader-objects active-uniforms)
+ (bytevector->pointer bv))
+ (u32vector-ref bv 0)))
+ (define (utf8->string* bv length)
+ (let ((bv* (make-bytevector length)))
+ (bytevector-copy! bv 0 bv* 0 length)
+ (utf8->string bv*)))
+ (define (parse-data-type type)
+ (cond
+ ((= type (version-2-0 bool)) %bool)
+ ((= type (data-type int)) %int)
+ ((= type (data-type unsigned-int)) %unsigned-int)
+ ((= type (data-type float)) %float)
+ ((= type (version-2-0 float-vec2)) %float-vec2)
+ ((= type (version-2-0 float-vec3)) %float-vec3)
+ ((= type (version-2-0 float-vec4)) %float-vec4)
+ ((= type (version-2-0 float-mat4)) %mat4)
+ ((= type (version-2-0 sampler-2d)) %sampler-2d)
+ (else
+ (error "unsupported OpenGL type" type))))
+ (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))
+ (define (attribute-count id)
+ (let ((bv (make-u32vector 1)))
+ (gl-get-programiv id
+ (arb-shader-objects active-attributes)
+ (bytevector->pointer bv))
+ (u32vector-ref bv 0)))
+ (define (extract-attributes id)
+ (let ((total (attribute-count id))
+ (table (make-hash-table)))
+ (let loop ((i 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-attrib id i
+ (bytevector-length name-bv)
+ (bytevector->pointer length-bv)
+ (bytevector->pointer size-bv)
+ (bytevector->pointer type-bv)
+ (bytevector->pointer name-bv))
+ (let* ((length (u32vector-ref length-bv 0))
+ (name (utf8->string* name-bv length))
+ (size (u32vector-ref size-bv 0))
+ (type (parse-data-type (u32vector-ref type-bv 0)))
+ (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))
(let ((vertex-id (make-shader-stage (version-2-0 vertex-shader)
vertex-port))
(fragment-id (make-shader-stage (version-2-0 fragment-shader)