diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 397 |
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)))) |