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