Shader outputs.

1 files changed, 186 insertions, 48 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 515101e..0a54b88 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -62,6 +62,9 @@
       (char? x)
       (boolean? x)))
 
+(define (unary-operator? x)
+  (eq? x 'not))
+
 (define (arithmetic-operator? x)
   (memq x '(+ - * /)))
 
@@ -75,12 +78,30 @@
 (define (vector-constructor? x)
   (memq x '(vec2 vec3 vec4)))
 
+(define (conversion? x)
+  (memq x '(int->float float->int)))
+
+(define (math-function? x)
+  (memq x '(abs sqrt min max sin cos tan clamp mix)))
+
 (define (primitive-call? x)
   (or (binary-operator? x)
-      (vector-constructor? x)))
-
-(define (input-qualifier? x)
-  (memq x '(in uniform)))
+      (unary-operator? x)
+      (vector-constructor? x)
+      (conversion? x)
+      (math-function? x)))
+
+(define (top-level-qualifier? x)
+  (memq x '(in out uniform)))
+
+(define (built-in-output? name stage)
+  (case stage
+    ((vertex)
+     ;; GL 4+ has more built-ins, but we are supporting GL 2+ so we
+     ;; can't use them easily.
+     (memq name '(gl-position gl-point-size gl-clip-distance)))
+    ((fragment)
+     (memq name '(gl-frag-depth gl-sample-mask)))))
 
 (define (difference a b)
   (match a
@@ -284,11 +305,20 @@
 
 (define (expand:top-level qualifiers types names body env)
   (let* ((env* (compose-envs (alpha-convert names) env)))
+    ;; TODO: Support interpolation qualifiers.
     `(top-level ,(map (lambda (qualifier type name)
                         (list qualifier type (lookup name env*)))
                       qualifiers types names)
                 ,(expand body env*))))
 
+(define (expand:outputs names exps env)
+  `(outputs ,@(map (lambda (name exp)
+                     (list (if (built-in-output? name 'vertex)
+                               name
+                               (lookup name env))
+                           (expand exp env)))
+                   names exps)))
+
 (define &seagull-syntax-error
   (make-exception-type '&seagull-syntax-error &error '(form)))
 
@@ -315,7 +345,9 @@
      (expand:lambda params body env))
     (('values exps ...)
      (expand:values exps env))
-    (('top-level (((? input-qualifier? qualifiers) types names) ...)
+    (('outputs ((? symbol? names) exps) ...)
+     (expand:outputs names exps env))
+    (('top-level (((? top-level-qualifier? qualifiers) types names) ...)
                  body)
      (expand:top-level qualifiers types names body env))
     ;; Macros:
@@ -431,6 +463,11 @@
   `(top-level ,inputs
               ,(propagate-constants body env)))
 
+(define (propagate:outputs names exps env)
+  `(outputs ,@(map (lambda (name exp)
+                     (list name (propagate-constants exp env)))
+                   names exps)))
+
 (define (propagate-constants exp env)
   (match exp
     ((? immediate?) exp)
@@ -450,6 +487,8 @@
      (propagate:primcall operator args env))
     (('call operator args ...)
      (propagate:call operator args env))
+    (('outputs (names exps) ...)
+     (propagate:outputs names exps env))
     (('top-level inputs body)
      (propagate:top-level inputs body env))))
 
@@ -509,6 +548,8 @@
     ((or ('primcall _ args ...)
          ('call args ...))
      (check-free-variables-in-list args bound-vars top-level-vars))
+    (('outputs (names exps) ...)
+     (check-free-variables-in-list exps 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))))
@@ -570,6 +611,14 @@
   (values `(top-level ,inputs ,body*)
           body-env))
 
+(define (hoist:outputs names exps)
+  (define-values (exps* exp-env)
+    (hoist:list exps))
+  (values `(outputs ,@(map (lambda (name exp)
+                             (list name exp))
+                           names exps*))
+          exp-env))
+
 (define (hoist-functions exp)
   (match exp
     ((or (? immediate?) ('var _ _))
@@ -586,6 +635,8 @@
      (hoist:primcall operator args))
     (('call args ...)
      (hoist:call args))
+    (('outputs (names exps) ...)
+     (hoist:outputs names exps))
     (('top-level inputs body)
      (hoist:top-level inputs body))))
 
@@ -612,15 +663,6 @@
 
 
 ;;;
-;;; Recursion analysis
-;;;
-
-;; GLSL does not allow for recursive function calls, but Seagull
-;; allows the current function to call itself in tail position because
-;; they can be compiled to a loop in GLSL.
-
-
-;;;
 ;;; Typed expressions
 ;;;
 
@@ -737,6 +779,14 @@
   (match type
     (('overload types) types)))
 
+;; Outputs type:
+(define outputs-type '(outputs))
+
+(define (outputs-type? obj)
+  (match obj
+    (('outputs) #t)
+    (_ #f)))
+
 (define (type? obj)
   (or (primitive-type? obj)
       (type-variable? obj)
@@ -793,9 +843,9 @@
          (function-type (list mat4-type mat4-type)
                         (list mat4-type))
          (function-type (list mat4-type vec4-type)
-                        (list mat4-type))
+                        (list vec4-type))
          (function-type (list vec4-type mat4-type)
-                        (list mat4-type)))))
+                        (list vec4-type)))))
 
 (define div-type
   (list (overload-type
@@ -855,6 +905,31 @@
          (function-type (list float-type vec3-type)
                         (list vec4-type)))))
 
+(define abs-type
+  (list (overload-type
+         (function-type (list int-type) (list int-type))
+         (function-type (list float-type) (list float-type)))))
+
+(define sqrt-type
+  (list (overload-type
+         (function-type (list int-type) (list int-type))
+         (function-type (list float-type) (list float-type)))))
+
+(define min/max-type
+  (list (overload-type
+         (function-type (list int-type int-type) (list int-type))
+         (function-type (list float-type float-type) (list float-type)))))
+
+(define trigonometry-type
+  (list (function-type (list float-type) (list float-type))))
+
+(define clamp/mix-type
+  (list (overload-type
+         (function-type (list int-type int-type int-type)
+                        (list int-type))
+         (function-type (list float-type float-type float-type)
+                        (list float-type)))))
+
 (define (top-level-type-env)
   `((+ . ,add/sub-type)
     (- . ,add/sub-type)
@@ -867,7 +942,20 @@
     (>= . ,comparison-type)
     (vec2 . ,make-vec2-type)
     (vec3 . ,make-vec3-type)
-    (vec4 . ,make-vec4-type)))
+    (vec4 . ,make-vec4-type)
+    (not ,(function-type (list bool-type) (list bool-type)))
+    (int->float ,(function-type (list int-type) (list float-type)))
+    (float->int ,(function-type (list float-type) (list int-type)))
+    (abs . ,abs-type)
+    (sqrt . ,sqrt-type)
+    (min . ,min/max-type)
+    (max . ,min/max-type)
+    (sin . ,trigonometry-type)
+    (cos . ,trigonometry-type)
+    (tan . ,trigonometry-type)
+    (clamp . ,clamp/mix-type)
+    (mix . ,clamp/mix-type)
+    (gl-position ,vec4-type)))
 
 (define (occurs? a b)
   (cond
@@ -883,7 +971,9 @@
 (define (apply-substitution-to-type type from to)
   (pk 'apply-substitution-to-type type from to)
   (cond
-   ((primitive-type? type) type)
+   ((or (primitive-type? type)
+        (outputs-type? type))
+    type)
    ((type-variable? type)
     (if (equal? type from) to type))
    ((function-type? type)
@@ -1007,15 +1097,14 @@
 
 (define (annotate:if predicate consequent alternate env)
   (define consequent* (annotate-exp consequent env))
-  (texp (fresh-type-variables-for-list
-         (texp-types consequent*))
+  (texp (texp-types consequent*)
         `(if ,(annotate-exp predicate env)
              ,consequent*
              ,(annotate-exp alternate env))))
 
 (define (annotate:let names exps body env)
   (define exps* (annotate:list exps env))
-  (define exp-types (map single-type exps*))
+  (define exp-types (map texp-types exps*))
   (define env* (fold extend-env env names exp-types))
   (define body* (annotate-exp body env*))
   (texp (texp-types body*)
@@ -1025,7 +1114,10 @@
   ;; Each function parameter gets a fresh type variable.
   (define param-types (fresh-type-variables-for-list params))
   ;; The type environment is extended with the function parameters.
-  (define env* (fold extend-env env params param-types))
+  (define env*
+    (fold (lambda (param type env*)
+            (extend-env param (list type) env*))
+          env params param-types))
   ;; The body is annotated in the new environment.
   (define body* (annotate-exp body env*))
   (texp (list (function-type param-types (texp-types body*)))
@@ -1068,11 +1160,19 @@
      (define env* (extend-env name (single-type exp*) env))
      (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))
+    ((((? top-level-qualifier? qualifier) type-name name) . rest)
+     (define env* (extend-env name (list (type-name->type type-name)) env))
      (define result* (cons (list qualifier type-name name) result))
      (annotate:top-level rest body env* result*))))
 
+(define (annotate:outputs names exps env)
+  (texp (list outputs-type)
+        `(outputs
+          ,@(map (lambda (name exp)
+                   (list (texp (pk 'types name (lookup name env)) name)
+                         (annotate-exp exp env)))
+                 names exps))))
+
 (define (annotate-exp exp env)
   (match exp
     ((? exact-integer?)
@@ -1082,7 +1182,7 @@
     ((? boolean?)
      (texp (list bool-type) exp))
     (('var var _)
-     (texp (list (lookup-type var env)) exp))
+     (texp (lookup-type var env) exp))
     (('if predicate consequent alternate)
      (annotate:if predicate consequent alternate env))
     (('let ((names exps) ...) body)
@@ -1095,6 +1195,8 @@
      (annotate:primitive-call operator args env))
     (('call operator args ...)
      (annotate:call operator args env))
+    (('outputs (names exps) ...)
+     (annotate:outputs names exps env))
     (('top-level bindings body)
      (annotate:top-level bindings body env))))
 
@@ -1200,6 +1302,8 @@
      (unify:functions a b success))
     ((a (? overload-type? b))
      (unify:overload b a success))
+    (((? outputs-type?) (? outputs-type?))
+     (success '()))
     ((() ())
      (success '()))
     (((a rest-a ...) (b rest-b ...))
@@ -1208,7 +1312,6 @@
      (unify:fail "type mismatch" a b))))
 
 (define (infer:list exps subs success)
-  (pk 'infer:list exps)
   (match exps
     (() (success subs))
     ((exp . rest)
@@ -1222,7 +1325,6 @@
                              (compose-substitutions sub0 sub1)))))))))
 
 (define (infer:if types predicate consequent alternate subs success)
-  (pk 'infer:if predicate consequent alternate subs)
   (infer predicate
          subs
          (lambda (sub0)
@@ -1243,22 +1345,11 @@
                                               (texp-types alternate)
                                               sub4)
                                              (lambda (sub5)
-                                               (define sub6
+                                               (success
                                                 (compose-substitutions
-                                                 sub4 sub5))
-                                               (unify (apply-substitutions-to-types
-                                                       types
-                                                       sub6)
-                                                      (apply-substitutions-to-types
-                                                       (texp-types consequent)
-                                                       sub6)
-                                                      (lambda (sub7)
-                                                        (success
-                                                          (compose-substitutions
-                                                           sub6 sub7)))))))))))))))
+                                                 sub4 sub5)))))))))))))
 
 (define (infer:lambda type body subs success)
-  (pk 'infer:lambda type body)
   (define type*
     (if (for-all-type? type)
         (for-all-type-ref type)
@@ -1273,11 +1364,9 @@
                      (compose-substitutions sub0 sub1)))))))
 
 (define (infer:values types exps subs success)
-  (pk 'infer:values exps)
   (infer:list exps subs success))
 
 (define (infer:call types operator args subs success)
-  (pk 'infer:call types operator args subs)
   (infer operator
          subs
          (lambda (sub0)
@@ -1296,7 +1385,6 @@
                        (success (compose-substitutions sub1 sub2)))))))))
 
 (define (infer:primcall types operator args subs success)
-  (pk 'infer:primcall types operator args)
   (infer:list
    args
    subs
@@ -1313,7 +1401,6 @@
                (compose-substitutions sub0 sub1)))))))
 
 (define (infer:let types names exps body subs success)
-  (pk 'infer:let types names exps subs)
   (infer:list
    exps
    subs
@@ -1346,10 +1433,21 @@
                        (success
                         (compose-substitutions sub1 sub2)))))))))
 
+(define (infer:outputs names exps subs success)
+  (define output-types (map single-type names))
+  (infer:list
+   exps
+   subs
+   (lambda (sub0)
+     (unify output-types
+            (apply-substitutions-to-types (map single-type exps) sub0)
+            (lambda (sub1)
+              (success
+               (compose-substitutions sub0 sub1)))))))
+
 (define (infer exp subs success)
   (match exp
     (('t types (or (? immediate?) ('var _ _)))
-     (pk 'infer:basic)
      (success subs))
     (('t types ('if predicate consequent alternate))
      (infer:if types predicate consequent alternate subs success))
@@ -1363,6 +1461,8 @@
      (infer:primcall types operator args subs success))
     (('t types ('call operator args ...))
      (infer:call types operator args subs success))
+    (('t _ ('outputs (names exps) ...))
+     (infer:outputs names exps subs success))
     (('t types ('top-level bindings body))
      (infer:top-level types bindings body subs success))
     (_ (error "unknown form" exp))))
@@ -1401,7 +1501,6 @@
        (infer annotated
               '()
               (lambda (subs)
-                (pk 'result-subs subs)
                 (resolve annotated subs)))))
    (lambda args
      (apply error args))))
@@ -1455,6 +1554,18 @@
           (type-name type) temp a-temp op* b-temp)
   (list temp))
 
+(define (emit:unary-operator type op a port level)
+  (define op*
+    (case op
+      ((not) '!)
+      (else op)))
+  (define a-temp (single-temp (emit-glsl a port level)))
+  (define temp (unique-identifier))
+  (indent level port)
+  (format port "~a ~a = ~a(~a);\n"
+          (type-name type) temp op* a-temp)
+  (list temp))
+
 (define (emit:declaration type lhs rhs port level)
   (indent level port)
   (if rhs
@@ -1538,6 +1649,11 @@
   let-temps)
 
 (define (emit:primcall type operator args port level)
+  (define operator*
+    (case operator
+      ((float->int) 'float)
+      ((int->float) 'int)
+      (else operator)))
   (define arg-temps
     (map (lambda (arg)
            (single-temp (emit-glsl arg port level)))
@@ -1547,7 +1663,7 @@
   (format port "~a ~a = ~a(~a);\n"
           (type-name type)
           output-temp
-          operator
+          operator*
           (string-join (map symbol->string arg-temps) ", "))
   (list output-temp))
 
@@ -1568,7 +1684,7 @@
 
 (define (emit:top-level bindings body port level)
   (for-each (match-lambda
-              (((? input-qualifier? qualifier) type-name name)
+              (((? top-level-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)))
@@ -1577,6 +1693,24 @@
   (emit-glsl body port (+ level 1))
   (display "}\n" port))
 
+(define (emit:outputs names exps port level)
+  (define (output-name name)
+    (case name
+      ((gl-position) 'gl_Position)
+      ((gl-point-size) 'gl_PointSize)
+      ((gl-clip-distance) 'gl_ClipDistance)
+      ((gl-frag-depth) 'gl_FragDepth)
+      ((gl-sample-mask) 'gl_SampleMask)
+      (else name)))
+  (for-each (lambda (name exp)
+              (match (emit-glsl exp port level)
+                ((temp)
+                 (indent level port)
+                 (format port "~a = ~a;\n"
+                         (output-name (texp-exp name))
+                         temp))))
+            names exps))
+
 (define* (emit-glsl exp port #:optional (level 0))
   (match exp
     (('t _ (? exact-integer? n))
@@ -1595,10 +1729,14 @@
      (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 (type) ('primcall ('t _ (? unary-operator? op)) a))
+     (emit:unary-operator type op a port level))
     (('t (type) ('primcall ('t _ op) args ...))
      (emit:primcall type op args port level))
     (('t types ('call operator args ...))
      (emit:call types operator args port level))
+    (('t _ ('outputs (names exps) ...))
+     (emit:outputs names exps port level))
     (('t _ ('top-level (bindings ...) body))
      (emit:top-level bindings body port level))))