summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm335
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)
+ )))