GLSL emission

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))))