diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 118 |
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)) |