diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 361 |
1 files changed, 179 insertions, 182 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index ca11ec3..6b2d099 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -850,27 +850,27 @@ (define var-name (struct-type 'name (list (cons 'names types) ...)))) ;; Type variables: -(define unique-type-variable-counter (make-parameter 0)) +(define unique-variable-type-counter (make-parameter 0)) -(define (unique-type-variable-number) - (let ((n (unique-type-variable-counter))) - (unique-type-variable-counter (+ n 1)) +(define (unique-variable-type-number) + (let ((n (unique-variable-type-counter))) + (unique-variable-type-counter (+ n 1)) n)) -(define (unique-type-variable-name) +(define (unique-variable-type-name) (string->symbol - (format #f "T~a" (unique-type-variable-number)))) + (format #f "T~a" (unique-variable-type-number)))) -(define (type-variable name) +(define (variable-type name) `(tvar ,name)) -(define (fresh-type-variable) - (type-variable (unique-type-variable-name))) +(define (fresh-variable-type) + (variable-type (unique-variable-type-name))) -(define (fresh-type-variables-for-list lst) - (map (lambda (_x) (fresh-type-variable)) lst)) +(define (fresh-variable-types-for-list lst) + (map (lambda (_x) (fresh-variable-type)) lst)) -(define (type-variable? obj) +(define (variable-type? obj) (match obj (('tvar _) #t) (_ #f))) @@ -928,7 +928,7 @@ (define (type? obj) (or (primitive-type? obj) - (type-variable? obj) + (variable-type? obj) (function-type? obj) (struct-type? obj) (outputs-type? obj))) @@ -939,7 +939,7 @@ (struct-type? type) (outputs-type? type)) type) - ((type-variable? type) + ((variable-type? type) (if (equal? type from) to type)) ((function-type? type) (function-type @@ -951,11 +951,6 @@ (function-type-returns type)))) ((for-all-type? type) type) - ;; ((qualified-type? type) - ;; (qualified-type (apply-substitution-to-type - ;; (qualified-type-ref type) from to) - ;; (apply-substitution-to-predicate - ;; (qualified-type-predicate type) from to))) (else (error "invalid type" type)))) (define (apply-substitutions-to-type type subs) @@ -1038,9 +1033,9 @@ (define (occurs? a b) (cond - ((and (type-variable? a) (type-variable? b)) + ((and (variable-type? a) (variable-type? b)) (eq? a b)) - ((and (type-variable? a) (function-type? b)) + ((and (variable-type? a) (function-type? b)) (or (occurs? a (function-type-parameters b)) (occurs? a (function-type-returns b)))) ((and (type? a) (list? b)) @@ -1184,8 +1179,8 @@ ;; '=' asserts that 'a' must equal 'b'. If either is a type ;; variable, then we don't have enough information to determine ;; success or failure. - ((or ('= (? type-variable?) _) - ('= _ (? type-variable?))) + ((or ('= (? variable-type?) _) + ('= _ (? variable-type?))) (values pred '())) ;; Neither argument is a type variable, so we can get an answer. (('= a b) @@ -1324,9 +1319,11 @@ ;; carried forward in the inference process. (('substitute a b) (values #t (list (cons a b)))) - (('struct-has? struct member var) + ;; Substitute the member var when struct has been resolved to a + ;; struct type. + (('struct-has? struct member member-var) (if (struct-type? struct) - (values #t (list (cons var (struct-type-ref struct member)))) + (values #t (list (cons member-var (struct-type-ref struct member)))) (values pred '()))))) (define (eval-predicate* pred subs) @@ -1348,7 +1345,7 @@ ((or (primitive-type? type) (struct-type? type)) '()) - ((type-variable? type) (list type)) + ((variable-type? type) (list type)) ((function-type? type) (let ((params (function-type-parameters type))) (filter (lambda (t) (member t params)) @@ -1377,7 +1374,7 @@ (delete-duplicates (env-fold (lambda (_name type vars) (cond - ((type-variable? type) + ((variable-type? type) (cons (free-variables-in-type type) vars)) ((for-all-type? type) @@ -1430,7 +1427,7 @@ (define (instantiate for-all) (define subs (fold (lambda (var env) - (extend-env var (fresh-type-variable) env)) + (extend-env var (fresh-variable-type) env)) (empty-env) (for-all-type-quantifiers for-all))) (define type (for-all-type-ref for-all)) @@ -1497,8 +1494,8 @@ (unify:primitives a b)) (((? struct-type? a) (? struct-type? b)) (unify:structs a b)) - ((or ((? type-variable? a) b) - (b (? type-variable? a))) + ((or ((? variable-type? a) b) + (b (? variable-type? a))) (unify:variable a b)) (((? function-type? a) (? function-type? b)) (unify:functions a b)) @@ -1516,11 +1513,11 @@ (define (infer:immediate x) (values (texp (list (cond ((exact-integer? x) - int-type) + type:int) ((float? x) - float-type) + type:float) ((boolean? x) - bool-type))) + type:bool))) x) '() #t)) @@ -1556,7 +1553,7 @@ (define-values (predicate-texp predicate-subs predicate-pred) (infer-exp predicate env)) (define predicate-unify-subs - (unify (texp-types predicate-texp) (list bool-type))) + (unify (texp-types predicate-texp) (list type:bool))) ;; Combine the substitutions and apply them to the environment. (define combined-subs-0 (compose-substitutions predicate-subs predicate-unify-subs)) @@ -1592,7 +1589,7 @@ (define (infer:lambda params body env) ;; Each function parameter gets a fresh type variable. - (define param-types (fresh-type-variables-for-list params)) + (define param-types (fresh-variable-types-for-list params)) ;; The type environment is extended with the function parameters. (define env* (fold (lambda (param type env*) @@ -1625,7 +1622,7 @@ ;; Generate fresh type variables to unify against the return types ;; of the operator. (define return-vars - (fresh-type-variables-for-list (function-type-returns operator-type))) + (fresh-variable-types-for-list (function-type-returns operator-type))) (define call-subs (unify operator-type (function-type (map single-type args*) @@ -1660,7 +1657,7 @@ ;; of the operator. (define operator-type (single-type operator*)) (define return-vars - (fresh-type-variables-for-list + (fresh-variable-types-for-list (function-type-returns operator-type))) (define call-subs (unify (apply-substitutions-to-type operator-type combined-subs-0) @@ -1685,7 +1682,7 @@ (define-values (exp* exp-subs exp-pred) (infer-exp exp env)) (define exp-type (single-type exp*)) - (define tvar (fresh-type-variable)) + (define tvar (fresh-variable-type)) (values (texp (list tvar) `(struct-ref ,exp* ,member)) exp-subs @@ -1823,58 +1820,58 @@ (_ (error "unknown form" exp)))) ;; Built-in types: -(define int-type (primitive-type 'int)) -(define float-type (primitive-type 'float)) -(define bool-type (primitive-type 'bool)) -(define-struct-type (vec2-type vec2) - (float-type x) - (float-type y)) -(define-struct-type (vec3-type vec3) - (float-type x) - (float-type y) - (float-type z)) -(define-struct-type (vec4-type vec4) - (float-type x) - (float-type y) - (float-type z) - (float-type w)) +(define type:int (primitive-type 'int)) +(define type:float (primitive-type 'float)) +(define type:bool (primitive-type 'bool)) +(define-struct-type (type:vec2 vec2) + (type:float x) + (type:float y)) +(define-struct-type (type:vec3 vec3) + (type:float x) + (type:float y) + (type:float z)) +(define-struct-type (type:vec4 vec4) + (type:float x) + (type:float y) + (type:float z) + (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 mat3-type (primitive-type 'mat3)) -(define mat4-type (primitive-type 'mat4)) -(define sampler-2d-type (primitive-type 'sampler-2d)) +(define type:mat3 (primitive-type 'mat3)) +(define type:mat4 (primitive-type 'mat4)) +(define type:sampler-2d (primitive-type 'sampler-2d)) (define (type-name->type name) (case name - ((bool) bool-type) - ((int) int-type) - ((float) float-type) - ((vec2) vec2-type) - ((vec3) vec3-type) - ((vec4) vec4-type) - ((mat3) mat3-type) - ((mat4) mat4-type) - ((sampler-2d) sampler-2d-type))) - -(define add/sub-type - (let ((a (fresh-type-variable))) + ((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))) + +(define type:+/- + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type (function-type (list a a) (list a)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type) - (predicate:= a vec2-type) - (predicate:= a vec3-type) - (predicate:= a vec4-type) - (predicate:= a mat3-type) - (predicate:= a mat4-type))))))) + (predicate:= a type:int) + (predicate:= a type:float) + (predicate:= a type:vec2) + (predicate:= a type:vec3) + (predicate:= a type:vec4) + (predicate:= a type:mat3) + (predicate:= a type:mat4))))))) (define-syntax-rule (a+b->c (ta tb tc) ...) - (let ((a (fresh-type-variable)) - (b (fresh-type-variable)) - (c (fresh-type-variable))) + (let ((a (fresh-variable-type)) + (b (fresh-variable-type)) + (c (fresh-variable-type))) (list (for-all-type (list a b c) (qualified-type @@ -1885,148 +1882,148 @@ (predicate:substitute c tc)) ...)))))) -(define mul-type - (a+b->c (int-type int-type int-type) - (float-type float-type float-type) - (vec2-type vec2-type vec2-type) - (vec2-type float-type vec2-type) - (float-type vec2-type vec2-type) - (vec3-type vec3-type vec3-type) - (vec3-type float-type vec3-type) - (float-type vec3-type vec3-type) - (vec4-type vec4-type vec4-type) - (vec4-type float-type vec4-type) - (float-type vec4-type vec4-type) - (mat3-type mat3-type mat3-type) - (mat3-type vec3-type mat3-type) - (vec3-type mat3-type mat3-type) - (mat4-type mat4-type mat4-type) - (mat4-type vec4-type vec4-type) - (vec4-type mat4-type vec4-type))) - -(define div-type - (a+b->c (int-type int-type int-type) - (float-type float-type float-type) - (vec2-type vec2-type vec2-type) - (vec2-type float-type vec2-type) - (vec3-type vec3-type vec3-type) - (vec3-type float-type vec3-type) - (vec4-type vec4-type vec4-type) - (vec4-type float-type vec4-type) - (mat3-type float-type mat3-type) - (mat4-type float-type mat4-type))) - -(define int->float-type - (list (function-type (list int-type) (list float-type)))) - -(define float->int-type - (list (function-type (list float-type) (list int-type)))) - -(define comparison-type - (let ((a (fresh-type-variable))) +(define type:* + (a+b->c (type:int type:int type:int) + (type:float type:float type:float) + (type:vec2 type:vec2 type:vec2) + (type:vec2 type:float type:vec2) + (type:float type:vec2 type:vec2) + (type:vec3 type:vec3 type:vec3) + (type:vec3 type:float type:vec3) + (type:float type:vec3 type:vec3) + (type:vec4 type:vec4 type:vec4) + (type:vec4 type:float type:vec4) + (type:float type:vec4 type:vec4) + (type:mat3 type:mat3 type:mat3) + (type:mat3 type:vec3 type:mat3) + (type:vec3 type:mat3 type:mat3) + (type:mat4 type:mat4 type:mat4) + (type:mat4 type:vec4 type:vec4) + (type:vec4 type:mat4 type:vec4))) + +(define type:/ + (a+b->c (type:int type:int type:int) + (type:float type:float type:float) + (type:vec2 type:vec2 type:vec2) + (type:vec2 type:float type:vec2) + (type:vec3 type:vec3 type:vec3) + (type:vec3 type:float type:vec3) + (type:vec4 type:vec4 type:vec4) + (type:vec4 type:float type:vec4) + (type:mat3 type:float type:mat3) + (type:mat4 type:float type:mat4))) + +(define type:int->float + (list (function-type (list type:int) (list type:float)))) + +(define type:float->int + (list (function-type (list type:float) (list type:int)))) + +(define type:comparison + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type - (function-type (list a a) (list bool-type)) + (function-type (list a a) (list type:bool)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type))))))) + (predicate:= a type:int) + (predicate:= a type:float))))))) -(define not-type - (list (function-type (list bool-type) (list bool-type)))) +(define type:not + (list (function-type (list type:bool) (list type:bool)))) -(define make-vec2-type - (list (function-type (list float-type float-type) - (list vec2-type)))) +(define type:make-vec2 + (list (function-type (list type:float type:float) + (list type:vec2)))) -(define make-vec3-type - (list (function-type (list float-type float-type float-type) - (list vec3-type)))) +(define type:make-vec3 + (list (function-type (list type:float type:float type:float) + (list type:vec3)))) -(define make-vec4-type - (list (function-type (list float-type float-type float-type float-type) - (list vec4-type)))) +(define type:make-vec4 + (list (function-type (list type:float type:float type:float type:float) + (list type:vec4)))) -(define abs-type - (let ((a (fresh-type-variable))) +(define type:abs + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type (function-type (list a) (list a)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type))))))) + (predicate:= a type:int) + (predicate:= a type:float))))))) -(define sqrt-type - (let ((a (fresh-type-variable))) +(define type:sqrt + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type (function-type (list a) (list a)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type))))))) + (predicate:= a type:int) + (predicate:= a type:float))))))) -(define min/max-type - (let ((a (fresh-type-variable))) +(define type:min/max + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type (function-type (list a a) (list a)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type))))))) + (predicate:= a type:int) + (predicate:= a type:float))))))) -(define trigonometry-type - (list (function-type (list float-type) (list float-type)))) +(define type:trig + (list (function-type (list type:float) (list type:float)))) -(define clamp/mix-type - (let ((a (fresh-type-variable))) +(define type:clamp/mix + (let ((a (fresh-variable-type))) (list (for-all-type (list a) (qualified-type (function-type (list a a) (list a)) (predicate:or - (predicate:= a int-type) - (predicate:= a float-type))))))) + (predicate:= a type:int) + (predicate:= a type:float))))))) -(define texture-2d-ref-type - (list (function-type (list sampler-2d-type vec2-type) - (list vec4-type)))) +(define type:texture-2d + (list (function-type (list type:sampler-2d type:vec2) + (list type:vec4)))) (define (top-level-type-env stage) - `((+ . ,add/sub-type) - (- . ,add/sub-type) - (* . ,mul-type) - (/ . ,div-type) - (int->float . ,int->float-type) - (float->int . ,float->int-type) - (= . ,comparison-type) - (< . ,comparison-type) - (<= . ,comparison-type) - (> . ,comparison-type) - (>= . ,comparison-type) - (not . ,not-type) - (vec2 . ,make-vec2-type) - (vec3 . ,make-vec3-type) - (vec4 . ,make-vec4-type) - (abs . ,abs-type) - (sqrt . ,sqrt-type) - (min . ,min/max-type) - (max . ,min/max-type) - (sin . ,trigonometry-type) - (cos . ,trigonometry-type) - (tan . ,trigonometry-type) - (clamp . ,clamp/mix-type) - (mix . ,clamp/mix-type) + `((+ . ,type:+/-) + (- . ,type:+/-) + (* . ,type:*) + (/ . ,type:/) + (int->float . ,type:int->float) + (float->int . ,type:float->int) + (= . ,type:comparison) + (< . ,type:comparison) + (<= . ,type:comparison) + (> . ,type:comparison) + (>= . ,type:comparison) + (not . ,type:not) + (vec2 . ,type:make-vec2) + (vec3 . ,type:make-vec3) + (vec4 . ,type:make-vec4) + (abs . ,type:abs) + (sqrt . ,type:sqrt) + (min . ,type:min/max) + (max . ,type:min/max) + (sin . ,type:trig) + (cos . ,type:trig) + (tan . ,type:trig) + (clamp . ,type:clamp/mix) + (mix . ,type:clamp/mix) ,@(case stage ((vertex) - `((vertex:position ,vec4-type) - (vertex:point-size ,float-type) - (vertex:clip-distance ,float-type))) + `((vertex:position ,type:vec4) + (vertex:point-size ,type:float) + (vertex:clip-distance ,type:float))) ((fragment) - `((fragment:depth ,float-type) - (texture-2d . ,texture-2d-ref-type)))))) + `((fragment:depth ,type:float) + (texture-2d . ,type:texture-2d)))))) ;; 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 @@ -2403,7 +2400,7 @@ (version '330) (port (current-output-port))) (parameterize ((unique-identifier-counter 0) - (unique-type-variable-counter 0)) + (unique-variable-type-counter 0)) (let* ((expanded (expand exp stage (top-level-env))) (propagated (propagate-constants expanded (empty-env))) (hoisted (hoist-functions* propagated)) |