diff options
| -rw-r--r-- | chickadee/render/shader.scm | 241 |
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) |