diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 128 |
1 files changed, 122 insertions, 6 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index c53e034..7c78ab2 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -170,6 +170,9 @@ (string->symbol (format #f "V~a" (unique-identifier-number)))) +(define (unique-identifiers-for-list lst) + (map (lambda (_x) (unique-identifier)) lst)) + (define (alpha-convert names) (define names* (map (lambda (_name) (unique-identifier)) names)) (fold extend-env (empty-env) names names*)) @@ -415,6 +418,10 @@ (('primitive _) #t) (_ #f))) +(define (primitive-type-name type) + (match type + (('primitive name) name))) + (define int-type (primitive-type 'int)) (define float-type (primitive-type 'float)) (define bool-type (primitive-type 'bool)) @@ -731,8 +738,7 @@ (annotate:top-level bindings body env)))) (define (annotate-exp* exp) - (parameterize ((unique-type-variable-counter 0)) - (annotate-exp exp (top-level-type-env)))) + (annotate-exp exp (top-level-type-env))) ;;; @@ -898,6 +904,8 @@ (resolve type env) var))) +;; TODO: If there are still quantified type variables, scan the entire +;; program for calls to the function and build an intersection type. (define (resolve:for-all type env) (let ((quantifiers (filter type-variable? (resolve (for-all-type-quantifiers type) env))) @@ -926,6 +934,108 @@ ;; 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 param-types (function-type-parameters type)) + (define return-types (function-type-returns type)) + (define outputs (unique-identifiers-for-list return-types)) + (format port "void ~a(" name) + (let loop ((params (append (zip (make-list (length params) 'in) + param-types + params) + (zip (make-list (length return-types) 'out) + return-types + outputs))) + (first? #t)) + (match params + (() #t) + (((qualifier type name) . rest) + (unless first? + (display ", " port)) + (format port "~a " qualifier) + (emit:type type port) + (format port " ~a" 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) + (for-each (match-lambda + ((name ('t (type) ('lambda params body))) + (emit:function name type params body port))) + bindings) + (emit-glsl body port)) + +(define (emit-glsl exp port) + (match exp + (('t _ (? number? n)) + (emit:number n port)) + (('t _ (? boolean? b)) + (emit:boolean b port)) + (('t _ ('var var _)) + (display var port)) + (('t _ ('primcall ('t _ (and (or '+ '- '* '/) op)) a b)) + (emit:binary-operator op a b port)) + (('t _ ('if predicate consequent alternate)) + (emit:if predicate consequent alternate port)) + (('t (type) ('let bindings body)) + (emit:let type bindings body port)) + (('t _ ('top-level (bindings ...) body)) + (emit:top-level bindings body port)))) ;;; @@ -939,14 +1049,20 @@ (for-each (lambda (x) (format #t "~a\n" x)) lst)) ;; Substitutions aren't being generated correctly. -(define (compile-seagull exp) - (parameterize ((unique-identifier-counter 0)) +(define* (compile-seagull exp #:optional (port (current-output-port))) + (parameterize ((unique-identifier-counter 0) + (unique-type-variable-counter 0)) (let* ((expanded (pk 'expanded (expand exp (top-level-env)))) (hoisted (pk 'hoisted (hoist-functions* expanded))) (texp (pk 'annotated (annotate-exp* hoisted))) (constraints (pk 'constraints (constrain-texp texp))) - (substitutions (pk 'substitutions (unify-constraints constraints)))) + (substitutions (pk 'substitutions (unify-constraints constraints))) + (resolved (pk 'resolved (resolve texp substitutions)))) + (display "*** BEGIN GLSL OUTPUT ***\n" port) + (emit-glsl resolved port) + (newline port) + (display "*** END GLSL OUTPUT ***\n" port) (list 'annotated texp 'constraints constraints 'substitutions substitutions - 'resolved (resolve texp substitutions))))) + 'resolved resolved)))) |