diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 133 |
1 files changed, 111 insertions, 22 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 1ae82bb..05003d9 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -1661,6 +1661,83 @@ combined-subs pred)) +(define (infer:values exps env) + (define-values (exps* exp-subs exp-pred) + (infer:list exps env)) + (values (texp (map single-type exps*) + `(values ,@exps*)) + exp-subs + exp-pred)) + +(define (infer:outputs names exps env) + (define-values (exps* exp-subs exp-pred) + (infer:list exps env)) + (values (texp (map single-type exps*) + `(outputs ,@(map list names exps*))) + exp-subs + exp-pred)) + +(define (infer:top-level bindings body env) + (define (infer-bindings bindings texps subs pred) + (match bindings + (() + (values (reverse texps) subs pred)) + ((('function _ exp) . rest) + (define-values (texp subs* pred*) + (infer-exp exp env)) + (define-values (new-pred combined-subs) + (eval-predicate* (compose-predicates pred pred*) + (compose-substitutions subs subs*))) + (infer-bindings rest + (cons texp texps) + combined-subs + new-pred)) + (((_ type-name _) . rest) + (infer-bindings rest + (cons (list (type-name->type type-name)) texps) + subs + pred)))) + (define qualifiers (map first bindings)) + (define names + (map (match-lambda + (('function name _) name) + ((_ _ name) name)) + bindings)) + (define type-names + (map (match-lambda + (((or 'in 'out) type-name _) type-name) + (_ #f)) + bindings)) + (define-values (exps exp-subs exp-pred) + (infer-bindings bindings '() '() #t)) + (define exp-types + (map (lambda (x) + (if (texp? x) + (texp-types x) + x)) + exps)) + (define env* + (fold extend-env + (apply-substitutions-to-env env exp-subs) + names + exp-types)) + (define-values (body* body-subs body-pred) + (infer-exp body env*)) + (define-values (pred combined-subs) + (eval-predicate* (compose-predicates exp-pred body-pred) + (compose-substitutions exp-subs body-subs))) + (define bindings* + (map (match-lambda* + (((and (or 'in 'out) qualifier) type-name name _) + (list qualifier type-name name)) + (('function _ name exp) + `(function ,name ,exp))) + qualifiers type-names names exps)) + (values (texp (texp-types body*) + `(top-level ,bindings* ,body*)) + combined-subs + pred)) + ;; Inference returns 3 values: ;; - a typed expression ;; - a list of substitutions @@ -1669,40 +1746,49 @@ (match exp ((? immediate?) (infer:immediate exp)) - ((? symbol?) - (infer:variable exp env)) + ((or (? symbol? name) ('var name _)) + (infer:variable name env)) (('if predicate consequent alternate) (infer:if predicate consequent alternate env)) (('let ((names exps) ...) body) (infer:let names exps body env)) (('lambda (params ...) body) (infer:lambda params body env)) - ;; (('values exps ...) - ;; (infer:values exps env)) + (('values exps ...) + (infer:values exps env)) (('primcall operator args ...) (infer:primitive-call operator args env)) (('call operator args ...) (infer:call operator args env)) - ;; (('outputs (names exps) ...) - ;; (infer:outputs names exps env)) - ;; (('top-level bindings body) - ;; (infer:top-level bindings body env)) + (('outputs (names exps) ...) + (infer:outputs names exps env)) + (('top-level bindings body) + (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 (when (and (= ,a ,int-type) + (= ,b ,int-type)) + (substitute ,c ,a)) + (when (and (= ,a ,float-type) + (= ,b ,float-type)) + (substitute ,c ,a)))))) + (empty-env))) + ;; 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) - (call-with-unify-rollback - (lambda () - (let ((annotated (pk 'annotated (annotate-exp* exp stage)))) - (infer annotated - '() - (lambda (subs) - (resolve annotated subs))))) - (match-lambda* - ((msg . args) - (seagull-type-error msg args infer-types))))) + (infer-exp exp (make-test-env))) ;;; @@ -1929,7 +2015,7 @@ (emit:float n version port level)) (('t _ (? boolean? b)) (emit:boolean b version port level)) - (('t _ ('var var _)) + (('t _ (? symbol? var)) (list var)) (('t _ ('if predicate consequent alternate)) (emit:if predicate consequent alternate version port level)) @@ -1937,11 +2023,11 @@ (emit:values exps version port level)) (('t types ('let ((names exps) ...) body)) (emit:let types names exps body version port level)) - (('t (type) ('primcall ('t _ (? binary-operator? op)) a b)) + (('t (type) ('primcall (? binary-operator? op) a b)) (emit:binary-operator type op a b version port level)) - (('t (type) ('primcall ('t _ (? unary-operator? op)) a)) + (('t (type) ('primcall (? unary-operator? op) a)) (emit:unary-operator type op a version port level)) - (('t (type) ('primcall ('t _ op) args ...)) + (('t (type) ('primcall op args ...)) (emit:primcall type op args version port level)) (('t types ('call operator args ...)) (emit:call types operator args version port level)) @@ -1958,6 +2044,8 @@ ;; Combine all of the compiler passes on a user provided program and ;; emit GLSL code if the program is valid. +(use-modules (ice-9 pretty-print)) + (define* (compile-seagull exp #:key (stage 'vertex) (version '330) (port (current-output-port))) @@ -1967,4 +2055,5 @@ (propagated (propagate-constants expanded (empty-env))) (hoisted (hoist-functions* propagated)) (inferred (infer-types hoisted stage))) + (pretty-print inferred) (emit-glsl inferred version port)))) |