Fix overload issues enough that the 9-patch shader compiles.

1 files changed, 92 insertions, 75 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index cc1df7f..4e271ff 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -37,6 +37,15 @@
 ;; - No closures
 ;; - No recursion
 ;;
+;; TODO:
+;; - Loops
+;; - (define ...) form
+;; - 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)
+;;
 ;;; Code:
 (define-module (chickadee graphics seagull)
   #:use-module (chickadee graphics shader)
@@ -67,12 +76,6 @@
 ;; in a program that is one step closer to being directly emitted to
 ;; GLSL code.
 
-;; TODO:
-;; - Loops
-;; - Scheme shader type -> GLSL struct translation
-;; - Dead code elimination (error when a uniform is eliminated)
-;; - Multiple GLSL versions
-
 
 ;;;
 ;;; Compiler helpers
@@ -829,17 +832,23 @@
      `(top-level ,new-bindings ,exp))))
 
 (define (hoist-functions* exp)
-  (define-values (exp* env)
+  (define-values (exp* function-env)
     (hoist-functions exp))
   (define top-level-vars
-    (append (env-names env) '(+ - * /)))
+    (append (env-names function-env)
+            (map (match-lambda
+                   ((_ _ name) name))
+                 (match exp*
+                   (('top-level bindings _)
+                    bindings)
+                   (_ '())))))
   (env-for-each (lambda (name exp)
                   (check-free-variables exp '() top-level-vars))
-                env)
+                function-env)
   (define bindings
     (env-map (lambda (name func)
                `(function ,name ,func))
-             env))
+             function-env))
   (maybe-merge-top-levels bindings exp*))
 
 
