From 5176e002c6cac030828713d4111b7571446c074d Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 23 Jan 2023 09:03:06 -0500 Subject: top-level inputs/uniforms. --- chickadee/graphics/seagull.scm | 90 +++++++++++++++++++++++++++++++++++------- 1 file changed, 75 insertions(+), 15 deletions(-) diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 9beb310..515101e 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -79,6 +79,9 @@ (or (binary-operator? x) (vector-constructor? x))) +(define (input-qualifier? x) + (memq x '(in uniform))) + (define (difference a b) (match a (() b) @@ -279,6 +282,13 @@ (define (expand:call operator operands env) `(call ,(expand operator env) ,@(expand:list operands env))) +(define (expand:top-level qualifiers types names body env) + (let* ((env* (compose-envs (alpha-convert names) env))) + `(top-level ,(map (lambda (qualifier type name) + (list qualifier type (lookup name env*))) + qualifiers types names) + ,(expand body env*)))) + (define &seagull-syntax-error (make-exception-type '&seagull-syntax-error &error '(form))) @@ -305,6 +315,9 @@ (expand:lambda params body env)) (('values exps ...) (expand:values exps env)) + (('top-level (((? input-qualifier? qualifiers) types names) ...) + body) + (expand:top-level qualifiers types names body env)) ;; Macros: (('let* (bindings ...) body) (expand:let* bindings body env)) @@ -414,6 +427,10 @@ (op* x* y*)) `(primcall ,op ,x* ,y*))) +(define (propagate:top-level inputs body env) + `(top-level ,inputs + ,(propagate-constants body env))) + (define (propagate-constants exp env) (match exp ((? immediate?) exp) @@ -432,7 +449,9 @@ (('primcall operator args ...) (propagate:primcall operator args env)) (('call operator args ...) - (propagate:call operator args env)))) + (propagate:call operator args env)) + (('top-level inputs body) + (propagate:top-level inputs body env)))) ;;; @@ -489,7 +508,10 @@ (check-free-variables-in-list exps bound-vars top-level-vars)) ((or ('primcall _ args ...) ('call args ...)) - (check-free-variables-in-list args bound-vars top-level-vars)))) + (check-free-variables-in-list args bound-vars top-level-vars)) + (('top-level ((_ _ names) ...) body) + (define bound-vars* (append names bound-vars)) + (check-free-variables body bound-vars* top-level-vars)))) (define (hoist:list exps) (let-values (((exp-list env-list) @@ -542,6 +564,12 @@ (values `(call ,@args*) args-env)) +(define (hoist:top-level inputs body) + (define-values (body* body-env) + (hoist-functions body)) + (values `(top-level ,inputs ,body*) + body-env)) + (define (hoist-functions exp) (match exp ((or (? immediate?) ('var _ _)) @@ -557,7 +585,16 @@ (('primcall operator args ...) (hoist:primcall operator args)) (('call args ...) - (hoist:call args)))) + (hoist:call args)) + (('top-level inputs body) + (hoist:top-level inputs body)))) + +(define (maybe-merge-top-levels new-bindings exp) + (match exp + (('top-level bindings body) + `(top-level ,(append bindings new-bindings) ,body)) + (_ + `(top-level ,new-bindings ,exp)))) (define (hoist-functions* exp) (define-values (exp* env) @@ -567,8 +604,11 @@ (env-for-each (lambda (name exp) (check-free-variables exp '() top-level-vars)) env) - `(top-level ,(reverse (env-map list env)) - ,exp*)) + (define bindings + (env-map (lambda (name func) + `(function ,name ,func)) + env)) + (maybe-merge-top-levels bindings exp*)) ;;; @@ -581,7 +621,7 @@ ;;; -;;; Type inference: Typed expressions +;;; Typed expressions ;;; ;; Transform all program expressions into typed expressions by @@ -614,6 +654,17 @@ (define mat3-type (primitive-type 'mat3)) (define mat4-type (primitive-type 'mat4)) +(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))) + ;; Type variables: (define unique-type-variable-counter (make-parameter 0)) @@ -851,14 +902,12 @@ (else (error "invalid type" type)))) (define (apply-substitutions-to-type type subs) - (pk 'sub-type type subs) (env-fold (lambda (from to type*) (apply-substitution-to-type type* from to)) type subs)) (define (apply-substitutions-to-types types subs) - (pk 'sub-types types subs) (map (lambda (type) (apply-substitutions-to-type type subs)) types)) @@ -1008,8 +1057,8 @@ (match bindings (() (let ((body* (annotate-exp body env))) - (texp (texp-types body*) `(top-level ,result ,body*)))) - (((name exp) . rest) + (texp (texp-types body*) `(top-level ,(reverse result) ,body*)))) + ((('function name exp) . rest) (define exp* (let ((x (annotate-exp exp env))) ;; Function types must be generalized so that functions like @@ -1017,7 +1066,11 @@ (texp (list (generalize (single-type x) env)) (texp-exp x)))) (define env* (extend-env name (single-type exp*) env)) - (define result* (cons (list name exp*) result)) + (define result* (cons `(function ,name ,exp*) result)) + (annotate:top-level rest body env* result*)) + ((((? input-qualifier? qualifier) type-name name) . rest) + (define env* (extend-env name (type-name->type type-name) env)) + (define result* (cons (list qualifier type-name name) result)) (annotate:top-level rest body env* result*)))) (define (annotate-exp exp env) @@ -1274,7 +1327,12 @@ (success (compose-substitutions sub1 sub2))))))))) -(define (infer:top-level types names exps body subs success) +(define (infer:top-level types bindings body subs success) + (define exps + (filter-map (match-lambda + (('function _ exp) exp) + (_ #f)) + bindings)) (infer:list exps subs @@ -1305,8 +1363,8 @@ (infer:primcall types operator args subs success)) (('t types ('call operator args ...)) (infer:call types operator args subs success)) - (('t types ('top-level ((names exps) ...) body)) - (infer:top-level types names exps body subs success)) + (('t types ('top-level bindings body)) + (infer:top-level types bindings body subs success)) (_ (error "unknown form" exp)))) (define (resolve:type-variable var env) @@ -1510,7 +1568,9 @@ (define (emit:top-level bindings body port level) (for-each (match-lambda - ((name ('t (type) ('lambda params body))) + (((? input-qualifier? qualifier) type-name name) + (format port "~a ~a ~a;\n" qualifier type-name name)) + (('function name ('t (type) ('lambda params body))) (emit:function name type params body port level))) bindings) (display "void main() {\n" port) -- cgit v1.2.3