summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm157
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))