summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-02-09 20:18:34 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commitcf99d0c491547aadd4d5f87a03a3ad4407081435 (patch)
tree270a951f91c7d7a240dccd54e6673b8a95f71f62
parentb941edf4d95697e84b56f2702dab3b33aa22f60e (diff)
Improve shader linking phase.
-rw-r--r--chickadee/graphics/seagull.scm219
1 files changed, 123 insertions, 96 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index ec600ba..8f1a474 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -2533,23 +2533,33 @@
;; Combine all of the compiler passes on a user provided program and
;; emit GLSL code if the program is valid.
-(define-record-type <shader-input>
- (make-shader-input type name)
- shader-input?
- (type input-type)
- (name input-name))
-
-(define-record-type <shader-output>
- (make-shader-output type name)
- shader-output?
- (type output-type)
- (name output-name))
-
-(define-record-type <shader-uniform>
- (make-shader-uniform type name)
- shader-uniform?
- (type uniform-type)
- (name uniform-name))
+(define-record-type <seagull-global>
+ (make-seagull-global qualifier type-descriptor name)
+ seagull-global?
+ (qualifier seagull-global-qualifier)
+ (type-descriptor seagull-global-type-descriptor)
+ (name seagull-global-name))
+
+(define (seagull-qualifier-input? global)
+ (eq? (seagull-global-qualifier global) 'in))
+
+(define (seagull-qualifier-output? global)
+ (eq? (seagull-global-qualifier global) 'out))
+
+(define (seagull-qualifier-uniform? global)
+ (eq? (seagull-global-qualifier global) 'uniform))
+
+;; (define-record-type <seagull-output>
+;; (make-seagull-output type-descriptor name)
+;; seagull-output?
+;; (type-descriptor output-type-descriptor)
+;; (name output-name))
+
+;; (define-record-type <seagull-uniform>
+;; (make-seagull-uniform type-descriptor name)
+;; seagull-uniform?
+;; (type-descriptor uniform-type-descriptor)
+;; (name uniform-name))
(define-record-type <seagull-module>
(%make-seagull-module stage inputs outputs uniforms source compiled
@@ -2579,12 +2589,20 @@
(define* (compile-seagull-module #:key stage source
(inputs '()) (outputs '()) (uniforms '()))
+ (define (specs->globals specs)
+ (map (match-lambda
+ ((qualifier type-desc name)
+ (make-seagull-global qualifier type-desc name)))
+ specs))
(unless (memq stage '(vertex fragment))
(error "invalid shader stage" stage))
(parameterize ((unique-identifier-counter 0)
(unique-variable-type-counter 0))
(let ((source* `(top-level ,(append inputs outputs uniforms)
- ,source)))
+ ,source))
+ (inputs* (specs->globals inputs))
+ (outputs* (specs->globals outputs))
+ (uniforms* (specs->globals uniforms)))
(define-values (expanded global-map)
(expand source* stage (top-level-env)))
(let* ((propagated (propagate-constants expanded (empty-env)))
@@ -2592,9 +2610,9 @@
(inferred (infer-types hoisted stage))
(resolved (resolve-overloads inferred)))
(make-seagull-module #:stage stage
- #:inputs inputs
- #:outputs outputs
- #:uniforms uniforms
+ #:inputs inputs*
+ #:outputs outputs*
+ #:uniforms uniforms*
#:source source
#:compiled resolved
#:global-map global-map
@@ -2612,11 +2630,11 @@
(uniforms . ,(reverse uniforms))))
((spec . rest)
(match spec
- (('in _ _)
+ (('in type-desc name)
(loop rest (cons spec inputs) outputs uniforms))
- (('out _ _)
+ (('out type-desc name)
(loop rest inputs (cons spec outputs) uniforms))
- (('uniform _ _)
+ (('uniform type-desc name)
(loop rest inputs outputs (cons spec uniforms))))))))
(define-syntax-rule (define-shader name stage ((qualifier type var) ...) source)
@@ -2637,25 +2655,25 @@
(define (vertex-outputs-match-fragment-inputs? vertex fragment)
(let ((fragment-inputs (seagull-module-inputs fragment)))
- (every (match-lambda
- ((_ desc name)
- (any (match-lambda
- ((_ desc* name*)
- (and (eq? name name*)
- (equal? desc desc*))))
- fragment-inputs)))
+ (every (lambda (o1)
+ (any (lambda (o2)
+ (and (eq? (seagull-global-name o1)
+ (seagull-global-name o2))
+ (equal? (seagull-global-type-descriptor o1)
+ (seagull-global-type-descriptor o2))))
+ fragment-inputs))
(seagull-module-outputs vertex))))
(define (uniforms-compatible? vertex fragment)
(let ((fragment-uniforms (seagull-module-uniforms fragment)))
- (every (match-lambda
- ((_ desc name)
- (every (match-lambda
- ((_ desc* name*)
- (if (eq? name name*)
- (equal? desc desc*)
- #t)))
- fragment-uniforms)))
+ (every (lambda (u1)
+ (every (lambda (u2)
+ (if (eq? (seagull-global-name u1)
+ (seagull-global-name u2))
+ (equal? (seagull-global-type-descriptor u1)
+ (seagull-global-type-descriptor u2))
+ #t))
+ fragment-uniforms))
(seagull-module-outputs vertex))))
(define (rewrite-variables exp subs)
@@ -2669,73 +2687,82 @@
(_ exp)))
(define (link-vertex-outputs-with-fragment-inputs vertex fragment)
+ (define (map-globals specs global-map)
+ (map (lambda (global)
+ (let ((name (seagull-global-name global)))
+ (cons name (assq-ref global-map name))))
+ specs))
+ (define (alpha-rename name-map)
+ (map (match-lambda
+ ((original-name . alpha-name)
+ (cons alpha-name (unique-identifier))))
+ name-map))
+ (define (remap specs global-map alpha-map)
+ (map (lambda (global)
+ (let ((name (seagull-global-name global)))
+ (cons (assq-ref alpha-map (assq-ref global-map name))
+ name)))
+ specs))
(let* ((vertex-global-map (seagull-module-global-map vertex))
- (vertex-output-map
- (map (match-lambda
- ((_ _ name)
- (cons name (assq-ref vertex-global-map name))))
- (seagull-module-outputs vertex)))
- (vertex-uniform-map
- (map (match-lambda
- ((_ _ name)
- (cons name (assq-ref vertex-global-map name))))
- (seagull-module-uniforms vertex)))
- (vertex-uniform-alpha-map
- (map (match-lambda
- ((original-name . alpha-name)
- (cons alpha-name
- (unique-identifier))))
- vertex-uniform-map))
- (vertex-output-alpha-map
- (map (match-lambda
- ((original-name . alpha-name)
- (cons alpha-name
- (unique-identifier))))
- vertex-output-map))
+ ;; Create a Scheme name -> alpha-converted GLSL name mapping
+ ;; for vertex outputs.
+ (vertex-output-map (map-globals (seagull-module-outputs vertex)
+ vertex-global-map))
+ ;; Create a Scheme name -> alpha-converted GLSL name mapping
+ ;; for vertex uniforms.
+ (vertex-uniform-map (map-globals (seagull-module-uniforms vertex)
+ vertex-global-map))
+ ;; Give new GLSL names to the vertex outputs and uniforms
+ ;; that are unique to both the vertex and fragment shaders.
+ ;; The vertex output names are changed so that the fragment
+ ;; input names can be changed to match. The vertex uniform
+ ;; names are changed so that the names do not clash with
+ ;; fragment globals.
+ (vertex-output-alpha-map (alpha-rename vertex-output-map))
+ (vertex-uniform-alpha-map (alpha-rename vertex-uniform-map))
(fragment-global-map (seagull-module-global-map fragment))
- (fragment-input-map
- (map (match-lambda
- ((_ _ name)
- (cons name (assq-ref fragment-global-map name))))
- (seagull-module-inputs fragment)))
- (fragment-uniform-map
- (map (match-lambda
- ((_ _ name)
- (cons name (assq-ref fragment-global-map name))))
- (seagull-module-uniforms fragment)))
- (fragment-uniform-alpha-map
- (map (match-lambda
- ((original-name . alpha-name)
- (cons alpha-name
- (unique-identifier))))
- fragment-uniform-map))
+ ;; Create a Scheme name -> alpha-converted GLSL name mapping
+ ;; for fragment inputs.
+ (fragment-input-map (map-globals (seagull-module-inputs fragment)
+ fragment-global-map))
+ ;; Create a Scheme name -> alpha-converted GLSL name mapping
+ ;; for fragment uniforms.
+ (fragment-uniform-map (map-globals (seagull-module-uniforms fragment)
+ fragment-global-map))
+ ;; Give new names to the fragment uniforms so that the names
+ ;; do not clash with vertex globals.
+ (fragment-uniform-alpha-map (alpha-rename fragment-uniform-map))
+ ;; This one is a little messy but what's happening is that
+ ;; the GLSL name for each fragment output is mapped to the
+ ;; respective renamed input. Vertex shader output names must
+ ;; match fragment shader input names.
(fragment-input-alpha-map
- (append (map (match-lambda
- ((_ _ name)
- (cons (assq-ref fragment-global-map
- name)
- (assq-ref vertex-output-alpha-map
- (assq-ref vertex-global-map
- name)))))
+ (append (map (lambda (input)
+ (let ((name (seagull-global-name input)))
+ (cons (assq-ref fragment-global-map
+ name)
+ (assq-ref vertex-output-alpha-map
+ (assq-ref vertex-global-map
+ name)))))
(seagull-module-inputs fragment)))))
+ ;; Rewrite the intermediate compiled forms of both shader stages
+ ;; to replace global variable names as needed.
(values (rewrite-variables (seagull-module-compiled vertex)
(append vertex-uniform-alpha-map
vertex-output-alpha-map))
(rewrite-variables (seagull-module-compiled fragment)
(append fragment-uniform-alpha-map
fragment-input-alpha-map))
- (append (map (match-lambda
- ((_ _ name)
- (cons (assq-ref vertex-uniform-alpha-map
- (assq-ref vertex-global-map name))
- name)))
- (seagull-module-uniforms vertex))
- (map (match-lambda
- ((_ _ name)
- (cons (assq-ref fragment-uniform-alpha-map
- (assq-ref fragment-global-map name))
- name)))
- (seagull-module-uniforms fragment))))))
+ ;; Generate a list of alpha-converted GLSL name -> Scheme
+ ;; name mappings. This will be given to the OpenGL shader
+ ;; constructor to map the human readable uniform names to
+ ;; the names they've been given by the compiler.
+ (append (remap (seagull-module-uniforms vertex)
+ vertex-global-map
+ vertex-uniform-alpha-map)
+ (remap (seagull-module-uniforms fragment)
+ fragment-global-map
+ fragment-uniform-alpha-map)))))
(define (seagull-module-uniform-map module)
(let ((global-map (seagull-module-global-map module)))