Compile shader modules at macro expansion time.

1 files changed, 57 insertions, 61 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index e114140..cc1df7f 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -71,6 +71,7 @@
 ;; - Loops
 ;; - Scheme shader type -> GLSL struct translation
 ;; - Dead code elimination (error when a uniform is eliminated)
+;; - Multiple GLSL versions
 
 
 ;;;
@@ -2581,27 +2582,6 @@
   (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
                         global-map max-id)
@@ -2628,37 +2608,6 @@
 (define (seagull-module-fragment? module)
   (eq? (seagull-module-stage module) 'fragment))
 
-(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))
-          (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)))
-             (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 '())
@@ -2678,15 +2627,62 @@
          (('uniform type-desc name)
           (loop rest inputs outputs (cons spec uniforms))))))))
 
-(define-syntax-rule (define-shader-stage 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* (compile-seagull #: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 ((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)))
+        (values resolved global-map (unique-identifier-counter))))))
+
+(define (specs->globals specs)
+  (map (match-lambda
+         ((qualifier type-desc name)
+          (make-seagull-global qualifier type-desc name)))
+       specs))
+
+;; Using syntax-case allows us to compile shaders to their fully typed
+;; intermediate form at compile time, leaving only GLSL emission for
+;; runtime.
+(define-syntax define-shader-stage
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name stage ((qualifier type var) ...) source)
+       (let* ((globals (group-by-qualifier
+                        (syntax->datum
+                         #'((qualifier type var) ...))))
+              (inputs (assq-ref globals 'inputs))
+              (outputs (assq-ref globals 'outputs))
+              (uniforms (assq-ref globals 'uniforms)))
+         (define-values (compiled global-map max-id)
+           (compile-seagull #:stage (syntax->datum #'stage)
+                            #:source (syntax->datum #'source)
+                            #:inputs inputs
+                            #:outputs outputs
+                            #:uniforms uniforms))
+         (with-syntax ((inputs (datum->syntax x inputs))
+                       (outputs (datum->syntax x outputs))
+                       (uniforms (datum->syntax x uniforms))
+                       (compiled (datum->syntax x compiled))
+                       (global-map (datum->syntax x global-map))
+                       (max-id (datum->syntax x max-id)))
+           #'(define name
+               (make-seagull-module #:stage 'stage
+                                    #:inputs (specs->globals 'inputs)
+                                    #:outputs (specs->globals 'outputs)
+                                    #:uniforms (specs->globals 'uniforms)
+                                    #:source 'source
+                                    #:compiled 'compiled
+                                    #:global-map 'global-map
+                                    #:max-id max-id))))))))
 
 (define-syntax-rule (define-vertex-shader name specs source)
   (define-shader-stage name vertex specs source))