summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm185
1 files changed, 103 insertions, 82 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index dd1cbc6..6ff764e 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -38,8 +38,9 @@
;; - No recursion
;;
;; TODO:
-;; - Loops
+;; - Seagull unquote
;; - User defined structs
+;; - Loops
;; - Better error messages (especially around type predicate failure)
;; - Helper function modules
;; - Shader composition
@@ -219,7 +220,8 @@
(define-symbolic-type primitive
primitive-type
primitive-type?
- (name primitive-type-name))
+ (name primitive-type-name)
+ (glsl-name primitive-type-glsl-name))
(define-symbolic-type outputs
outputs-type
@@ -229,14 +231,12 @@
struct-type
struct-type?
(name struct-type-name)
+ (glsl-name struct-type-glsl-name)
(fields struct-type-fields))
(define (struct-type-ref type field)
(assq-ref (struct-type-fields type) field))
-(define-syntax-rule (define-struct-type (var-name name) (types names) ...)
- (define var-name (struct-type 'name (list (cons 'names types) ...))))
-
(define-symbolic-type array
array-type
array-type?
@@ -570,10 +570,40 @@
(values new-pred subs)
(eval-predicate* new-pred (compose-substitutions subs pred-subs))))
+;; Built-in type registry.
+(define *types* (make-hash-table))
+
+(define (lookup-type name)
+ (hashq-ref *types* name))
+
+(define (register-type! name type)
+ (hashq-set! *types* name type))
+
+(define-syntax define-primitive-type
+ (syntax-rules ()
+ ((_ var-name seagull-name)
+ (define-primitive-type var-name
+ seagull-name (symbol->string 'seagull-name)))
+ ((_ var-name seagull-name glsl-name)
+ (begin
+ (define var-name (primitive-type 'seagull-name glsl-name))
+ (register-type! 'seagull-name var-name)))))
+
+(define-syntax define-struct-type
+ (syntax-rules ()
+ ((_ (var-name seagull-name) (types names) ...)
+ (define-struct-type (var-name seagull-name (symbol->string 'seagull-name))
+ (types names) ...))
+ ((_ (var-name seagull-name glsl-name) (types names) ...)
+ (begin
+ (define var-name (struct-type 'seagull-name glsl-name
+ (list (cons 'names types) ...)))
+ (register-type! 'seagull-name var-name)))))
+
;; Built-in types:
-(define type:int (primitive-type 'int))
-(define type:float (primitive-type 'float))
-(define type:bool (primitive-type 'bool))
+(define-primitive-type type:int int)
+(define-primitive-type type:float float)
+(define-primitive-type type:bool bool)
(define-struct-type (type:vec2 vec2)
(type:float x)
(type:float y))
@@ -588,9 +618,9 @@
(type:float w))
;; TODO: Matrices are technically array types in GLSL, but we are
;; choosing to represent them opaquely for now to keep things simple.
-(define type:mat3 (primitive-type 'mat3))
-(define type:mat4 (primitive-type 'mat4))
-(define type:sampler-2d (primitive-type 'sampler2D))
+(define-primitive-type type:mat3 mat3)
+(define-primitive-type type:mat4 mat4)
+(define-primitive-type type:sampler-2d sampler-2d "sampler2D")
(define type:outputs (outputs-type))
@@ -656,31 +686,31 @@
(register-seagull-variable! (make-seagull-variable 'name args ...)))
(define-seagull-variable vertex:position
- #:glsl-name 'gl_Position
+ #:glsl-name "gl_Position"
#:type type:vec4
#:stages '(vertex)
#:qualifier 'output)
(define-seagull-variable vertex:point-size
- #:glsl-name 'gl_PointSize
+ #:glsl-name "gl_PointSize"
#:type type:float
#:stages '(vertex)
#:qualifier 'output)
(define-seagull-variable vertex:clip-distance
- #:glsl-name 'gl_ClipDistance
+ #:glsl-name "gl_ClipDistance"
#:type type:float
#:stages '(vertex)
#:qualifier 'output)
(define-seagull-variable fragment:depth
- #:glsl-name 'gl_FragDepth
+ #:glsl-name "gl_FragDepth"
#:type type:float
#:stages '(fragment)
#:qualifier 'output)
(define-seagull-variable fragment:coord
- #:glsl-name 'gl_FragCoord
+ #:glsl-name "gl_FragCoord"
#:type type:vec4
#:stages '(fragment)
#:qualifier 'input)
@@ -1138,7 +1168,7 @@
(define (unique-identifiers-for-list lst)
(map (lambda (_x) (unique-identifier)) lst))
-(define (top-level-env stage)
+(define (expand:top-level-env stage)
(fold (lambda (v env)
(let ((name (seagull-variable-name v)))
(extend-env name name env)))
@@ -1409,7 +1439,7 @@
(seagull-syntax-error "unknown form" exp expand))))
(define (expand* exp stage)
- (expand exp stage (top-level-env stage)))
+ (expand exp stage (expand:top-level-env stage)))
;;;
@@ -2010,6 +2040,18 @@
(define (type-mismatch a b origin)
(seagull-type-error "type mismatch" (list a b) origin))
+(define (type-descriptor->type desc)
+ (match desc
+ ((? symbol?)
+ (lookup-type desc))
+ (('array desc* (? exact-integer? length) (? exact-integer? rest) ...)
+ (let loop ((rest rest)
+ (prev (array-type (type-descriptor->type desc*) length)))
+ (match rest
+ (() prev)
+ ((length . rest)
+ (loop rest (array-type prev length))))))))
+
(define (apply-substitution-to-type type from to)
(cond
((or (primitive-type? type)
@@ -2314,7 +2356,7 @@
(values (reverse texps) subs pred))
((exp . rest)
(define-values (texp subs* pred*)
- (infer-exp exp env))
+ (infer exp env))
(define-values (new-pred combined-subs)
(eval-predicate* (predicate:compose pred pred*)
(compose-substitutions subs subs*)))
@@ -2326,7 +2368,7 @@
(define (infer:if predicate consequent alternate env)
;; Infer predicate types and unify it with the boolean type.
(define-values (predicate-texp predicate-subs predicate-pred)
- (infer-exp predicate env))
+ (infer predicate env))
(define predicate-unify-subs
(unify (texp-types predicate-texp) (list type:bool)))
;; Combine the substitutions and apply them to the environment.
@@ -2337,13 +2379,13 @@
;; Infer consequent and alternate types and unify them against each
;; other. Each branch of an 'if' should have the same type.
(define-values (consequent-texp consequent-subs consequent-pred)
- (infer-exp consequent env0))
+ (infer consequent env0))
(define combined-subs-1
(compose-substitutions combined-subs-0 consequent-subs))
(define env1
(apply-substitutions-to-env env0 consequent-subs))
(define-values (alternate-texp alternate-subs alternate-pred)
- (infer-exp alternate env1))
+ (infer alternate env1))
(define combined-subs-2
(compose-substitutions combined-subs-1 alternate-subs))
;; Eval combined predicate.
@@ -2371,7 +2413,7 @@
(extend-env param type env*))
env params param-types))
(define-values (body* body-subs body-pred)
- (infer-exp body env*))
+ (infer body env*))
(define-values (pred subs)
(eval-predicate* body-pred body-subs))
(values (texp (list (generalize
@@ -2437,7 +2479,7 @@
;; The type signature of primitive functions can be looked up
;; directly in the environment.
(define-values (operator* operator-subs operator-pred)
- (infer-exp operator env))
+ (infer operator env))
(define env*
(apply-substitutions-to-env env operator-subs))
;; Infer the arguments.
@@ -2472,7 +2514,7 @@
(define (infer:struct-ref exp field env)
(define-values (exp* exp-subs exp-pred)
- (infer-exp exp env))
+ (infer exp env))
(define exp-type (single-type exp*))
(define tvar (fresh-variable-type))
(define-values (pred combined-subs)
@@ -2487,11 +2529,11 @@
(define (infer:array-ref array-exp index-exp env)
(define-values (array-exp* array-exp-subs array-exp-pred)
- (infer-exp array-exp env))
+ (infer array-exp env))
(define array-type (single-type array-exp*))
(define env* (apply-substitutions-to-env env array-exp-subs))
(define-values (index-exp* index-exp-subs index-exp-pred)
- (infer-exp index-exp env*))
+ (infer index-exp env*))
(define index-type (single-type index-exp*))
(define combined-subs
(compose-substitutions array-exp-subs index-exp-subs))
@@ -2523,7 +2565,7 @@
names
exp-types))
(define-values (body* body-subs body-pred)
- (infer-exp body env*))
+ (infer body env*))
(define-values (pred combined-subs)
(eval-predicate* (predicate:compose exp-pred body-pred)
(compose-substitutions exp-subs body-subs)))
@@ -2554,7 +2596,7 @@
names
exp-types))
(define-values (body* body-subs body-pred)
- (infer-exp body env*))
+ (infer body env*))
(define-values (pred combined-subs)
(eval-predicate* (predicate:compose exp-pred body-pred)
(compose-substitutions exp-subs body-subs)))
@@ -2613,7 +2655,7 @@
(values (reverse texps) subs pred env))
((('function name exp) . rest)
(define-values (texp subs* pred*)
- (infer-exp exp env))
+ (infer exp env))
(define-values (new-pred combined-subs)
(eval-predicate* (predicate:compose pred pred*)
(compose-substitutions subs subs*)))
@@ -2646,7 +2688,7 @@
(define-values (exps exp-subs exp-pred env*)
(infer-bindings bindings '() '() predicate:succeed env))
(define-values (body* body-subs body-pred)
- (infer-exp body env*))
+ (infer body env*))
(define-values (pred combined-subs)
(eval-predicate* (predicate:compose exp-pred body-pred)
(compose-substitutions exp-subs body-subs)))
@@ -2666,7 +2708,7 @@
;; - a typed expression
;; - a list of substitutions
;; - a type predicate
-(define (infer-exp exp env)
+(define (infer exp env)
(match exp
((? constant?)
(infer:constant exp))
@@ -2698,40 +2740,21 @@
;; earlier compiler pass.
(_ (error "unknown form" exp))))
-(define (type-descriptor->type desc)
- (match desc
- ('bool type:bool)
- ('int type:int)
- ('float type:float)
- ('vec2 type:vec2)
- ('vec3 type:vec3)
- ('vec4 type:vec4)
- ('mat3 type:mat3)
- ('mat4 type:mat4)
- ('sampler-2d type:sampler-2d)
- (('array desc* (? exact-integer? length) (? exact-integer? rest) ...)
- (let loop ((rest rest)
- (prev (array-type (type-descriptor->type desc*) length)))
- (match rest
- (() prev)
- ((length . rest)
- (loop rest (array-type prev length))))))))
-
-(define (top-level-type-env stage)
- (case stage
- ((vertex)
- `((vertex:position . ,type:vec4)
- (vertex:point-size . ,type:float)
- (vertex:clip-distance . ,type:float)))
- ((fragment)
- `((fragment:depth . ,type:float)
- (fragment:coord . ,type:vec4)))))
+(define (infer:top-level-env stage)
+ (fold (lambda (v env)
+ (let ((name (seagull-variable-name v))
+ (type (seagull-variable-type v)))
+ (extend-env name type env)))
+ (empty-env)
+ (find-variables
+ (lambda (v)
+ (variable-for-stage? v stage)))))
;; TODO: Add some kind of context object that is threaded through the
;; inference process so that when a type error occurs we can show the
;; expression that caused it.
-(define (infer-types exp stage)
- (infer-exp exp (top-level-type-env stage)))
+(define (infer* exp stage)
+ (infer exp (infer:top-level-env stage)))
;;;
@@ -2838,9 +2861,9 @@
globals))
(match func
(('lambda _ body)
- (infer-exp (untype body)
- (compose-envs env
- (top-level-type-env stage)))))
+ (let ((top (infer:top-level-env stage)))
+ (infer (untype body)
+ (compose-envs env top)))))
(define subs*
(compose-substitutions subs (vars->subs func env)))
(define func*
@@ -2870,28 +2893,26 @@
(define (type-descriptor->glsl desc)
(match desc
((? symbol?)
- (match (type-descriptor->type desc)
+ (match (lookup-type desc)
((? primitive-type? primitive)
- (primitive-type-name primitive))
+ (primitive-type-glsl-name primitive))
((? struct-type? struct)
- (struct-type-name struct))))
+ (struct-type-glsl-name struct))))
(('array desc* length)
(format #f "~a[~a]"
(type-descriptor->glsl desc*)
length))))
-(define (type->type-descriptor type)
+(define (type->glsl type)
(cond
((primitive-type? type)
- (primitive-type-name type))
+ (primitive-type-glsl-name type))
((struct-type? type)
- (struct-type-name type))
+ (struct-type-glsl-name type))
((array-type? type)
- `(array ,(type->type-descriptor (array-type-ref type))
- ,(array-type-length type)))))
-
-(define (type->glsl type)
- (type-descriptor->glsl (type->type-descriptor type)))
+ (format #f "~a[~a]"
+ (type->glsl (array-type-ref type))
+ length))))
(define (single-temp temps)
(match temps
@@ -3226,7 +3247,7 @@
(let* ((simplified (simplify expanded (empty-env)))
(pruned (prune simplified))
(hoisted (hoist-functions* pruned))
- (inferred (infer-types hoisted stage))
+ (inferred (infer* hoisted stage))
(resolved (resolve-overloads inferred stage)))
(values resolved global-map (unique-identifier-counter))))))
@@ -3511,11 +3532,11 @@ Run the partial evaluator on EXP for shader STAGE."
Run type inference on EXP for shader STAGE."
(parameterize ((unique-identifier-counter 0))
(pretty-print
- (infer-types (hoist-functions*
- (prune
- (simplify*
- (expand* exp stage))))
- stage))))
+ (infer* (hoist-functions*
+ (prune
+ (simplify*
+ (expand* exp stage))))
+ stage))))
(define-meta-command ((seagull-inspect chickadee) repl module)
"seagull-inspect MODULE