Messy but working shader linker.

1 files changed, 271 insertions, 20 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index a1adb1d..ec600ba 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -43,8 +43,22 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
-  #:export (compile-seagull))
+  #:export (compile-seagull-module
+            define-vertex-shader
+            define-fragment-shader
+            seagull-module?
+            seagull-module-vertex?
+            seagull-module-fragment?
+            seagull-module-stage
+            seagull-module-inputs
+            seagull-module-outputs
+            seagull-module-uniforms
+            seagull-module-source
+            seagull-module-compiled
+            seagull-module-global-map
+            link-seagull-modules))
 
 ;; The Seagull compiler is designed as a series of source-to-source
 ;; program transformations in which each transformation pass results
@@ -52,7 +66,6 @@
 ;; GLSL code.
 
 ;; TODO:
-;; - Array types
 ;; - Loops
 ;; - Shader stage linking
 ;; - Input/uniform mapping for invoking shaders from Scheme
@@ -419,12 +432,14 @@
   `(call ,(expand operator stage env) ,@(expand:list operands stage env)))
 
 (define (expand:top-level qualifiers types names body stage env)
-  (let* ((env* (compose-envs (alpha-convert names) env)))
+  (let* ((global-map (alpha-convert names))
+         (env* (compose-envs global-map env)))
     ;; TODO: Support interpolation qualifiers.
-    `(top-level ,(map (lambda (qualifier type name)
-                        (list qualifier type (lookup name env*)))
-                      qualifiers types names)
-                ,(expand body stage env*))))
+    (values `(top-level ,(map (lambda (qualifier type name)
+                                (list qualifier type (lookup name env*)))
+                              qualifiers types names)
+                        ,(expand body stage env*))
+            global-map)))
 
 (define (expand:outputs names exps stage env)
   `(outputs
@@ -2151,6 +2166,13 @@
                           (list (cons struct-var struct)
                                 (cons field-var field-type)))))
                  structs))
