Fixes to make path fill shader compile.

1 files changed, 162 insertions, 85 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 4e271ff..44a9bd9 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -39,12 +39,15 @@
 ;;
 ;; TODO:
 ;; - Loops
+;; - discard
 ;; - (define ...) form
+;; - struct field aliases (rgba for vec4, for example)
 ;; - Scheme shader type -> GLSL struct translation
 ;; - Dead code elimination (error when a uniform is eliminated)
 ;; - User defined structs
 ;; - Multiple GLSL versions
 ;; - Better error messages (especially around type predicate failure)
+;; - Refactor to add define-primitive syntax
 ;;
 ;;; Code:
 (define-module (chickadee graphics seagull)
@@ -114,7 +117,7 @@
   (memq x '(int->float float->int)))
 
 (define (math-function? x)
-  (memq x '(abs sqrt min max mod floor ceil sin cos tan clamp mix)))
+  (memq x '(abs sqrt min max mod floor ceil sin cos tan clamp mix length)))
 
 (define (vertex-primitive-call? x)
   #f)
@@ -1235,8 +1238,8 @@
                   ,(apply-substitution-to-type b from to)))
     (('struct-field struct field var)
      `(struct-field ,(apply-substitution-to-type struct from to)
-                   ,field
-                   ,(apply-substitution-to-type var from to)))
+                    ,field
+                    ,(apply-substitution-to-type var from to)))
     (('array-element array var)
      `(array-element ,(apply-substitution-to-type array from to)
                      ,(apply-substitution-to-type var from to)))))
@@ -1405,7 +1408,10 @@
     ;; struct type.
     (('struct-field struct field field-var)
      (if (struct-type? struct)
-         (values #t (list (cons field-var (struct-type-ref struct field))))
+         (let ((field-type (struct-type-ref struct field)))
+           (if field-type
+               (values #t (list (cons field-var field-type)))
+               (values #f '())))
          (values pred '())))
     ;; Substitute the element var when array has been resolved to an
     ;; array type.
@@ -1774,11 +1780,15 @@
     (infer-exp exp env))
   (define exp-type (single-type exp*))
   (define tvar (fresh-variable-type))
-  (values (texp (list tvar)
-                `(struct-ref ,exp* ,field))
-          exp-subs
-          (compose-predicates exp-pred
-                              (predicate:struct-field exp-type field tvar))))
+  (define-values (pred combined-subs)
+    (eval-predicate* (compose-predicates (predicate:struct-field exp-type field tvar)
+                                         exp-pred)
+                     exp-subs))
+  (values (texp (list (apply-substitutions-to-type tvar combined-subs))
+                `(struct-ref ,(apply-substitutions-to-texp exp* combined-subs)
+                             ,field))
+          combined-subs
+          pred))
 
 (define (infer:array-ref array-exp index-exp env)
   (define-values (array-exp* array-exp-subs array-exp-pred)
@@ -1823,7 +1833,11 @@
     (eval-predicate* (compose-predicates exp-pred body-pred)
                      (compose-substitutions exp-subs body-subs)))
   (values (texp (texp-types body*)
-                `(let ,(map list names exps*) ,body*))
+                `(let ,(map (lambda (name exp)
+                              (list name (apply-substitutions-to-texp
+                                          exp combined-subs)))
+                            names exps*)
+                   ,(apply-substitutions-to-texp body* combined-subs)))
           combined-subs
           pred))
 
@@ -1848,7 +1862,11 @@
   (define-values (pred combined-subs)
     (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs)))
   (values (texp (list type:outputs)
-                `(outputs ,@(map list names exps*)))
+                `(outputs
+                  ,@(map (lambda (name exp)
+                           (list name (apply-substitutions-to-texp
+                                       exp combined-subs)))
+                         names exps*)))
           combined-subs
           pred))
 
@@ -2025,8 +2043,8 @@
             (type:vec4 type:float type:vec4)
             (type:float type:vec4 type:vec4)
             (type:mat3 type:mat3 type:mat3)
-            (type:mat3 type:vec3 type:mat3)
-            (type:vec3 type:mat3 type:mat3)
+            (type:mat3 type:vec3 type:vec3)
+            (type:vec3 type:mat3 type:vec3)
             (type:mat4 type:mat4 type:mat4)
             (type:mat4 type:vec4 type:vec4)
             (type:vec4 type:mat4 type:vec4)))
@@ -2087,6 +2105,17 @@
   (define type:make-vec4
     (list (function-type (list type:float type:float type:float type:float)
                          (list type:vec4))))
+  (define type:length
+    (let ((a (fresh-variable-type)))
+      (list (type-scheme
+             (list a)
+             (qualified-type
+              (function-type (list a) (list type:float))
+              (predicate:or
+               (predicate:= a type:float)
+               (predicate:= a type:vec2)
+               (predicate:= a type:vec3)
+               (predicate:= a type:vec4)))))))
   (define type:abs
     (let ((a (fresh-variable-type)))
       (list (type-scheme
@@ -2157,6 +2186,7 @@
     (vec2 . ,type:make-vec2)
     (vec3 . ,type:make-vec3)
     (vec4 . ,type:make-vec4)
+    (length . ,type:length)
     (abs . ,type:abs)
     (sqrt . ,type:sqrt)
     (min . ,type:min/max)
@@ -2236,14 +2266,25 @@
 (define (vars->subs exp env)
   (match exp
     (('t ((? variable-type? tvar)) (? symbol? name))
-     (list (cons tvar (lookup name env))))
+     (let ((type (lookup* name env)))
+       (if type
+           (list (cons tvar type))
+           '())))
     ((head . rest)
      (delete-duplicates
       (append (vars->subs head env)
               (vars->subs rest env))))
     (_ '())))
 
-(define (resolve-overloads program)
+(define (untype x)
+  (match x
+    (('t (_ ...) exp)
+     (untype exp))
+    ((exp . rest)
+     (cons (untype exp) (untype rest)))
+    (_ x)))
+
+(define (resolve-overloads program stage)
   ;; Find all of the struct types used in the program.  They will be
   ;; used to generate overloaded functions that take one or more
   ;; structs as arguments.
@@ -2251,7 +2292,8 @@
   (match program
     (('t types ('top-level bindings body))
      (define bindings*
-       (let loop ((bindings bindings))
+       (let loop ((bindings bindings)
+                  (globals (empty-env)))
          (match bindings
            (() '())
            ((('function name ('t ((? type-scheme? type)) func)) . rest)
@@ -2267,8 +2309,16 @@
                                (('lambda (params ...) _)
                                 params)))
                            (define env
-                             (fold extend-env (empty-env) params
-                                   (function-type-parameters type*)))
+                             (compose-envs (fold extend-env (empty-env) params
+                                                 (map list (function-type-parameters type*)))
+                                           globals))
+                           (pk 're-infer-func env)
+                           (match func
+                             (('lambda _ body)
+                              (pretty-print
+                               (infer-exp (untype body)
+                                          (compose-envs env
+                                                        (top-level-type-env stage))))))
                            (define subs*
                              (compose-substitutions subs
                                                     (vars->subs func env)))
@@ -2283,9 +2333,17 @@
                           ;;                     rest)
                           ;;         (find-signatures name body))
                           ))
-                    (loop rest)))
-           ((binding . rest)
-            (cons binding (loop rest))))))
+                    (loop rest globals)))
+           ((('function name texp) . rest)
+            (cons `(function ,name ,texp)
+                  (loop rest globals)))
+           (((qualifier type name) . rest)
+            (pk 'global qualifier type name)
+            (cons (list qualifier type name)
+                  (loop rest
+                        (extend-env name
+                                    (list (type-descriptor->type type))
+                                    globals)))))))
      `(t ,types (top-level ,bindings* ,body)))
     (_ (error "expected top-level form" program))))
 
@@ -2330,43 +2388,43 @@
   (when (> n 0)
     (display (make-string (* n 2) #\space) port)))
 
-(define (emit:int n version port level)
+(define (emit:int n stage version port level)
   (define temp (unique-identifier))
   (indent level port)
   (format port "int ~a = ~a;\n" temp n)
   (list temp))
 
-(define (emit:float n version port level)
+(define (emit:float n stage version port level)
   (define temp (unique-identifier))
   (indent level port)
   (format port "float ~a = ~a;\n" temp n)
   (list temp))
 
-(define (emit:boolean b version port level)
+(define (emit:boolean b stage version 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 version port level)
+(define (emit:binary-operator type op a b stage version port level)
   (define op*
     (case op
       ((=) '==)
       (else op)))
-  (define a-temp (single-temp (emit-glsl a version port level)))
-  (define b-temp (single-temp (emit-glsl b version port level)))
+  (define a-temp (single-temp (emit-glsl a stage version port level)))
+  (define b-temp (single-temp (emit-glsl b stage version port level)))
   (define temp (unique-identifier))
   (indent level port)
   (format port "~a ~a = ~a ~a ~a;\n"
           (type->glsl type) temp a-temp op* b-temp)
   (list temp))
 
-(define (emit:unary-operator type op a version port level)
+(define (emit:unary-operator type op a stage version port level)
   (define op*
     (case op
       ((not) '!)
       (else op)))
-  (define a-temp (single-temp (emit-glsl a version port level)))
+  (define a-temp (single-temp (emit-glsl a stage version port level)))
   (define temp (unique-identifier))
   (indent level port)
   (format port "~a ~a = ~a(~a);\n"
@@ -2387,10 +2445,11 @@
             types lhs-list rhs-list*))
 
 (define (emit:mov a b port level)
-  (indent level port)
-  (format port "~a = ~a;\n" a b))
+  (when a
+    (indent level port)
+    (format port "~a = ~a;\n" a b)))
 
-(define (emit:function name type params body version port level)
+(define (emit:function name type params body stage version port level)
   (define param-types (function-type-parameters type))
   (define return-types (function-type-returns type))
   (define outputs (unique-identifiers-for-list return-types))
@@ -2412,29 +2471,32 @@
                qualifier (type->glsl type) name)
        (loop rest #f))))
   (display ") {\n" port)
-  (define body-temps (emit-glsl body version port (+ level 1)))
+  (define body-temps (emit-glsl body stage version 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 version port level)
-  (define if-temps (unique-identifiers-for-list (texp-types consequent)))
+(define (emit:if predicate consequent alternate stage version port level)
+  (define if-temps
+    (if (equal? (texp-types consequent) (list type:outputs))
+        '(#f)
+        (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 version port level)))
+    (single-temp (emit-glsl predicate stage version port level)))
   (indent level port)
   (format port "if(~a) {\n" predicate-temp)
   (define consequent-temps
-    (emit-glsl consequent version port (+ level 1)))
+    (emit-glsl consequent stage version 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 version port (+ level 1)))
+    (emit-glsl alternate stage version port (+ level 1)))
   (for-each (lambda (lhs rhs)
               (emit:mov lhs rhs port (+ level 1)))
             if-temps alternate-temps)
@@ -2442,19 +2504,19 @@
   (display "}\n" port)
   if-temps)
 
-(define (emit:values exps version port level)
+(define (emit:values exps stage version port level)
   (append-map (lambda (exp)
-                (emit-glsl exp version port level))
+                (emit-glsl exp stage version port level))
               exps))
 
-(define (emit:let types names exps body version port level)
+(define (emit:let types names exps body stage version port level)
   (define binding-temps
     (map (lambda (exp)
-           (single-temp (emit-glsl exp version port level)))
+           (single-temp (emit-glsl exp stage version 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 version port level))
+  (define body-temps (emit-glsl body stage version port level))
   (define let-temps (unique-identifiers-for-list types))
   (emit:declarations (texp-types body) let-temps body-temps port level)
   let-temps)
@@ -2464,12 +2526,12 @@
     (int->float . float)
     (texture-2d . texture2D)))
 
-(define (emit:primcall type operator args version port level)
+(define (emit:primcall type operator args stage version port level)
   (define operator*
     (or (assq-ref %primcall-map operator) operator))
   (define arg-temps
     (map (lambda (arg)
-           (single-temp (emit-glsl arg version port level)))
+           (single-temp (emit-glsl arg stage version port level)))
          args))
   (define output-temp (unique-identifier))
   (indent level port)
@@ -2480,11 +2542,11 @@
           (string-join (map symbol->string arg-temps) ", "))
   (list output-temp))
 
-(define (emit:call types operator args version port level)
-  (define operator-name (single-temp (emit-glsl operator version port)))
+(define (emit:call types operator args stage version port level)
+  (define operator-name (single-temp (emit-glsl operator stage version port)))
   (define arg-temps
     (map (lambda (arg)
-           (single-temp (emit-glsl arg version port level)))
+           (single-temp (emit-glsl arg stage version port level)))
          args))
   (define output-temps (unique-identifiers-for-list types))
   (emit:declarations types output-temps #f port level)
@@ -2495,8 +2557,8 @@
                        ", "))
   output-temps)
 
-(define (emit:struct-ref type exp field version port level)
-  (define input-temp (single-temp (emit-glsl exp version port level)))
+(define (emit:struct-ref type exp field stage version port level)
+  (define input-temp (single-temp (emit-glsl exp stage version port level)))
   (define output-temp (unique-identifier))
   (indent level port)
   (format port "~a ~a = ~a.~a;\n"
@@ -2506,9 +2568,9 @@
           field)
   (list output-temp))
 
-(define (emit:array-ref type array-exp index-exp version port level)
-  (define array-temp (single-temp (emit-glsl array-exp version port level)))
-  (define index-temp (single-temp (emit-glsl index-exp version port level)))
+(define (emit:array-ref type array-exp index-exp stage version port level)
+  (define array-temp (single-temp (emit-glsl array-exp stage version port level)))
+  (define index-temp (single-temp (emit-glsl index-exp stage version port level)))
   (define output-temp (unique-identifier))
   (indent level port)
   (format port "~a ~a = ~a[~a];\n"
@@ -2518,7 +2580,7 @@
           index-temp)
   (list output-temp))
 
-(define (emit:top-level bindings body version port level)
+(define (emit:top-level bindings body stage version port level)
   (for-each (match-lambda
               (((? top-level-qualifier? qualifier) type-desc name)
                (format port "~a ~a ~a;\n"
@@ -2526,10 +2588,10 @@
                        (type-descriptor->glsl type-desc)
                        name))
               (('function name ('t (type) ('lambda params body)))
-               (emit:function name type params body version port level)))
+               (emit:function name type params body stage version port level)))
             bindings)
   (display "void main() {\n" port)
-  (emit-glsl body version port (+ level 1))
+  (emit-glsl body stage version port (+ level 1))
   (display "}\n" port))
 
 (define %built-in-output-map
@@ -2538,51 +2600,55 @@
     (vertex:clip-distance . gl_ClipDistance)
     (fragment:depth . gl_FragDepth)))
 
-(define (emit:outputs names exps version port level)
+(define (emit:outputs names exps stage version port level)
   (define (output-name name)
     (or (assq-ref %built-in-output-map name) name))
-  (for-each (lambda (name exp)
-              (match (emit-glsl exp version port level)
-                ((temp)
-                 (indent level port)
-                 (format port "~a = ~a;\n"
-                         (output-name name)
-                         temp))))
-            names exps)
+  (if (and (eq? stage 'fragment) (null? names))
+      (begin
+        (indent level port)
+        (format port "discard;\n"))
+      (for-each (lambda (name exp)
+                  (match (emit-glsl exp stage version port level)
+                    ((temp)
+                     (indent level port)
+                     (format port "~a = ~a;\n"
+                             (output-name name)
+                             temp))))
+                names exps))
   '(#f))
 
-(define* (emit-glsl exp version port #:optional (level 0))
+(define* (emit-glsl exp stage version port #:optional (level 0))
   (match exp
     (('t _ (? exact-integer? n))
-     (emit:int n version port level))
+     (emit:int n stage version port level))
     (('t _ (? float? n))
-     (emit:float n version port level))
+     (emit:float n stage version port level))
     (('t _ (? boolean? b))
-     (emit:boolean b version port level))
+     (emit:boolean b stage version port level))
     (('t _ (? symbol? var))
      (list var))
     (('t _ ('if predicate consequent alternate))
-     (emit:if predicate consequent alternate version port level))
+     (emit:if predicate consequent alternate stage version port level))
     (('t _ ('values exps ...))
-     (emit:values exps version port level))
+     (emit:values exps stage version port level))
     (('t types ('let ((names exps) ...) body))
-     (emit:let types names exps body version port level))
+     (emit:let types names exps body stage version port level))
     (('t (type) ('primcall (? binary-operator? op) a b))
-     (emit:binary-operator type op a b version port level))
+     (emit:binary-operator type op a b stage version port level))
     (('t (type) ('primcall (? unary-operator? op) a))
-     (emit:unary-operator type op a version port level))
+     (emit:unary-operator type op a stage version port level))
     (('t (type) ('primcall op args ...))
-     (emit:primcall type op args version port level))
+     (emit:primcall type op args stage version port level))
     (('t types ('call operator args ...))
-     (emit:call types operator args version port level))
+     (emit:call types operator args stage version port level))
     (('t (type) ('struct-ref exp field))
-     (emit:struct-ref type exp field version port level))
+     (emit:struct-ref type exp field stage version port level))
     (('t (type) ('array-ref array-exp index-exp))
-     (emit:array-ref type array-exp index-exp version port level))
+     (emit:array-ref type array-exp index-exp stage version port level))
     (('t _ ('outputs (names exps) ...))
-     (emit:outputs names exps version port level))
+     (emit:outputs names exps stage version port level))
     (('t _ ('top-level (bindings ...) body))
-     (emit:top-level bindings body version port level))))
+     (emit:top-level bindings body stage version port level))))
 
 
 ;;;
@@ -2657,7 +2723,7 @@
       (let* ((propagated (propagate-constants expanded (empty-env)))
              (hoisted (hoist-functions* propagated))
              (inferred (infer-types hoisted stage))
-             (resolved (resolve-overloads inferred)))
+             (resolved (resolve-overloads inferred stage)))
         (values resolved global-map (unique-identifier-counter))))))
 
 (define (specs->globals specs)
@@ -2666,6 +2732,7 @@
           (make-seagull-global qualifier type-desc name)))
        specs))
 
+(use-modules (ice-9 pretty-print))
 ;; Using syntax-case allows us to compile shaders to their fully typed
 ;; intermediate form at compile time, leaving only GLSL emission for
 ;; runtime.
@@ -2685,6 +2752,7 @@
                             #:inputs inputs
                             #:outputs outputs
                             #:uniforms uniforms))
+         (pretty-print compiled)
          (with-syntax ((inputs (datum->syntax x inputs))
                        (outputs (datum->syntax x outputs))
                        (uniforms (datum->syntax x uniforms))
@@ -2784,8 +2852,17 @@
          (fragment-uniform-map (map-globals (seagull-module-uniforms fragment)
                                             fragment-global-map))
          ;; Give new names to the fragment uniforms so that the names
-         ;; do not clash with vertex globals.
-         (fragment-uniform-alpha-map (alpha-rename fragment-uniform-map))
+         ;; do not clash with vertex globals and also that any
+         ;; uniforms in the vertex shader have the *same* name in the
+         ;; fragment shader.
+         (fragment-uniform-alpha-map
+          (map (match-lambda
+                 ((original-name . alpha-name)
+                  (cons alpha-name
+                        (or (assq-ref vertex-uniform-alpha-map
+                                      (assq-ref vertex-uniform-map original-name))
+                            (unique-identifier)))))
+               fragment-uniform-map))
          ;; This one is a little messy but what's happening is that
          ;; the GLSL name for each fragment output is mapped to the
          ;; respective renamed input.  Vertex shader output names must
@@ -2843,11 +2920,11 @@
     (define vertex-glsl
       (call-with-output-string
         (lambda (port)
-          (emit-glsl vertex* version port))))
+          (emit-glsl vertex* 'fragment version port))))
     (define fragment-glsl
       (call-with-output-string
         (lambda (port)
-          (emit-glsl fragment* version port))))
+          (emit-glsl fragment* 'fragment version port))))
     (display vertex-glsl)
     (newline)
     (display fragment-glsl)