diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 157 |
1 files changed, 125 insertions, 32 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 7a22355..d03de86 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -109,15 +109,6 @@ (define (top-level-qualifier? x) (memq x '(in out uniform))) -(define (built-in-output? name stage) - (case stage - ((vertex) - ;; GL 4+ has more built-ins, but we are supporting GL 2+ so we - ;; can't use them easily. - (memq name '(vertex:position vertex:point-size vertex:clip-distance))) - ((fragment) - (memq name '(vertex:frag-depth))))) - ;;; ;;; Lexical environments @@ -189,13 +180,6 @@ (proc name exp))) env)) -(define (top-level-env stage) - (case stage - ((vertex) - (empty-env)) - ((fragment) - '((fragment:coord . fragment:coord))))) - ;;; ;;; Types @@ -431,6 +415,98 @@ ;;; +;;; Built-in variables +;;; + +(define-record-type <seagull-variable> + (%make-seagull-variable name glsl-name type stages qualifier) + seagull-variable? + (name seagull-variable-name) + (glsl-name seagull-variable-glsl-name) + (type seagull-variable-type) + (stages seagull-variable-stages) + (qualifier seagull-variable-qualifier)) + +(define* (make-seagull-variable name #:key glsl-name type stages qualifier) + (%make-seagull-variable name glsl-name type stages qualifier)) + +(define (output-variable? variable) + (eq? (seagull-variable-qualifier variable) 'output)) + +(define (input-variable? variable) + (eq? (seagull-variable-qualifier variable) 'input)) + +(define (variable-for-stage? variable stage) + (memq stage (seagull-variable-stages variable))) + +(define *seagull-variables* (make-hash-table)) + +(define (register-seagull-variable! variable) + (hashq-set! *seagull-variables* + (seagull-variable-name variable) + variable)) + +(define (find-variables pred) + (hash-fold (lambda (k v memo) + (if (pred v) + (cons v memo) + memo)) + '() + *seagull-variables*)) + +(define (lookup-output-variable name) + (let ((variable (hashq-ref *seagull-variables* name))) + (and (seagull-variable? variable) + (output-variable? variable) + variable))) + +(define (lookup-output-variable-for-stage name stage) + (let ((variable (lookup-output-variable name))) + (and (seagull-variable? variable) + (variable-for-stage? variable stage) + variable))) + +(define (lookup-input-variable name) + (let ((variable (hashq-ref *seagull-variables* name))) + (and (seagull-variable? variable) + (input-variable? variable) + variable))) + +(define-syntax-rule (define-seagull-variable name args ...) + (register-seagull-variable! (make-seagull-variable 'name args ...))) + +(define-seagull-variable vertex:position + #:glsl-name 'gl_Position + #:type type:vec4 + #:stages '(vertex) + #:qualifier 'output) + +(define-seagull-variable vertex:point-size + #:glsl-name 'gl_PointSize + #:type type:float + #:stages '(vertex) + #:qualifier 'output) + +(define-seagull-variable vertex:clip-distance + #:glsl-name 'gl_ClipDistance + #:type type:float + #:stages '(vertex) + #:qualifier 'output) + +(define-seagull-variable fragment:depth + #:glsl-name 'gl_FragDepth + #:type type:float + #:stages '(fragment) + #:qualifier 'output) + +(define-seagull-variable fragment:coord + #:glsl-name 'gl_FragCoord + #:type type:vec4 + #:stages '(fragment) + #:qualifier 'input) + + +;;; ;;; Primitives ;;; @@ -826,6 +902,16 @@ (define (unique-identifiers-for-list lst) (map (lambda (_x) (unique-identifier)) lst)) +(define (top-level-env stage) + (fold (lambda (v env) + (let ((name (seagull-variable-name v))) + (extend-env name name env))) + (empty-env) + (find-variables + (lambda (v) + (and (input-variable? v) + (variable-for-stage? v stage)))))) + (define (alpha-convert names) (define names* (map (lambda (_name) (unique-identifier)) names)) (fold extend-env (empty-env) names names*)) @@ -1016,10 +1102,13 @@ (define (expand:outputs names exps stage env) `(outputs ,@(map (lambda (name exp) - (list (if (built-in-output? name stage) - name - (lookup name env)) - (expand exp stage env))) + (let ((variable (lookup-output-variable-for-stage name stage))) + (list (if (seagull-variable? variable) + (seagull-variable-name variable) + ;; TODO: Check that the variable is an output + ;; variable. + (lookup name env)) + (expand exp stage env)))) names exps))) (define (expand:discard stage env) @@ -1083,6 +1172,9 @@ (_ (seagull-syntax-error "unknown form" exp expand)))) +(define (expand* exp stage) + (expand exp stage (top-level-env stage))) + ;;; ;;; Constant propagation and folding @@ -2989,15 +3081,13 @@ (emit-glsl body stage version port (+ level 1)) (display "}\n" port)) -(define %built-in-output-map - '((vertex:position . gl_Position) - (vertex:point-size . gl_PointSize) - (vertex:clip-distance . gl_ClipDistance) - (fragment:depth . gl_FragDepth))) +(define (glsl-output-name name) + (let ((variable (lookup-output-variable name))) + (if (seagull-variable? variable) + (seagull-variable-glsl-name variable) + name))) (define (emit:outputs names exps stage version port level) - (define (output-name name) - (or (assq-ref %built-in-output-map name) name)) (if (and (eq? stage 'fragment) (null? names)) (begin (indent level port) @@ -3007,13 +3097,16 @@ ((temp) (indent level port) (format port "~a = ~a;\n" - (output-name name) + (glsl-output-name name) temp)))) names exps)) '(#f)) -(define %built-in-input-map - '((fragment:coord . gl_FragCoord))) +(define (glsl-input-name name) + (let ((variable (lookup-input-variable name))) + (if (seagull-variable? variable) + (seagull-variable-glsl-name variable) + name))) (define* (emit-glsl exp stage version port #:optional (level 0)) (match exp @@ -3024,7 +3117,7 @@ (('t _ (? boolean? b)) (emit:boolean b stage version port level)) (('t _ (? symbol? var)) - (list (or (assq-ref %built-in-input-map var) var))) + (list (glsl-input-name var))) (('t _ ('if predicate consequent alternate)) (emit:if predicate consequent alternate stage version port level)) (('t _ ('values exps ...)) @@ -3111,7 +3204,7 @@ (let ((source* `(top-level ,(append inputs outputs uniforms) ,body))) (define-values (expanded global-map) - (expand source* stage (top-level-env stage))) + (expand* source* stage)) (let* ((simplified (simplify-exp expanded (empty-env))) (pruned (prune simplified)) (hoisted (hoist-functions* pruned)) |