diff options
| -rw-r--r-- | chickadee/graphics/gpu.scm | 175 | ||||
| -rw-r--r-- | chickadee/graphics/shader.scm | 188 |
2 files changed, 232 insertions, 131 deletions
diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm index ef12d10..66d2c31 100644 --- a/chickadee/graphics/gpu.scm +++ b/chickadee/graphics/gpu.scm @@ -165,12 +165,32 @@ free-gpu-shader gpu-shader? gpu-shader-id + gpu-shader-compiled? + gpu-shader-info-log + set-gpu-shader-source + gpu-shader-compile gpu-shader:null fresh-gpu-program free-gpu-program gpu-program? gpu-program-id + gpu-program-linked? + gpu-program-attach-shader + gpu-program-link + gpu-program-info-log + gpu-program-uniform-count + gpu-program-attribute-count + gpu-program-uniform-ref + gpu-program-attribute-ref + set-gpu-program-uniform:signed-int + set-gpu-program-uniform:unsigned-int + set-gpu-program-uniform:float + set-gpu-program-uniform:vec2 + set-gpu-program-uniform:vec3 + set-gpu-program-uniform:vec4 + set-gpu-program-uniform:mat3 + set-gpu-program-uniform:mat4 gpu-program:null make-gpu @@ -1255,3 +1275,158 @@ (symbol->data-type type) (offset->pointer offset) instances)) + +(define (gpu-shader-compiled? shader) + (let ((status (make-u32vector 1))) + (gl-get-shaderiv (gpu-shader-id shader) + (version-2-0 compile-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + +(define (set-gpu-shader-source shader source) + (let ((bv (string->utf8 source))) + (gl-shader-source (gpu-shader-id shader) + 1 + (bytevector->pointer + (u64vector + (pointer-address (bytevector->pointer bv)))) + (bytevector->pointer + (u32vector (bytevector-length bv)))))) + +(define (gpu-shader-compile shader) + (gl-compile-shader (gpu-shader-id shader))) + +(define (set-gpu-program-uniform:signed-int location ptr) + (gl-uniform1iv location 1 ptr)) + +(define (set-gpu-program-uniform:unsigned-int location ptr) + (gl-uniform1uiv location 1 ptr)) + +(define (set-gpu-program-uniform:float location ptr) + (gl-uniform1fv location 1 ptr)) + +(define (set-gpu-program-uniform:vec2 location ptr) + (gl-uniform2fv location 1 ptr)) + +(define (set-gpu-program-uniform:vec3 location ptr) + (gl-uniform3fv location 1 ptr)) + +(define (set-gpu-program-uniform:vec4 location ptr) + (gl-uniform4fv location 1 ptr)) + +(define (set-gpu-program-uniform:mat3 location ptr) + (gl-uniform-matrix3fv location 1 #f ptr)) + +(define (set-gpu-program-uniform:mat4 location ptr) + (gl-uniform-matrix4fv location 1 #f ptr)) + +(define (gpu-program-linked? program) + (let ((status (make-u32vector 1))) + (gl-get-programiv (gpu-program-id program) + (version-2-0 link-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + +(define (gpu-shader-info-log shader) + (let ((log-length-bv (make-u32vector 1))) + (gl-get-shaderiv (gpu-shader-id shader) (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)))) + (gl-get-shader-info-log (gpu-shader-id shader) log-length + %null-pointer (bytevector->pointer log)) + (utf8->string log)))) + +(define (gpu-program-info-log program) + (let ((log-length-bv (make-u32vector 1))) + (gl-get-shaderiv (gpu-shader-id program) (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)))) + (gl-get-shader-info-log (gpu-shader-id program) log-length + %null-pointer (bytevector->pointer log)) + (utf8->string log)))) + +(define (gpu-program-attach-shader program shader) + (gl-attach-shader (gpu-program-id program) (gpu-shader-id shader))) + +(define (gpu-program-link program) + (gl-link-program (gpu-program-id program))) + +(define (gpu-program-uniform-count program) + (let ((bv (make-u32vector 1))) + (gl-get-programiv (gpu-program-id program) + (arb-shader-objects active-uniforms) + (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (gpu-program-attribute-count program) + (let ((bv (make-u32vector 1))) + (gl-get-programiv (gpu-program-id program) + (arb-shader-objects active-attributes) + (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-mat3)) 'mat3) + ((= type (version-2-0 float-mat4)) 'mat4) + ((= type (version-2-0 sampler-2d)) 'sampler-2d) + ((= type (version-2-0 sampler-cube)) 'sampler-cube) + (else + (error "unsupported OpenGL uniform type" type)))) + +(define (gpu-program-uniform-ref program index) + (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 (gpu-program-id program) + index + (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 (gpu-program-id program) name)) + (size (u32vector-ref size-bv 0)) + (type (parse-data-type (u32vector-ref type-bv 0)))) + (values name location size type)))) + +(define (gpu-program-attribute-ref program index) + (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 (gpu-program-id program) + index + (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 (gpu-program-id program) + name))) + (values name location size type)))) diff --git a/chickadee/graphics/shader.scm b/chickadee/graphics/shader.scm index f1e930f..9974b38 100644 --- a/chickadee/graphics/shader.scm +++ b/chickadee/graphics/shader.scm @@ -25,14 +25,12 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (gl) #:use-module (chickadee math matrix) #:use-module (chickadee math vector) #:use-module (chickadee math rect) #:use-module (chickadee graphics buffer) #:use-module (chickadee graphics color) #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) #:use-module (chickadee graphics gpu) #:use-module (chickadee graphics texture) #:use-module (chickadee utils) @@ -56,7 +54,6 @@ make-shader shader? null-shader - g:shader current-shader load-shader strings->shader @@ -113,8 +110,8 @@ (serialize bv (* i size) (vector-ref data i)))) (serialize bv 0 data)))) -(define (shader-primitive-type-apply-uniform type location count pointer) - ((shader-primitive-type-setter type) location count pointer)) +(define (shader-primitive-type-apply-uniform type location pointer) + ((shader-primitive-type-setter type) location pointer)) (define (shader-primitive-type-validate type data) (let ((valid? (shader-primitive-type-validator type))) @@ -137,7 +134,7 @@ #:serializer (lambda (bv i bool) (bytevector-s32-native-set! bv i (if bool 1 0))) - #:setter gl-uniform1iv + #:setter set-gpu-program-uniform:signed-int #:null #false) (define-shader-primitive-type int @@ -147,7 +144,7 @@ #:serializer (lambda (bv i n) (bytevector-s32-native-set! bv i n)) - #:setter gl-uniform1iv + #:setter set-gpu-program-uniform:signed-int #:null 0) (define-shader-primitive-type unsigned-int @@ -159,7 +156,7 @@ #:serializer (lambda (bv i u) (bytevector-u32-native-set! bv i u)) - #:setter gl-uniform1uiv + #:setter set-gpu-program-uniform:unsigned-int #:null 0) (define-shader-primitive-type float @@ -169,7 +166,7 @@ #:serializer (lambda (bv i f) (bytevector-ieee-single-native-set! bv i f)) - #:setter gl-uniform1fv + #:setter set-gpu-program-uniform:float #:null 0.0) (define-shader-primitive-type float-vec2 @@ -180,7 +177,7 @@ (let ((unwrap-vec2 (@@ (chickadee math vector) unwrap-vec2))) (lambda (bv i v) (bytevector-copy! (unwrap-vec2 v) 0 bv i 8))) - #:setter gl-uniform2fv + #:setter set-gpu-program-uniform:vec2 #:null (vec2 0.0 0.0)) (define-shader-primitive-type float-vec3 @@ -191,7 +188,7 @@ (let ((unwrap-vec3 (@@ (chickadee math vector) unwrap-vec3))) (lambda (bv i v) (bytevector-copy! (unwrap-vec3 v) 0 bv i 12))) - #:setter gl-uniform3fv + #:setter set-gpu-program-uniform:vec3 #:null (vec3 0.0 0.0 0.0)) (define-shader-primitive-type float-vec4 @@ -199,19 +196,18 @@ #:size 16 ; 16 bytes = 4 floats = 1 vec4 #:validator (lambda (x) (or (rect? x) (color? x))) #:serializer - (let ((unwrap-rect (@@ (chickadee math rect) unwrap-rect))) + (let ((unwrap-rect (@@ (chickadee math rect) unwrap-rect)) + (unwrap-color (@@ (chickadee graphics color) unwrap-color))) (lambda (bv i v) ;; As of now, there is no vec4 Scheme type, but we do want to ;; accept colors and rects as vec4s since there is no special ;; color or rect type in GLSL. - (if (rect? v) - (bytevector-copy! (unwrap-rect v) 0 bv i 16) - (begin - (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 + (cond + ((rect? v) + (bytevector-copy! (unwrap-rect v) 0 bv i 16)) + ((color? v) + (bytevector-copy! (unwrap-color v) 0 bv i 16))))) + #:setter set-gpu-program-uniform:vec4 #:null (make-null-rect)) (define-shader-primitive-type mat3 @@ -222,8 +218,7 @@ (let ((matrix3-bv (@@ (chickadee math matrix) matrix3-bv))) (lambda (bv i m) (bytevector-copy! (matrix3-bv m) 0 bv i (* 3 3 4)))) - #:setter (lambda (location count ptr) - (gl-uniform-matrix3fv location count #f ptr)) + #:setter set-gpu-program-uniform:mat3 #:null (make-identity-matrix3)) (define-shader-primitive-type mat4 @@ -235,8 +230,7 @@ (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)) + #:setter set-gpu-program-uniform:mat4 #:null (make-identity-matrix4)) (define-shader-primitive-type sampler-2d @@ -246,7 +240,7 @@ #:serializer (lambda (bv i texture-unit) (bytevector-s32-native-set! bv i texture-unit)) - #:setter gl-uniform1iv + #:setter set-gpu-program-uniform:signed-int #:null 0) (define-shader-primitive-type sampler-cube @@ -256,7 +250,7 @@ #:serializer (lambda (bv i texture-unit) (bytevector-s32-native-set! bv i texture-unit)) - #:setter gl-uniform1iv + #:setter set-gpu-program-uniform:signed-int #:null 0) @@ -502,38 +496,12 @@ (location attribute-location) (type attribute-type)) -(define null-shader (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f)) +(define null-shader + (%make-shader gpu-program:null (make-hash-table) (make-hash-table) #f #f)) (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 (gpu-shader-id 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 (gpu-program-id 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 (gpu-shader-id 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 (gpu-shader-id 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 (glsl-preprocessor-source) ;; Set up preprocessor directives dynamically based on the current ;; OpenGL context's GLSL version so that we can write shaders that @@ -557,49 +525,32 @@ them into a GPU shader program." (error "incompatible GLSL version" glsl-version))))) (define (make-shader-stage type port) (let* ((gpu (current-gpu)) - (id (fresh-gpu-shader gpu type)) - (source (string->utf8 - (string-append (glsl-preprocessor-source) - (get-string-all port))))) - (gl-shader-source (gpu-shader-id id) 1 - (bytevector->pointer - (u64vector - (pointer-address (bytevector->pointer source)))) - (bytevector->pointer - (u32vector (bytevector-length source)))) - (gl-compile-shader (gpu-shader-id id)) - (unless (shader-compiled? id) - (let ((error-log (compilation-error id))) + (id (fresh-gpu-shader gpu type))) + (set-gpu-shader-source id (string-append (glsl-preprocessor-source) + (get-string-all port))) + (gpu-shader-compile id) + (unless (gpu-shader-compiled? id) + (let ((error-log (gpu-shader-info-log id))) (free-gpu-shader id) ; clean up GPU resource. (display "shader compilation failed:\n") (display error-log (current-error-port)) (error "failed to compile shader"))) id)) - (define (uniform-count id) - (let ((bv (make-u32vector 1))) - (gl-get-programiv (gpu-program-id 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-mat3)) mat3) - ((= type (version-2-0 float-mat4)) mat4) - ((= type (version-2-0 sampler-2d)) sampler-2d) - ((= type (version-2-0 sampler-cube)) sampler-cube) + (match type + ('bool bool) + ('int int) + ('unsigned-int unsigned-int) + ('float float) + ('float-vec2 float-vec2) + ('float-vec3 float-vec3) + ('float-vec4 float-vec4) + ('mat3 mat3) + ('mat4 mat4) + ('sampler-2d sampler-2d) + ('sampler-cube sampler-cube) (else - (error "unsupported OpenGL type" type)))) + (error "unsupported uniform type" type)))) (define (camel->snake str) (list->string (let loop ((i 0)) @@ -652,7 +603,7 @@ them into a GPU shader program." new-name))) (inner rest new-namespace)))))))) (define (extract-uniforms id) - (let ((total (uniform-count id)) + (let ((total (gpu-program-uniform-count id)) (namespace (fresh-uniform-namespace "root"))) ;; OpenGL has an API for shader program introspection that we ;; use to extract all active uniforms. This uniform data must @@ -668,18 +619,9 @@ them into a GPU shader program." (size-bv (make-u32vector 1)) (type-bv (make-u32vector 1)) (name-bv (make-bytevector 255))) - (gl-get-active-uniform (gpu-program-id 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 (gpu-program-id id) name)) - (size (u32vector-ref size-bv 0)) - (type (parse-data-type (u32vector-ref type-bv 0))) + (define-values (name location size %type) + (gpu-program-uniform-ref id i)) + (let* ((type (parse-data-type %type)) (sampler? (or (eq? type sampler-2d) (eq? type sampler-cube))) (default (cond (sampler? @@ -709,46 +651,30 @@ them into a GPU shader program." (* size (shader-primitive-type-size type)))))) (values namespace scratch-size))))) - (define (attribute-count id) - (let ((bv (make-u32vector 1))) - (gl-get-programiv (gpu-program-id id) - (arb-shader-objects active-attributes) - (bytevector->pointer bv)) - (u32vector-ref bv 0))) (define (extract-attributes id) - (let ((total (attribute-count id)) + (let ((total (gpu-program-attribute-count id)) (table (make-hash-table))) (for-range ((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 (gpu-program-id 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 (gpu-program-id id) name))) - (unless (= size 1) - (error "unsupported attribute size" name size)) - (hash-set! table name (make-attribute name location type))))) + (define-values (name location size type) + (gpu-program-attribute-ref id i)) + (unless (= size 1) + (error "unsupported attribute size" name size)) + (hash-set! table name (make-attribute name location type)))) table)) (assert-current-graphics-engine) (let* ((gpu (current-gpu)) (vertex-id (make-shader-stage 'vertex vertex-port)) (fragment-id (make-shader-stage 'fragment fragment-port)) (id (fresh-gpu-program gpu))) - (gl-attach-shader (gpu-program-id id) (gpu-shader-id vertex-id)) - (gl-attach-shader (gpu-program-id id) (gpu-shader-id fragment-id)) - (gl-link-program (gpu-program-id id)) - (unless (shader-linked? id) - (let ((error-log (linking-error id))) + (gpu-program-attach-shader id vertex-id) + (gpu-program-attach-shader id fragment-id) + (gpu-program-link id) + (unless (gpu-program-linked? id) + (let ((error-log (gpu-program-info-log id))) (free-gpu-program id) (error "failed to link shader" error-log))) (free-gpu-shader vertex-id) @@ -791,7 +717,7 @@ shader program." ;; updates. Maybe UBOs would help address this? (let ((type (uniform-type uniform))) (shader-primitive-type-serialize type (shader-scratch shader) value) - (shader-primitive-type-apply-uniform type (uniform-location uniform) 1 + (shader-primitive-type-apply-uniform type (uniform-location uniform) (shader-scratch-pointer shader)) (%set-uniform-value! uniform value))) |