+    (('struct-field struct-var field field-var)
+     (filter-map (lambda (struct)
+                   (let ((field-type (struct-type-ref struct field)))
+                     (and field-type
+                          (list (cons struct-var struct)
+                                (cons field-var field-type)))))
+                 structs))
     (('or preds ...)
      (concatenate (map (lambda (pred)
                          (possible-substitutions pred structs))
@@ -2220,7 +2242,11 @@
 (define (type-descriptor->glsl desc)
   (match desc
     ((? symbol?)
-     desc)
+     (match (type-descriptor->type desc)
+       ((? primitive-type? primitive)
+        (primitive-type-name primitive))
+       ((? struct-type? struct)
+        (struct-type-name struct))))
     (('array desc* length)
      (format #f "~a[~a]"
              (type-descriptor->glsl desc*)
@@ -2507,17 +2533,242 @@
 ;; Combine all of the compiler passes on a user provided program and
 ;; emit GLSL code if the program is valid.
 
-(use-modules (ice-9 pretty-print))
-
-(define* (compile-seagull exp #:key (stage 'vertex)
-                          (version '330)
-                          (port (current-output-port)))
+(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-module>
+  (%make-seagull-module stage inputs outputs uniforms source compiled
+                        global-map max-id)
+  seagull-module?
+  (stage seagull-module-stage)
+  (inputs seagull-module-inputs)
+  (outputs seagull-module-outputs)
+  (uniforms seagull-module-uniforms)
+  (source seagull-module-source)
+  (compiled seagull-module-compiled)
+  ;; Original name -> alpha converted name mapping for inputs,
+  ;; outputs, and uniforms.
+  (global-map seagull-module-global-map)
+  (max-id seagull-module-max-id))
+
+(define* (make-seagull-module #:key stage inputs outputs uniforms source
+                              compiled global-map max-id)
+  (%make-seagull-module stage inputs outputs uniforms source compiled
+                        global-map max-id))
+
+(define (seagull-module-vertex? module)
+  (eq? (seagull-module-stage module) 'vertex))
+
+(define (seagull-module-fragment? module)
+  (eq? (seagull-module-stage module) 'fragment))
+
+(define* (compile-seagull-module #:key stage source
+                                 (inputs '()) (outputs '()) (uniforms '()))
+  (unless (memq stage '(vertex fragment))
+    (error "invalid shader stage" stage))
   (parameterize ((unique-identifier-counter 0)
                  (unique-variable-type-counter 0))
-    (let* ((expanded (expand exp stage (top-level-env)))
-           (propagated (propagate-constants expanded (empty-env)))
-           (hoisted (hoist-functions* propagated))
-           (inferred (infer-types hoisted stage))
-           (resolved (resolve-overloads inferred)))
-      (pretty-print resolved)
-      (emit-glsl resolved version port))))
+    (let ((source* `(top-level ,(append inputs outputs uniforms)
+                               ,source)))
+      (define-values (expanded global-map)
+        (expand source* stage (top-level-env)))
+      (let* ((propagated (propagate-constants expanded (empty-env)))
+             (hoisted (hoist-functions* propagated))
+             (inferred (infer-types hoisted stage))
+             (resolved (resolve-overloads inferred)))
+        (make-seagull-module #:stage stage
+                             #:inputs inputs
+                             #:outputs outputs
+                             #:uniforms uniforms
+                             #:source source
+                             #:compiled resolved
+                             #:global-map global-map
+                             #:max-id (unique-identifier-counter))))))
+
+(define (group-by-qualifier specs)
+  (let loop ((specs specs)
+             (inputs '())
+             (outputs '())
+             (uniforms '()))
+    (match specs
+      (()
+       `((inputs . ,(reverse inputs))
+         (outputs . ,(reverse outputs))
+         (uniforms . ,(reverse uniforms))))
+      ((spec . rest)
+       (match spec
+         (('in _ _)
+          (loop rest (cons spec inputs) outputs uniforms))
+         (('out _ _)
+          (loop rest inputs (cons spec outputs) uniforms))
+         (('uniform _ _)
+          (loop rest inputs outputs (cons spec uniforms))))))))
+
+(define-syntax-rule (define-shader name stage ((qualifier type var) ...) source)
+  (define name
+    (let ((top-level-defs (group-by-qualifier
+                           (list (list 'qualifier 'type 'var) ...))))
+      (compile-seagull-module #:stage 'stage
+                              #:source 'source
+                              #:inputs (assq-ref top-level-defs 'inputs)
+                              #:outputs (assq-ref top-level-defs 'outputs)
+                              #:uniforms (assq-ref top-level-defs 'uniforms)))))
+
+(define-syntax-rule (define-vertex-shader name specs source)
+  (define-shader name vertex specs source))
+
+(define-syntax-rule (define-fragment-shader name specs source)
+  (define-shader name fragment specs source))
+
+(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)))
+           (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)))
+           (seagull-module-outputs vertex))))
+
+(define (rewrite-variables exp subs)
+  (match exp
+    ((? symbol?)
+     (or (assq-ref subs exp) exp))
+    (() '())
+    ((exp* . rest)
+     (cons (rewrite-variables exp* subs)
+           (rewrite-variables rest subs)))
+    (_ exp)))
+
+(define (link-vertex-outputs-with-fragment-inputs vertex fragment)
+  (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))
+         (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))
+         (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)))))
+                       (seagull-module-inputs fragment)))))
+    (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))))))
+
+(define (seagull-module-uniform-map module)
+  (let ((global-map (seagull-module-global-map module)))
+    (map (match-lambda
+           ((_ _ name)
+            (cons (assq-ref global-map name) name)))
+         (seagull-module-uniforms module))))
+
+(define* (link-seagull-modules vertex fragment #:key
+                               (version '330))
+  (unless (seagull-module-vertex? vertex)
+    (error "not a vertex shader" vertex))
+  (unless (seagull-module-fragment? fragment)
+    (error "not a fragment shader" fragment))
+  (parameterize ((unique-identifier-counter
+                  (max (seagull-module-max-id vertex)
+                       (seagull-module-max-id fragment))))
+    (unless (vertex-outputs-match-fragment-inputs? vertex fragment)
+      (error "vertex outputs do not match fragment inputs"))
+    (unless (uniforms-compatible? vertex fragment)
+      (error "vertex uniforms clash with fragment uniforms"))
+    (define-values (vertex* fragment* uniform-map)
+      (link-vertex-outputs-with-fragment-inputs vertex fragment))
+    (define vertex-glsl
+      (call-with-output-string
+        (lambda (port)
+          (emit-glsl vertex* version port))))
+    (define fragment-glsl
+      (call-with-output-string
+        (lambda (port)
+          (emit-glsl fragment* version port))))
+    (display vertex-glsl)
+    (newline)
+    (display fragment-glsl)
+    (newline)
+    (values vertex-glsl fragment-glsl uniform-map)))