@@ -1892,7 +1901,7 @@
            (((? top-level-qualifier? qualifier) type-name name _)
             (list qualifier type-name name))
            (('function _ name exp)
-            `(function ,name ,exp)))
+            `(function ,name ,(apply-substitutions-to-exp exp combined-subs))))
          qualifiers type-names names exps))
   (values (texp (texp-types body*)
                 `(top-level ,bindings* ,body*))
@@ -2181,72 +2190,64 @@
 ;; of non-quantified function type specifications, one for each unique
 ;; type of call in the program.
 
-;; Check if the substitutions in a and b do not contain
-;; contradictions.
-(define (consistent? a b)
-  (every (match-lambda
-           ((from . to)
-            (let ((other (assq-ref b from)))
-              (or (not other) (equal? to other)))))
-         a))
+(define (find-signatures:list name texps)
+  (append-map (lambda (texp)
+                (find-signatures name texp))
+              texps))
 
-;; Compute all the valid permutations of substitutions that a
-;; predicate could produce.
-(define (possible-substitutions pred structs)
-  (match pred
-    (#t '())
-    (('substitute from to)
-     (list (list (cons from to))))
-    (('= a b)
-     (list (list (cons a b))))
-    (('struct-field struct-var field field-var)
-     (filter-map (lambda (struct)
-                   (let ((field-type (struct-type-ref struct field)))
-                     (and field-type
-                          (list (cons struct-var struct)
-                                (cons field-var field-type)))))
-                 structs))
-    (('struct-field struct-var field field-var)
-     (filter-map (lambda (struct)
-                   (let ((field-type (struct-type-ref struct field)))
-                     (and field-type
-                          (list (cons struct-var struct)
-                                (cons field-var field-type)))))
-                 structs))
-    (('or preds ...)
-     (concatenate (map (lambda (pred)
-                         (possible-substitutions pred structs))
-                       preds)))
-    (((or 'and 'list) preds ...)
-     (let loop ((in (map (lambda (pred)
-                           (possible-substitutions pred structs))
-                         preds)))
-       (match in
-         (() '())
-         ((options . rest)
-          (define rest-options (loop rest))
-          (append-map (lambda (a)
-                        (if (null? rest-options)
-                            (list a)
-                            (filter-map (lambda (b)
-                                          (and (consistent? a b)
-                                               (compose-substitutions a b)))
-                                        rest-options)))
-                      options)))))))
-
-(define (find-structs exp)
+(define (find-signatures:if name predicate consequent alternate)
+  (append (find-signatures name predicate)
+          (find-signatures name consequent)
+          (find-signatures name alternate)))
+
+(define (find-signatures:let name binding-texps body)
+  (append (find-signatures:list name binding-texps)
+          (find-signatures name body)))
+
+(define (find-signatures:array-ref name array index)
+  (append (find-signatures name array)
+          (find-signatures name index)))
+
+(define (find-signatures name texp)
+  (match (texp-exp texp)
+    ((or (? immediate?) (? symbol?))
+     '())
+    (('if predicate consequent alternate)
+     (find-signatures:if name predicate consequent alternate))
+    (('let ((_ exps) ...) body)
+     (find-signatures:let name exps body))
+    (('values exps ...)
+     (find-signatures:list name exps))
+    (('primcall _ args ...)
+     (find-signatures:list name args))
+    (('call operator args ...)
+     (cons (if (eq? (texp-exp operator) name)
+               (function-type (map single-type args)
+                              (texp-types texp)))
+           (find-signatures:list name args)))
+    (('struct-ref struct _)
+     (find-signatures name struct))
+    (('array-ref array index)
+     (find-signatures:array-ref name array index))
+    (('outputs (_ exps) ...)
+     (find-signatures:list name exps))
+    (_ (error "uh oh" texp))))
+
+(define (vars->subs exp env)
   (match exp
-    ((? struct-type?)
-     (list exp))
-    ((exps ...)
-     (append-map find-structs exps))
+    (('t ((? variable-type? tvar)) (? symbol? name))
+     (list (cons tvar (lookup name env))))
+    ((head . rest)
+     (delete-duplicates
+      (append (vars->subs head env)
+              (vars->subs rest env))))
     (_ '())))
 
 (define (resolve-overloads program)
   ;; 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.
-  (define structs (delete-duplicates (find-structs program)))
+  ;;(define structs (delete-duplicates (find-structs program)))
   (match program
     (('t types ('top-level bindings body))
      (define bindings*
@@ -2256,16 +2257,32 @@
            ((('function name ('t ((? type-scheme? type)) func)) . rest)
             (define qtype (type-scheme-ref type))
             (define func-type (qualified-type-ref qtype))
-            (append (map (lambda (subs)
+            (append (map (lambda (call-type)
+                           (define subs
+                             (unify func-type call-type))
                            (define type*
                              (apply-substitutions-to-type func-type subs))
+                           (define params
+                             (match func
+                               (('lambda (params ...) _)
+                                params)))
+                           (define env
+                             (fold extend-env (empty-env) params
+                                   (function-type-parameters type*)))
+                           (define subs*
+                             (compose-substitutions subs
+                                                    (vars->subs func env)))
                            (define func*
-                             (apply-substitutions-to-exp func subs))
+                             (apply-substitutions-to-exp func subs*))
                            `(function ,name (t (,type*) ,func*)))
                          (delete-duplicates
-                          (possible-substitutions
-                           (qualified-type-predicate qtype)
-                           structs)))
+                          (find-signatures name body)
+                          ;; (append (append-map (match-lambda
+                          ;;                       (('function name lambda*)
+                          ;;                        (find-signatures name lambda*)))
+                          ;;                     rest)
+                          ;;         (find-signatures name body))
+                          ))
                     (loop rest)))
            ((binding . rest)
             (cons binding (loop rest))))))
@@ -2415,7 +2432,7 @@
               (emit:mov lhs rhs port (+ level 1)))
             if-temps consequent-temps)
   (indent level port)
-  (display "else {\n" port)
+  (display "} else {\n" port)
   (define alternate-temps
     (emit-glsl alternate version port (+ level 1)))
   (for-each (lambda (lhs rhs)