diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 335 |
1 files changed, 189 insertions, 146 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 7c78ab2..c7f8ee9 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -62,9 +62,12 @@ (char? x) (boolean? x))) -(define (primitive-call? x) +(define (binary-operator? x) (memq x '(+ - * / = < <= > >=))) +(define (primitive-call? x) + (binary-operator? x)) + (define (difference a b) (match a (() b) @@ -177,21 +180,21 @@ (define names* (map (lambda (_name) (unique-identifier)) names)) (fold extend-env (empty-env) names names*)) -(define (expand-list exps env) +(define (expand:list exps env) (map (lambda (exp) (expand exp env)) exps)) -(define (expand-variable exp env) +(define (expand:variable exp env) ;; Replace original variable with alpha-converted name, but keep ;; track of the original for showing the user error messages that ;; make sense later. `(var ,(lookup exp env) ,exp)) -(define (expand-if predicate consequent alternate env) +(define (expand:if predicate consequent alternate env) `(if ,(expand predicate env) ,(expand consequent env) ,(expand alternate env))) -(define (expand-let names exps body env) +(define (expand:let names exps body env) (if (null? names) (expand body env) (let* ((exps* (map (lambda (exp) (expand exp env)) exps)) @@ -199,7 +202,7 @@ (bindings* (map list (lookup-all names env*) exps*))) `(let ,bindings* ,(expand body env*))))) -(define (expand-let* bindings body env) +(define (expand:let* bindings body env) (match bindings (() (expand body env)) ((binding . rest) @@ -207,16 +210,16 @@ (let* ,rest ,body)) env)))) -(define (expand-lambda params body env) +(define (expand:lambda params body env) (define env* (compose-envs (alpha-convert params) env)) (define params* (lookup-all params env*)) `(lambda ,params* ,(expand body env*))) -(define (expand-primitive-call operator operands env) - `(primcall ,operator ,@(expand-list operands env))) +(define (expand:primitive-call operator operands env) + `(primcall ,operator ,@(expand:list operands env))) -(define (expand-call operator operands env) - `(call ,(expand operator env) ,@(expand-list operands env))) +(define (expand:call operator operands env) + `(call ,(expand operator env) ,@(expand:list operands env))) (define &seagull-syntax-error (make-exception-type '&seagull-syntax-error &error '(form))) @@ -234,23 +237,23 @@ ((? immediate?) exp) ((? symbol?) - (expand-variable exp env)) + (expand:variable exp env)) ;; Primitive syntax forms: (('if predicate consequent alternate) - (expand-if predicate consequent alternate env)) + (expand:if predicate consequent alternate env)) (('let (((? symbol? names) exps) ...) body) - (expand-let names exps body env)) + (expand:let names exps body env)) (('lambda ((? symbol? params) ...) body) - (expand-lambda params body env)) + (expand:lambda params body env)) ;; Macros: (('let* (bindings ...) body) - (expand-let* bindings body env)) + (expand:let* bindings body env)) ;; Primitive calls: (((? primitive-call? operator) args ...) - (expand-primitive-call operator args env)) + (expand:primitive-call operator args env)) ;; Function calls: ((operator args ...) - (expand-call operator args env)) + (expand:call operator args env)) ;; Syntax error: (_ (raise-exception @@ -297,7 +300,7 @@ (raise-exception (make-exception (make-seagull-scope-error original-name) - (make-exception-with-origin free-variables) + (make-exception-with-origin check-free-variables) (make-exception-with-message "seagull: free variable is not top-level") (make-exception-with-irritants (list exp)))))) @@ -315,7 +318,7 @@ ('call args ...)) (check-free-variables-in-list args bound-vars top-level-vars)))) -(define (hoist-list exps) +(define (hoist:list exps) (let-values (((exp-list env-list) (unzip2 (map (lambda (exp) @@ -326,7 +329,7 @@ exps)))) (values exp-list (apply compose-envs env-list)))) -(define (hoist-if predicate consequent alternate) +(define (hoist:if predicate consequent alternate) (define-values (predicate* predicate-env) (hoist-functions predicate)) (define-values (consequent* consequent-env) @@ -336,14 +339,14 @@ (values `(if ,predicate* ,consequent* ,alternate*) (compose-envs predicate-env consequent-env alternate-env))) -(define (hoist-let names exps body) - (define-values (exps* exps-env) (hoist-list exps)) +(define (hoist:let names exps body) + (define-values (exps* exps-env) (hoist:list exps)) (define-values (body* body-env) (hoist-functions body)) (values `(let ,(map list names exps*) ,body*) (compose-envs exps-env body-env))) -(define (hoist-lambda params body) +(define (hoist:lambda params body) (define var (unique-identifier)) (define-values (body* body-env) (hoist-functions body)) @@ -351,13 +354,13 @@ (values `(var ,var #f) (extend-env var lambda* body-env))) -(define (hoist-primcall operator args) - (define-values (args* args-env) (hoist-list args)) +(define (hoist:primcall operator args) + (define-values (args* args-env) (hoist:list args)) (values `(primcall ,operator ,@args*) args-env)) -(define (hoist-call args) - (define-values (args* args-env) (hoist-list args)) +(define (hoist:call args) + (define-values (args* args-env) (hoist:list args)) (values `(call ,@args*) args-env)) @@ -366,15 +369,15 @@ ((or (? immediate?) ('var _ _)) (values exp (empty-env))) (('if predicate consequent alternate) - (hoist-if predicate consequent alternate)) + (hoist:if predicate consequent alternate)) (('let ((names exps) ...) body) - (hoist-let names exps body)) + (hoist:let names exps body)) (('lambda (params ...) body) - (hoist-lambda params body)) + (hoist:lambda params body)) (('primcall operator args ...) - (hoist-primcall operator args)) + (hoist:primcall operator args)) (('call args ...) - (hoist-call args)))) + (hoist:call args)))) (define (hoist-functions* exp) (define-values (exp* env) @@ -588,8 +591,7 @@ ;; variable components that need to be solved for. (define (lookup-type name env) - (pk 'lookup-type name env) - (let ((type (pk 'looked-up (lookup name env)))) + (let ((type (lookup name env))) (if (for-all-type? type) (instantiate type) type))) @@ -630,9 +632,6 @@ (define (generalize type env) (if (function-type? type) - ;; (let ((quantifiers (difference (free-variables-in-type type) - ;; (free-variables-in-env env)))) - ;; (for-all-type quantifiers type)) (match (difference (free-variables-in-type type) (free-variables-in-env env)) (() type) @@ -645,7 +644,7 @@ (extend-env var (fresh-type-variable) env)) (empty-env) (for-all-type-quantifiers for-all))) - (pk 'instantiated (apply-substitutions-to-type (for-all-type-ref for-all) subs))) + (apply-substitutions-to-type (for-all-type-ref for-all) subs)) (define (fresh-type-variables-for-list lst) (map (lambda (_x) (fresh-type-variable)) lst)) @@ -660,19 +659,15 @@ ,(annotate-exp alternate env)))) (define (annotate:let names exps body env) - (define exps* (annotate-list exps env)) + (define exps* (annotate:list exps env)) (define exp-types (map single-type exps*)) (define env* (fold extend-env env names exp-types)) (define body* (annotate-exp body env*)) - (texp (list (function-type (fresh-type-variables-for-list exps) - (texp-types body*))) + (texp (texp-types body*) + ;; (list (function-type (fresh-type-variables-for-list exps) + ;; (texp-types body*))) `(let ,(map list names exps*) ,body*))) -;; (let ((a 1) (b 2)) (+ a b)) -;; ((lambda (a b) (+ a b)) 1 2) -;; (-> (T0 T1) (int)) -;; (-> (int int) (int)) - (define (annotate:lambda params body env) ;; Each function parameter gets a fresh type variable. (define param-types (fresh-type-variables-for-list params)) @@ -688,20 +683,20 @@ ;; directly in the environment. (define operator-types (lookup-type operator env)) (define operator* (texp operator-types operator)) - (define args* (annotate-list args env)) + (define args* (annotate:list args env)) (texp (fresh-type-variables-for-list (list operator*)) `(primcall ,operator* ,@args*))) (define (annotate:call operator args env) (define operator* (annotate-exp operator env)) - (define args* (annotate-list args env)) + (define args* (annotate:list args env)) (texp (fresh-type-variables-for-list (texp-types operator*)) `(call ,operator* ,@args*))) (define* (annotate:top-level bindings body env #:optional (result '())) (match bindings (() - (let ((body* (pk 'body (annotate-exp body env)))) + (let ((body* (annotate-exp body env))) (texp (texp-types body*) `(top-level ,result ,body*)))) (((name exp) . rest) (define exp* @@ -756,9 +751,7 @@ (constrain-texp alternate))) (define (constrain:let type rhs body) - (append (new-env (type (function-type (map single-type rhs) - (texp-types body)))) - (constrain-texp body) + (append (constrain-texp body) (append-map constrain-texp rhs))) (define (constrain:lambda type body) @@ -792,12 +785,10 @@ (('t (type) ('let ((_ rhs) ...) body)) (constrain:let type rhs body)) (('t (type) ('lambda _ body)) - (pk 'constrain:lambda type body) (constrain:lambda type body)) (('t (types ...) ('primcall operator args ...)) (constrain:primitive-call types operator args)) (('t (types ...) ('call operator args ...)) - (pk 'constrain:call types operator args) (constrain:call types operator args)) (('t (types ...) ('top-level ((_ rhs) ...) body)) (constrain:top-level types rhs body)) @@ -822,7 +813,6 @@ (abort-to-prompt %unify-prompt-tag)) (define (unify:maybe-substitute var other env) - (pk 'maybe-sub var other) (cond ;; Tautology: matching 2 vars that are the same. ((and (type-variable? other) (eq? var other)) @@ -834,12 +824,10 @@ (unify type other env))) ;; Substitute variable for value. (else - (or (pk 'sub var other (substitute var other env)) + (or (substitute-type var other env) (unify-fail))))) (define (unify:constants a b env) - (pk 'a a) - (pk 'b b) (if (eqv? a b) env (unify-fail))) (define (unify:lists a rest-a b rest-b env) @@ -869,25 +857,20 @@ (match args ((or ((? type-variable? a) b env) (b (? type-variable? a) env)) - (pk 'unify-vars a b) (unify:variables a b env)) (((? function-type? a) (? function-type? b) env) - (pk 'unify-funcs a b) (unify:functions a b env)) (((? intersection-type? a) b env) - (pk 'unify-intersection a b) (unify:intersection a b env)) (((a . rest-a) (b . rest-b) env) - (pk 'unify-lists a rest-a b rest-b) (unify:lists a rest-a b rest-b env)) ((a b env) - (pk 'unify-constants a b) (unify:constants a b env)))) (define (unify-constraints env) (call-with-unify-backtrack (lambda () - (unify (pk 'as (map car env)) (pk 'bs (map cdr env)) '())) + (unify (env-names env) (env-values env) '())) (lambda () #f))) @@ -912,8 +895,6 @@ (ref (resolve (for-all-type-ref type) env))) (if (null? quantifiers) ref (for-all-type quantifiers ref)))) -(define (resolve:t)) - (define (resolve:list exps env) (map (lambda (exp) (resolve exp env)) exps)) @@ -934,43 +915,69 @@ ;; Transform typed expressions into a string of GLSL code. -(define (emit:number n port) - (display (number->string n) port)) - -(define (emit:boolean b port) - (display (if b "true" "false") port)) - -(define (emit:type type port) - (display (primitive-type-name type) port)) - -(define (emit:binary-operator op a b port) - (display "(" port) - (emit-glsl a port) - (format port " ~a " op) - (emit-glsl b port) - (display ")" port)) - -(define (emit:declaration type name exp port) - (emit:type type port) - (display " " port) - (display name port) - (when exp - (begin - (display " = " port) - (emit-glsl exp port))) - (display ";\n" port)) - -(define (emit:assignment name exp port) - (display "(" port) - (display name port) - (display " = " port) - (emit-glsl exp port) - (display ")" port)) - -(define (emit:function name type params body port) +(define (type-name type) + (primitive-type-name type)) + +(define (single-temp temps) + (match temps + ((temp) temp))) + +(define (indent n port) + (when (> n 0) + (display (make-string (* n 2) #\space) port))) + +(define (emit:int n port level) + (define temp (unique-identifier)) + (indent level port) + (format port "int ~a = ~a;\n" temp n) + (list temp)) + +(define (emit:float n port level) + (define temp (unique-identifier)) + (indent level port) + (format port "float ~a = ~a;\n" temp n) + (list temp)) + +(define (emit:boolean b port level) + (define temp (unique-identifier)) + (indent level port) + (format port "bool ~a = ~a;\n" temp (if b "true" "false")) + (list temp)) + +(define (emit:binary-operator type op a b port level) + (define op* + (case op + ((=) '==) + (else op))) + (define a-temp (single-temp (emit-glsl a port level))) + (define b-temp (single-temp (emit-glsl b port level))) + (define temp (unique-identifier)) + (indent level port) + (format port "~a ~a = ~a ~a ~a;\n" + (type-name type) temp a-temp op* b-temp) + (list temp)) + +(define (emit:declaration type lhs rhs port level) + (indent level port) + (if rhs + (format port "~a ~a = ~a;\n" (type-name type) lhs rhs) + (format port "~a ~a;\n" (type-name type) lhs))) + +(define (emit:declarations types lhs-list rhs-list port level) + (define rhs-list* (if rhs-list rhs-list (make-list (length lhs-list) #f))) + (for-each (lambda (type lhs rhs) + (emit:declaration type lhs rhs port level)) + types lhs-list rhs-list*)) + +(define (emit:mov a b port level) + (indent level port) + (format port "~a = ~a;\n" a b)) + +(define (emit:function name type params body port level) (define param-types (function-type-parameters type)) (define return-types (function-type-returns type)) (define outputs (unique-identifiers-for-list return-types)) + (indent level port) (format port "void ~a(" name) (let loop ((params (append (zip (make-list (length params) 'in) param-types @@ -984,58 +991,93 @@ (((qualifier type name) . rest) (unless first? (display ", " port)) - (format port "~a " qualifier) - (emit:type type port) - (format port " ~a" name) + (format port "~a ~a ~a" + qualifier (type-name type) name) (loop rest #f)))) (display ") {\n" port) - ;; TODO: Multiple return values. - (emit:assignment (first outputs) body port) - (display ";\n}\n" port)) - -(define (emit:if predicate consequent alternate port) - (display "(" port) - (emit-glsl predicate port) - (display " ? " port) - (emit-glsl consequent port) - (display " : " port) - (emit-glsl alternate port) - (display ")" port)) - -(define (emit:let type bindings body port) - (define temp (unique-identifier)) - (define type* (first (function-type-returns type))) - (emit:declaration type* temp #f port) - (for-each (match-lambda - ((name (and exp ('t (type) _))) - (emit:declaration type name exp port))) - bindings) - (emit:assignment temp body port) - (display ";\n" port)) - -(define (emit:top-level bindings body port) + (define body-temps (emit-glsl body port (+ level 1))) + (for-each (lambda (output temp) + (emit:mov output temp port (+ level 1))) + outputs body-temps) + (indent level port) + (display "}\n" port)) + +(define (emit:if predicate consequent alternate port level) + (define if-temps (unique-identifiers-for-list (texp-types consequent))) + (emit:declarations (texp-types consequent) if-temps #f port level) + (define predicate-temp (single-temp (emit-glsl predicate port level))) + (indent level port) + (format port "if(~a) {\n" predicate-temp) + (define consequent-temps (emit-glsl consequent port (+ level 1))) + (for-each (lambda (lhs rhs) + (emit:mov lhs rhs port (+ level 1))) + if-temps consequent-temps) + (indent level port) + (display "else {\n" port) + (define alternate-temps (emit-glsl alternate port (+ level 1))) + (for-each (lambda (lhs rhs) + (emit:mov lhs rhs port (+ level 1))) + if-temps alternate-temps) + (indent level port) + (display "}\n" port) + if-temps) + +(define (emit:let types names exps body port level) + (define binding-temps + (map (lambda (exp) + (single-temp (emit-glsl exp port level))) + exps)) + (define binding-types (map single-type exps)) + (emit:declarations binding-types names binding-temps port level) + (define body-temps (emit-glsl body port level)) + (define let-temps (unique-identifiers-for-list types)) + (emit:declarations (texp-types body) let-temps body-temps port level) + let-temps) + +(define (emit:call types operator args port level) + (define operator-name (single-temp (emit-glsl operator port))) + (define arg-temps + (map (lambda (arg) + (single-temp (emit-glsl arg port level))) + args)) + (define output-temps (unique-identifiers-for-list types)) + (emit:declarations types output-temps #f port level) + (indent level port) + (format port "~a(~a);\n" + operator-name + (string-join (map symbol->string (append arg-temps output-temps)) + ", ")) + output-temps) + +(define (emit:top-level bindings body port level) (for-each (match-lambda ((name ('t (type) ('lambda params body))) - (emit:function name type params body port))) + (emit:function name type params body port level))) bindings) - (emit-glsl body port)) + (display "void main() {\n" port) + (emit-glsl body port (+ level 1)) + (display "}\n" port)) -(define (emit-glsl exp port) +(define* (emit-glsl exp port #:optional (level 0)) (match exp - (('t _ (? number? n)) - (emit:number n port)) + (('t _ (? exact-integer? n)) + (emit:int n port level)) + (('t _ (? float? n)) + (emit:float n port level)) (('t _ (? boolean? b)) - (emit:boolean b port)) + (emit:boolean b port level)) (('t _ ('var var _)) - (display var port)) - (('t _ ('primcall ('t _ (and (or '+ '- '* '/) op)) a b)) - (emit:binary-operator op a b port)) + (list var)) (('t _ ('if predicate consequent alternate)) - (emit:if predicate consequent alternate port)) - (('t (type) ('let bindings body)) - (emit:let type bindings body port)) + (emit:if predicate consequent alternate port level)) + (('t types ('let ((names exps) ...) body)) + (emit:let types names exps body port level)) + (('t (type) ('primcall ('t _ (? binary-operator? op)) a b)) + (emit:binary-operator type op a b port level)) + (('t types ('call operator args ...)) + (emit:call types operator args port level)) (('t _ ('top-level (bindings ...) body)) - (emit:top-level bindings body port)))) + (emit:top-level bindings body port level)))) ;;; @@ -1062,7 +1104,8 @@ (emit-glsl resolved port) (newline port) (display "*** END GLSL OUTPUT ***\n" port) - (list 'annotated texp - 'constraints constraints - 'substitutions substitutions - 'resolved resolved)))) + ;; (list 'annotated texp + ;; 'constraints constraints + ;; 'substitutions substitutions + ;; 'resolved resolved) + ))) |