summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm397
1 files changed, 190 insertions, 207 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index dcddfb9..2f7cf69 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -123,9 +123,9 @@
((vertex)
;; GL 4+ has more built-ins, but we are supporting GL 2+ so we
;; can't use them easily.
- (memq name '(gl-position gl-point-size gl-clip-distance)))
+ (memq name '(vertex:position vertex:point-size vertex:clip-distance)))
((fragment)
- (memq name '(gl-frag-depth gl-sample-mask)))))
+ (memq name '(vertex:frag-depth)))))
;;;
@@ -1069,177 +1069,6 @@
a))
(append a* b*))
-;; (define add/sub-type
-;; (list (overload-type
-;; (function-type (list int-type int-type)
-;; (list int-type))
-;; (function-type (list float-type float-type)
-;; (list float-type))
-;; (function-type (list vec2-type vec2-type)
-;; (list vec2-type))
-;; (function-type (list vec3-type vec3-type)
-;; (list vec3-type))
-;; (function-type (list vec4-type vec4-type)
-;; (list vec4-type))
-;; (function-type (list mat3-type mat3-type)
-;; (list mat3-type))
-;; (function-type (list mat4-type mat4-type)
-;; (list mat4-type)))))
-
-;; (define mul-type
-;; (list (overload-type
-;; (function-type (list int-type int-type)
-;; (list int-type))
-;; (function-type (list float-type float-type)
-;; (list float-type))
-;; (function-type (list vec2-type vec2-type)
-;; (list vec2-type))
-;; (function-type (list vec2-type float-type)
-;; (list vec2-type))
-;; (function-type (list float-type vec2-type)
-;; (list vec2-type))
-;; (function-type (list vec3-type vec3-type)
-;; (list vec3-type))
-;; (function-type (list vec3-type float-type)
-;; (list vec3-type))
-;; (function-type (list float-type vec3-type)
-;; (list vec3-type))
-;; (function-type (list vec4-type vec4-type)
-;; (list vec4-type))
-;; (function-type (list vec4-type float-type)
-;; (list vec4-type))
-;; (function-type (list float-type vec4-type)
-;; (list vec4-type))
-;; (function-type (list mat3-type mat3-type)
-;; (list mat3-type))
-;; (function-type (list mat3-type vec3-type)
-;; (list mat3-type))
-;; (function-type (list vec3-type mat3-type)
-;; (list mat3-type))
-;; (function-type (list mat4-type mat4-type)
-;; (list mat4-type))
-;; (function-type (list mat4-type vec4-type)
-;; (list vec4-type))
-;; (function-type (list vec4-type mat4-type)
-;; (list vec4-type)))))
-
-;; (define div-type
-;; (list (overload-type
-;; (function-type (list int-type int-type)
-;; (list int-type))
-;; (function-type (list float-type float-type)
-;; (list float-type))
-;; (function-type (list vec2-type vec2-type)
-;; (list vec2-type))
-;; (function-type (list vec2-type float-type)
-;; (list vec2-type))
-;; (function-type (list vec3-type vec3-type)
-;; (list vec3-type))
-;; (function-type (list vec3-type float-type)
-;; (list vec3-type))
-;; (function-type (list vec4-type vec4-type)
-;; (list vec4-type))
-;; (function-type (list vec4-type float-type)
-;; (list vec4-type))
-;; (function-type (list mat3-type float-type)
-;; (list mat3-type))
-;; (function-type (list mat4-type float-type)
-;; (list mat4-type)))))
-
-;; (define comparison-type
-;; (list (overload-type
-;; (function-type (list int-type int-type)
-;; (list bool-type))
-;; (function-type (list float-type float-type)
-;; (list bool-type)))))
-
-;; (define make-vec2-type
-;; (list (function-type (list float-type float-type)
-;; (list vec2-type))))
-
-;; (define make-vec3-type
-;; (list (overload-type
-;; (function-type (list float-type float-type float-type)
-;; (list vec3-type))
-;; (function-type (list vec2-type float-type)
-;; (list vec3-type))
-;; (function-type (list float-type vec2-type)
-;; (list vec3-type)))))
-
-;; (define make-vec4-type
-;; (list (overload-type
-;; (function-type (list float-type float-type float-type float-type)
-;; (list vec4-type))
-;; (function-type (list vec2-type float-type float-type)
-;; (list vec4-type))
-;; (function-type (list float-type vec2-type float-type)
-;; (list vec4-type))
-;; (function-type (list float-type float-type vec2-type)
-;; (list vec4-type))
-;; (function-type (list vec3-type float-type)
-;; (list vec4-type))
-;; (function-type (list float-type vec3-type)
-;; (list vec4-type)))))
-
-;; (define abs-type
-;; (list (overload-type
-;; (function-type (list int-type) (list int-type))
-;; (function-type (list float-type) (list float-type)))))
-
-;; (define sqrt-type
-;; (list (overload-type
-;; (function-type (list int-type) (list int-type))
-;; (function-type (list float-type) (list float-type)))))
-
-;; (define min/max-type
-;; (list (overload-type
-;; (function-type (list int-type int-type) (list int-type))
-;; (function-type (list float-type float-type) (list float-type)))))
-
-;; (define trigonometry-type
-;; (list (function-type (list float-type) (list float-type))))
-
-;; (define clamp/mix-type
-;; (list (overload-type
-;; (function-type (list int-type int-type int-type)
-;; (list int-type))
-;; (function-type (list float-type float-type float-type)
-;; (list float-type)))))
-
-(define (top-level-type-env stage)
- '()
- ;; `((+ . ,add/sub-type)
- ;; (- . ,add/sub-type)
- ;; (* . ,mul-type)
- ;; (/ . ,div-type)
- ;; (= . ,comparison-type)
- ;; (< . ,comparison-type)
- ;; (<= . ,comparison-type)
- ;; (> . ,comparison-type)
- ;; (>= . ,comparison-type)
- ;; (vec2 . ,make-vec2-type)
- ;; (vec3 . ,make-vec3-type)
- ;; (vec4 . ,make-vec4-type)
- ;; (not ,(function-type (list bool-type) (list bool-type)))
- ;; (int->float ,(function-type (list int-type) (list float-type)))
- ;; (float->int ,(function-type (list float-type) (list int-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)
- ;; ,@(case stage
- ;; ((vertex)
- ;; `((gl-position ,vec4-type)))
- ;; ((fragment)
- ;; `((texture-2d ,(function-type (list sampler-2d-type vec2-type)
- ;; (list vec4-type)))))))
- )
-
(define (lookup-type name env)
(let ((type (lookup name env)))
(if (for-all-type? type)
@@ -1282,6 +1111,9 @@
(cons pred (loop rest))))))
`(list ,@preds*))
+(define (predicate:= a b)
+ `(= ,a ,b))
+
(define (predicate:substitute from to)
`(substitute ,from ,to))
@@ -1309,9 +1141,6 @@
#t
preds))
-(define (compose-predicates-for-types types)
- (compose-predicates* (map predicate-for-type types)))
-
;; Produces a simplified predicate and a new set of substitutions for
;; predicates that have been satisfied and simplified to #t. It's a
;; bit of a weird process since we're dealing with partial evaluation,
@@ -1828,10 +1657,19 @@
(define (infer:outputs names exps env)
(define-values (exps* exp-subs exp-pred)
(infer:list exps env))
+ (define exp-types (map texp-types exps*))
+ (define unify-subs
+ (unify (map texp-types exps*)
+ (map (lambda (name)
+ (lookup name env))
+ names)))
+ ;; Eval predicate.
+ (define-values (pred combined-subs)
+ (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs)))
(values (texp (map single-type exps*)
`(outputs ,@(map list names exps*)))
- exp-subs
- exp-pred))
+ combined-subs
+ pred))
(define (infer:top-level bindings body env)
(define (infer-bindings bindings texps subs pred)
@@ -1861,7 +1699,7 @@
bindings))
(define type-names
(map (match-lambda
- (((or 'in 'out) type-name _) type-name)
+ (((? top-level-qualifier?) type-name _) type-name)
(_ #f))
bindings))
(define-values (exps exp-subs exp-pred)
@@ -1884,7 +1722,7 @@
(compose-substitutions exp-subs body-subs)))
(define bindings*
(map (match-lambda*
- (((and (or 'in 'out) qualifier) type-name name _)
+ (((? top-level-qualifier? qualifier) type-name name _)
(list qualifier type-name name))
(('function _ name exp)
`(function ,name ,exp)))
@@ -1922,30 +1760,176 @@
(infer:top-level bindings body env))
(_ (error "unknown form" exp))))
-(define (make-test-env)
- (extend-env
- '+
- (list (let ((a (fresh-type-variable))
- (b (fresh-type-variable))
- (c (fresh-type-variable)))
- (for-all-type
- (list a b c)
- (function-type (list a b) (list c))
- `(or (and (= ,a ,int-type)
- (= ,b ,int-type)
- (substitute ,c ,a))
-
- (and (= ,a ,float-type)
- (= ,b ,float-type)
- (substitute ,c ,a))
- ))))
- (empty-env)))
+(define add/sub-type
+ (let ((a (fresh-type-variable)))
+ (list (for-all-type
+ (list a)
+ (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))))))
+
+(define-syntax-rule (a+b->c (ta tb tc) ...)
+ (let ((a (fresh-type-variable))
+ (b (fresh-type-variable))
+ (c (fresh-type-variable)))
+ (list (for-all-type
+ (list a b c)
+ (function-type (list a b) (list c))
+ (predicate:or
+ (predicate:and (predicate:= a ta)
+ (predicate:= b tb)
+ (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 float-type mat3-type)
+ (float-type mat3-type mat3-type)
+ (mat4-type mat4-type mat4-type)
+ (mat4-type float-type mat4-type)
+ (float-type mat4-type mat4-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)))
+ (list (for-all-type
+ (list a)
+ (function-type (list a a) (list bool-type))
+ (predicate:or
+ (predicate:= a int-type)
+ (predicate:= a float-type))))))
+
+(define not-type
+ (list (function-type (list bool-type) (list bool-type))))
+
+(define make-vec2-type
+ (list (function-type (list float-type float-type)
+ (list vec2-type))))
+
+(define make-vec3-type
+ (list (function-type (list float-type float-type float-type)
+ (list vec3-type))))
+
+(define make-vec4-type
+ (list (function-type (list float-type float-type float-type float-type)
+ (list vec4-type))))
+
+(define abs-type
+ (let ((a (fresh-type-variable)))
+ (list (for-all-type
+ (list a)
+ (function-type (list a) (list a))
+ (predicate:or
+ (predicate:= a int-type)
+ (predicate:= a float-type))))))
+
+(define sqrt-type
+ (let ((a (fresh-type-variable)))
+ (list (for-all-type
+ (list a)
+ (function-type (list a) (list a))
+ (predicate:or
+ (predicate:= a int-type)
+ (predicate:= a float-type))))))
+
+(define min/max-type
+ (let ((a (fresh-type-variable)))
+ (list (for-all-type
+ (list a)
+ (function-type (list a a) (list a))
+ (predicate:or
+ (predicate:= a int-type)
+ (predicate:= a float-type))))))
+
+(define trigonometry-type
+ (list (function-type (list float-type) (list float-type))))
+
+(define clamp/mix-type
+ (let ((a (fresh-type-variable)))
+ (list (for-all-type
+ (list a)
+ (function-type (list a a) (list a))
+ (predicate:or
+ (predicate:= a int-type)
+ (predicate:= a float-type))))))
+
+(define texture-2d-ref-type
+ (list (function-type (list sampler-2d-type vec2-type)
+ (list vec4-type))))
+
+(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)
+ ,@(case stage
+ ((vertex)
+ `((vertex:position ,vec4-type)
+ (vertex:point-size ,float-type)
+ (vertex:clip-distance ,float-type)))
+ ((fragment)
+ `((fragment:depth ,float-type)
+ (texture-2d . ,texture-2d-ref-type))))))
;; 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 (make-test-env)))
+ (infer-exp exp (top-level-type-env stage)))
;;;
@@ -2006,7 +1990,8 @@
(define func*
(apply-substitutions-to-exp func subs))
`(function ,name (t (,type*) ,func*)))
- (possible-substitutions (for-all-type-predicate type)))
+ (delete-duplicates
+ (possible-substitutions (for-all-type-predicate type))))
(loop rest)))
((binding . rest)
(cons binding (loop rest))))))
@@ -2212,11 +2197,10 @@
(display "}\n" port))
(define %built-in-output-map
- '((gl-position . gl_Position)
- (gl-point-size . gl_PointSize)
- (gl-clip-distance . gl_ClipDistance)
- (gl-frag-depth . gl_FragDepth)
- (gl-sample-mask . gl_SampleMask)))
+ '((vertex:position . gl_Position)
+ (vertex:point-size . gl_PointSize)
+ (vertex:clip-distance . gl_ClipDistance)
+ (fragment:depth . gl_FragDepth)))
(define (emit:outputs names exps version port level)
(define (output-name name)
@@ -2226,7 +2210,7 @@
((temp)
(indent level port)
(format port "~a = ~a;\n"
- (output-name (texp-exp name))
+ (output-name name)
temp))))
names exps))
@@ -2279,6 +2263,5 @@
(hoisted (hoist-functions* propagated))
(inferred (infer-types hoisted stage))
(resolved (resolve-overloads inferred)))
- (pretty-print inferred)
(pretty-print resolved)
(emit-glsl resolved version port))))