Improve shader linking phase.

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)))