summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/gpu.scm175
-rw-r--r--chickadee/graphics/shader.scm188
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)))