top-level inputs/uniforms.

1 files changed, 75 insertions, 15 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 9beb310..515101e 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -79,6 +79,9 @@
   (or (binary-operator? x)
       (vector-constructor? x)))
 
+(define (input-qualifier? x)
+  (memq x '(in uniform)))
+
 (define (difference a b)
   (match a
     (() b)
@@ -279,6 +282,13 @@
 (define (expand:call operator operands env)
   `(call ,(expand operator env) ,@(expand:list operands env)))
 
+(define (expand:top-level qualifiers types names body env)
+  (let* ((env* (compose-envs (alpha-convert names) env)))
+    `(top-level ,(map (lambda (qualifier type name)
+                        (list qualifier type (lookup name env*)))
+                      qualifiers types names)
+                ,(expand body env*))))
+
 (define &seagull-syntax-error
   (make-exception-type '&seagull-syntax-error &error '(form)))
 
@@ -305,6 +315,9 @@
      (expand:lambda params body env))
     (('values exps ...)
      (expand:values exps env))
+    (('top-level (((? input-qualifier? qualifiers) types names) ...)
+                 body)
+     (expand:top-level qualifiers types names body env))
     ;; Macros:
     (('let* (bindings ...) body)
      (expand:let* bindings body env))
@@ -414,6 +427,10 @@
         (op* x* y*))
       `(primcall ,op ,x* ,y*)))
 
+(define (propagate:top-level inputs body env)
+  `(top-level ,inputs
+              ,(propagate-constants body env)))
+
 (define (propagate-constants exp env)
   (match exp
     ((? immediate?) exp)
@@ -432,7 +449,9 @@
     (('primcall operator args ...)
      (propagate:primcall operator args env))
     (('call operator args ...)
-     (propagate:call operator args env))))
+     (propagate:call operator args env))
+    (('top-level inputs body)
+     (propagate:top-level inputs body env))))
 
 
 ;;;
@@ -489,7 +508,10 @@
      (check-free-variables-in-list exps bound-vars top-level-vars))
     ((or ('primcall _ args ...)
          ('call args ...))
-     (check-free-variables-in-list args bound-vars top-level-vars))))
+     (check-free-variables-in-list args bound-vars top-level-vars))
+    (('top-level ((_ _ names) ...) body)
+     (define bound-vars* (append names bound-vars))
+     (check-free-variables body bound-vars* top-level-vars))))
 
 (define (hoist:list exps)
   (let-values (((exp-list env-list)
@@ -542,6 +564,12 @@
   (values `(call ,@args*)
           args-env))
 
+(define (hoist:top-level inputs body)
+  (define-values (body* body-env)
+    (hoist-functions body))
+  (values `(top-level ,inputs ,body*)
+          body-env))
+
 (define (hoist-functions exp)
   (match exp
     ((or (? immediate?) ('var _ _))
@@ -557,7 +585,16 @@
     (('primcall operator args ...)
      (hoist:primcall operator args))
     (('call args ...)
-     (hoist:call args))))
+     (hoist:call args))
+    (('top-level inputs body)
+     (hoist:top-level inputs body))))
+
+(define (maybe-merge-top-levels new-bindings exp)
+  (match exp
+    (('top-level bindings body)
+     `(top-level ,(append bindings new-bindings) ,body))
+    (_
+     `(top-level ,new-bindings ,exp))))
 
 (define (hoist-functions* exp)
   (define-values (exp* env)
@@ -567,8 +604,11 @@
   (env-for-each (lambda (name exp)
                   (check-free-variables exp '() top-level-vars))
                 env)
-  `(top-level ,(reverse (env-map list env))
-              ,exp*))
+  (define bindings
+    (env-map (lambda (name func)
+               `(function ,name ,func))
+             env))
+  (maybe-merge-top-levels bindings exp*))
 
 
 ;;;
@@ -581,7 +621,7 @@
 
 
 ;;;
-;;; Type inference: Typed expressions
+;;; Typed expressions
 ;;;
 
 ;; Transform all program expressions into typed expressions by
@@ -614,6 +654,17 @@
 (define mat3-type (primitive-type 'mat3))
 (define mat4-type (primitive-type 'mat4))
 
+(define (type-name->type name)
+  (case name
+    ((bool) bool-type)
+    ((int) int-type)
+    ((float) float-type)
+    ((vec2) vec2-type)
+    ((vec3) vec3-type)
+    ((vec4) vec4-type)
+    ((mat3) mat3-type)
+    ((mat4) mat4-type)))
+
 ;; Type variables:
 (define unique-type-variable-counter (make-parameter 0))
 
@@ -851,14 +902,12 @@
    (else (error "invalid type" type))))
 
 (define (apply-substitutions-to-type type subs)
-  (pk 'sub-type type subs)
   (env-fold (lambda (from to type*)
               (apply-substitution-to-type type* from to))
             type
             subs))
 
 (define (apply-substitutions-to-types types subs)
-  (pk 'sub-types types subs)
   (map (lambda (type)
          (apply-substitutions-to-type type subs))
        types))
@@ -1008,8 +1057,8 @@
   (match bindings
     (()
      (let ((body* (annotate-exp body env)))
-       (texp (texp-types body*) `(top-level ,result ,body*))))
-    (((name exp) . rest)
+       (texp (texp-types body*) `(top-level ,(reverse result) ,body*))))
+    ((('function name exp) . rest)
      (define exp*
        (let ((x (annotate-exp exp env)))
          ;; Function types must be generalized so that functions like
@@ -1017,7 +1066,11 @@
          (texp (list (generalize (single-type x) env))
                (texp-exp x))))
      (define env* (extend-env name (single-type exp*) env))
-     (define result* (cons (list name exp*) result))
+     (define result* (cons `(function ,name ,exp*) result))
+     (annotate:top-level rest body env* result*))
+    ((((? input-qualifier? qualifier) type-name name) . rest)
+     (define env* (extend-env name (type-name->type type-name) env))
+     (define result* (cons (list qualifier type-name name) result))
      (annotate:top-level rest body env* result*))))
 
 (define (annotate-exp exp env)
@@ -1274,7 +1327,12 @@
                        (success
                         (compose-substitutions sub1 sub2)))))))))
 
-(define (infer:top-level types names exps body subs success)
+(define (infer:top-level types bindings body subs success)
+  (define exps
+    (filter-map (match-lambda
+                  (('function _ exp) exp)
+                  (_ #f))
+                bindings))
   (infer:list
    exps
    subs
@@ -1305,8 +1363,8 @@
      (infer:primcall types operator args subs success))
     (('t types ('call operator args ...))
      (infer:call types operator args subs success))
-    (('t types ('top-level ((names exps) ...) body))
-     (infer:top-level types names exps body subs success))
+    (('t types ('top-level bindings body))
+     (infer:top-level types bindings body subs success))
     (_ (error "unknown form" exp))))
 
 (define (resolve:type-variable var env)
@@ -1510,7 +1568,9 @@
 
 (define (emit:top-level bindings body port level)
   (for-each (match-lambda
-              ((name ('t (type) ('lambda params body)))
+              (((? input-qualifier? qualifier) type-name name)
+               (format port "~a ~a ~a;\n" qualifier type-name name))
+              (('function name ('t (type) ('lambda params body)))
                (emit:function name type params body port level)))
             bindings)
   (display "void main() {\n" port)