Better GLSL emission.

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