Add struct types.

1 files changed, 283 insertions, 114 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index bb7008f..ca11ec3 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -292,6 +292,18 @@
 (define (expand:values exps stage env)
   `(values ,@(expand:list exps stage env)))
 
+(define (expand:-> exp members stage env)
+  (define exp* (expand exp stage env))
+  (match members
+    ((member . rest)
+     (let loop ((members rest)
+                (prev `(struct-ref ,exp* ,member)))
+       (match members
+         (() prev)
+         ((next . rest)
+          (loop `(struct-ref ,prev ,next)
+                rest)))))))
+
 ;; Arithmetic operators, in true Lisp fashion, can accept many
 ;; arguments.  + and * accept 0 or more. - and / accept one or more.
 ;; The expansion pass transforms all such expressions into binary
@@ -437,6 +449,8 @@
                  body)
      (expand:top-level qualifiers types names body stage env))
     ;; Macros:
+    (('-> exp (? symbol? members) ..1)
+     (expand:-> exp members stage env))
     (('let* (bindings ...) body)
      (expand:let* bindings body stage env))
     (('+ args ...)
@@ -526,6 +540,9 @@
                   (propagate-constants arg env))
                 args)))
 
+(define (propagate:struct-ref exp member env)
+  `(struct-ref ,(propagate-constants exp env) ,member))
+
 ;; The division of two integers can result in a rational, non-integer,
 ;; such as 1/2.  This isn't how integer division works in GLSL, so we
 ;; need to round the result to an integer.
@@ -576,6 +593,8 @@
      (propagate:primcall operator args env))
     (('call operator args ...)
      (propagate:call operator args env))
+    (('struct-ref exp member)
+     (propagate:struct-ref exp member env))
     (('outputs (names exps) ...)
      (propagate:outputs names exps env))
     (('top-level inputs body)
@@ -637,6 +656,8 @@
     ((or ('primcall _ args ...)
          ('call args ...))
      (check-free-variables-in-list args bound-vars top-level-vars))
+    (('struct-ref exp member)
+     (check-free-variables exp bound-vars top-level-vars))
     (('outputs (names exps) ...)
      (check-free-variables-in-list exps bound-vars top-level-vars))
     (('top-level ((_ _ names) ...) body)
@@ -695,8 +716,7 @@
 (define (hoist:lambda params body)
   (define-values (body* body-env)
     (hoist-functions body))
-  (values `(lambda ,params ,body*)
-          body-env))
+  (values `(lambda ,params ,body*) body-env))
 
 (define (hoist:values exps)
   (define-values (exps* exp-env)
@@ -705,13 +725,15 @@
 
 (define (hoist:primcall operator args)
   (define-values (args* args-env) (hoist:list args))
-  (values `(primcall ,operator ,@args*)
-          args-env))
+  (values `(primcall ,operator ,@args*) args-env))
 
 (define (hoist:call args)
   (define-values (args* args-env) (hoist:list args))
-  (values `(call ,@args*)
-          args-env))
+  (values `(call ,@args*) args-env))
+
+(define (hoist:struct-ref exp member)
+  (define-values (exp* exp-env) (hoist-functions exp))
+  (values `(struct-ref ,exp* ,member) exp-env))
 
 (define (hoist:top-level inputs body)
   (define-values (body* body-env)
@@ -744,6 +766,8 @@
      (hoist:primcall operator args))
     (('call args ...)
      (hoist:call args))
+    (('struct-ref exp member)
+     (hoist:struct-ref exp member))
     (('outputs (names exps) ...)
      (hoist:outputs names exps))
     (('top-level inputs body)
@@ -794,27 +818,36 @@
   (match type
     (('primitive name) name)))
 
-(define int-type (primitive-type 'int))
-(define float-type (primitive-type 'float))
-(define bool-type (primitive-type 'bool))
-(define vec2-type (primitive-type 'vec2))
-(define vec3-type (primitive-type 'vec3))
-(define vec4-type (primitive-type 'vec4))
-(define mat3-type (primitive-type 'mat3))
-(define mat4-type (primitive-type 'mat4))
-(define sampler-2d-type (primitive-type 'sampler-2d))
+;; Outputs type:
+(define outputs-type '(outputs))
 
-(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)
-    ((sampler-2d) sampler-2d-type)))
+(define (outputs-type? obj)
+  (match obj
+    (('outputs) #t)
+    (_ #f)))
+
+;; Struct type:
+(define (struct-type name members)
+  `(struct ,name ,members))
+
+(define (struct-type? obj)
+  (match obj
+    (('struct _ _) #t)
+    (_ #f)))
+
+(define (struct-type-name type)
+  (match type
+    (('struct name _) name)))
+
+(define (struct-type-members type)
+  (match type
+    (('struct _ members) members)))
+
+(define (struct-type-ref type member)
+  (assq-ref (struct-type-members type) member))
+
+(define-syntax-rule (define-struct-type (var-name name) (types names) ...)
+  (define var-name (struct-type 'name (list (cons 'names types) ...))))
 
 ;; Type variables:
 (define unique-type-variable-counter (make-parameter 0))
@@ -860,43 +893,50 @@
     (('-> _ returns) returns)))
 
 ;; For all types:
-(define (for-all-type quantifiers type predicate)
-  `(for-all ,quantifiers ,type ,predicate))
+(define (for-all-type quantifiers type)
+  `(for-all ,quantifiers ,type))
 
 (define (for-all-type? obj)
   (match obj
-    (('for-all _ _ _) #t)
+    (('for-all _ _) #t)
     (_ #f)))
 
 (define (for-all-type-quantifiers type)
   (match type
-    (('for-all q _ _) q)))
+    (('for-all q _) q)))
 
 (define (for-all-type-ref type)
   (match type
-    (('for-all _ t _) t)))
-
-(define (for-all-type-predicate type)
-  (match type
-    (('for-all _ _ p) p)))
+    (('for-all _ t) t)))
 
-;; Outputs type:
-(define outputs-type '(outputs))
+;; Qualified types:
+(define (qualified-type type pred)
+  `(qualified ,type ,pred))
 
-(define (outputs-type? obj)
+(define (qualified-type? obj)
   (match obj
-    (('outputs) #t)
+    (('qualified _ _) #t)
     (_ #f)))
 
+(define (qualified-type-ref type)
+  (match type
+    (('qualified type _) type)))
+
+(define (qualified-type-predicate type)
+  (match type
+    (('qualified _ pred) pred)))
+
 (define (type? obj)
   (or (primitive-type? obj)
       (type-variable? obj)
       (function-type? obj)
+      (struct-type? obj)
       (outputs-type? obj)))
 
 (define (apply-substitution-to-type type from to)
   (cond
    ((or (primitive-type? type)
+        (struct-type? type)
         (outputs-type? type))
     type)
    ((type-variable? type)
@@ -911,6 +951,11 @@
           (function-type-returns type))))
    ((for-all-type? type)
     type)
+   ;; ((qualified-type? type)
+   ;;  (qualified-type (apply-substitution-to-type
+   ;;                   (qualified-type-ref type) from to)
+   ;;                  (apply-substitution-to-predicate
+   ;;                   (qualified-type-predicate type) from to)))
    (else (error "invalid type" type))))
 
 (define (apply-substitutions-to-type type subs)
@@ -1072,6 +1117,9 @@
                  (predicate:substitute from to)))
               subs)))
 
+(define (predicate:struct-has? struct member var)
+  `(struct-has? ,struct ,member ,var))
+
 (define (compose-predicates a b)
   (cond
    ((and (eq? a #t) (eq? b #t))
@@ -1110,7 +1158,11 @@
                    preds)))
     (('substitute a b)
      `(substitute ,(apply-substitution-to-type a from to)
-                  ,(apply-substitution-to-type b from to)))))
+                  ,(apply-substitution-to-type b from to)))
+    (('struct-has? struct member var)
+     `(struct-has? ,(apply-substitution-to-type struct from to)
+                   ,member
+                   ,var))))
 
 (define (apply-substitutions-to-predicate pred subs)
   (env-fold (lambda (from to pred*)
@@ -1271,7 +1323,11 @@
     ;; Substitution always succeeds and returns a substitution to be
     ;; carried forward in the inference process.
     (('substitute a b)
-     (values #t (list (cons a b))))))
+     (values #t (list (cons a b))))
+    (('struct-has? struct member var)
+     (if (struct-type? struct)
+         (values #t (list (cons var (struct-type-ref struct member))))
+         (values pred '())))))
 
 (define (eval-predicate* pred subs)
   (define-values (new-pred pred-subs)
@@ -1279,7 +1335,7 @@
      (apply-substitutions-to-predicate pred subs)))
   ;; TODO: Get information about *why* the predicate failed.
   (unless new-pred
-    (error "predicate failure"))
+    (error "predicate failure" pred))
   ;; Recursively evaluate the predicate, applying the substitutions
   ;; generated by the last evaluation, until it cannot be simplified
   ;; any further.
@@ -1289,7 +1345,9 @@
 
 (define* (free-variables-in-type type)
   (cond
-   ((primitive-type? type) '())
+   ((or (primitive-type? type)
+        (struct-type? type))
+    '())
    ((type-variable? type) (list type))
    ((function-type? type)
     (let ((params (function-type-parameters type)))
@@ -1349,7 +1407,10 @@
                  preds))
     (('substitute a b)
      (append (free-variables-in-type a)
-             (free-variables-in-type b)))))
+             (free-variables-in-type b)))
+    (('struct-has? struct member var)
+     (append (free-variables-in-type struct)
+             (free-variables-in-type var)))))
 
 ;; Quantified variables:
 ;; - Unused parameters
@@ -1363,7 +1424,7 @@
                          (free-variables-in-env env))
         (() type)
         ((quantifiers ...)
-         (for-all-type quantifiers type pred)))
+         (for-all-type quantifiers (qualified-type type pred))))
       type))
 
 (define (instantiate for-all)
@@ -1372,9 +1433,16 @@
             (extend-env var (fresh-type-variable) env))
           (empty-env)
           (for-all-type-quantifiers for-all)))
+  (define type (for-all-type-ref for-all))
   (values
-   (apply-substitutions-to-type (for-all-type-ref for-all) subs)
-   (apply-substitutions-to-predicate (for-all-type-predicate for-all) subs)))
+   (apply-substitutions-to-type (if (qualified-type? type)
+                                    (qualified-type-ref type)
+                                    type)
+                                subs)
+   (if (qualified-type? type)
+       (apply-substitutions-to-predicate (qualified-type-predicate type)
+                                         subs)
+       #t)))
 
 (define (maybe-instantiate types)
   (define types+preds
@@ -1391,6 +1459,11 @@
       '()
       (error "primitive type mismatch" a b)))
 
+(define (unify:structs a b)
+  (if (equal? a b)
+      '()
+      (error "struct type mismatch" a b)))
+
 (define (unify:variable a b)
   (cond
    ((eq? a b)
@@ -1422,6 +1495,8 @@
   (match (list a b)
     (((? primitive-type? a) (? primitive-type? b))
      (unify:primitives a b))
+    (((? struct-type? a) (? struct-type? b))
+     (unify:structs a b))
     ((or ((? type-variable? a) b)
          (b (? type-variable? a)))
      (unify:variable a b))
@@ -1429,6 +1504,8 @@
      (unify:functions a b))
     (((? outputs-type?) (? outputs-type?))
      '())
+    (((? type?) (? type?))
+     (error "type mismatch" a b))
     ((() ())
      '())
     (((a rest-a ...) (b rest-b ...))
@@ -1527,7 +1604,7 @@
     (eval-predicate* body-pred body-subs))
   (values (texp (list (generalize
                        (function-type (apply-substitutions-to-types param-types
-                                                                    body-subs)
+                                                                    subs)
                                       (texp-types body*))
                        pred env))
                 `(lambda ,params ,body*))
@@ -1604,6 +1681,17 @@
           combined-subs
           pred))
 
+(define (infer:struct-ref exp member env)
+  (define-values (exp* exp-subs exp-pred)
+    (infer-exp exp env))
+  (define exp-type (single-type exp*))
+  (define tvar (fresh-type-variable))
+  (values (texp (list tvar)
+                `(struct-ref ,exp* ,member))
+          exp-subs
+          (compose-predicates exp-pred
+                              (predicate:struct-has? exp-type member tvar))))
+
 (define (infer:let names exps body env)
   (define-values (exps* exp-subs exp-pred)
     (infer:list exps env))
@@ -1643,31 +1731,37 @@
   ;; Eval predicate.
   (define-values (pred combined-subs)
     (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs)))
-  (values (texp (map single-type exps*)
+  (values (texp (list outputs-type)
                 `(outputs ,@(map list names exps*)))
           combined-subs
           pred))
 
 (define (infer:top-level bindings body env)
-  (define (infer-bindings bindings texps subs pred)
+  (define (infer-bindings bindings texps subs pred env)
     (match bindings
       (()
-       (values (reverse texps) subs pred))
-      ((('function _ exp) . rest)
+       (values (reverse texps) subs pred env))
+      ((('function name exp) . rest)
        (define-values (texp subs* pred*)
          (infer-exp exp env))
        (define-values (new-pred combined-subs)
          (eval-predicate* (compose-predicates pred pred*)
                           (compose-substitutions subs subs*)))
+       (define env*
+         (apply-substitutions-to-env (extend-env name (texp-types texp) env)
+                                     combined-subs))
        (infer-bindings rest
                        (cons texp texps)
                        combined-subs
-                       new-pred))
-      (((_ type-name _) . rest)
+                       new-pred
+                       env*))
+      (((_ type-name name) . rest)
+       (define types (list (type-name->type type-name)))
        (infer-bindings rest
-                       (cons (list (type-name->type type-name)) texps)
+                       (cons types texps)
                        subs
-                       pred))))
+                       pred
+                       (extend-env name types env)))))
   (define qualifiers (map first bindings))
   (define names
     (map (match-lambda
@@ -1679,19 +1773,8 @@
            (((? top-level-qualifier?) type-name _) type-name)
            (_ #f))
          bindings))
-  (define-values (exps exp-subs exp-pred)
-    (infer-bindings bindings '() '() #t))
-  (define exp-types
-    (map (lambda (x)
-           (if (texp? x)
-               (texp-types x)
-               x))
-         exps))
-  (define env*
-    (fold extend-env
-          (apply-substitutions-to-env env exp-subs)
-          names
-          exp-types))
+  (define-values (exps exp-subs exp-pred env*)
+    (infer-bindings bindings '() '() #t env))
   (define-values (body* body-subs body-pred)
     (infer-exp body env*))
   (define-values (pred combined-subs)
@@ -1731,25 +1814,62 @@
      (infer:primitive-call operator args env))
     (('call operator args ...)
      (infer:call operator args env))
+    (('struct-ref exp member)
+     (infer:struct-ref exp member env))
     (('outputs (names exps) ...)
      (infer:outputs names exps env))
     (('top-level bindings body)
      (infer:top-level bindings body env))
     (_ (error "unknown form" exp))))
 
+;; Built-in types:
+(define int-type (primitive-type 'int))
+(define float-type (primitive-type 'float))
+(define bool-type (primitive-type 'bool))
+(define-struct-type (vec2-type vec2)
+  (float-type x)
+  (float-type y))
+(define-struct-type (vec3-type vec3)
+  (float-type x)
+  (float-type y)
+  (float-type z))
+(define-struct-type (vec4-type vec4)
+  (float-type x)
+  (float-type y)
+  (float-type z)
+  (float-type w))
+;; TODO: Matrices are technically array types in GLSL, but we are
+;; choosing to represent them opaquely for now to keep things simple.
+(define mat3-type (primitive-type 'mat3))
+(define mat4-type (primitive-type 'mat4))
+(define sampler-2d-type (primitive-type 'sampler-2d))
+
+(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)
+    ((sampler-2d) sampler-2d-type)))
+
 (define add/sub-type
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a a) (list a))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type)
-            (predicate:= a vec2-type)
-            (predicate:= a vec3-type)
-            (predicate:= a vec4-type)
-            (predicate:= a mat3-type)
-            (predicate:= a mat4-type))))))
+           (qualified-type
+            (function-type (list a a) (list a))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)
+             (predicate:= a vec2-type)
+             (predicate:= a vec3-type)
+             (predicate:= a vec4-type)
+             (predicate:= a mat3-type)
+             (predicate:= a mat4-type)))))))
 
 (define-syntax-rule (a+b->c (ta tb tc) ...)
   (let ((a (fresh-type-variable))
@@ -1757,12 +1877,13 @@
         (c (fresh-type-variable)))
     (list (for-all-type
            (list a b c)
-           (function-type (list a b) (list c))
-           (predicate:or
-            (predicate:and (predicate:= a ta)
-                           (predicate:= b tb)
-                           (predicate:substitute c tc))
-            ...)))))
+           (qualified-type
+            (function-type (list a b) (list c))
+            (predicate:or
+             (predicate:and (predicate:= a ta)
+                            (predicate:= b tb)
+                            (predicate:substitute c tc))
+             ...))))))
 
 (define mul-type
   (a+b->c (int-type int-type int-type)
@@ -1777,11 +1898,11 @@
           (vec4-type float-type vec4-type)
           (float-type vec4-type vec4-type)
           (mat3-type mat3-type mat3-type)
-          (mat3-type float-type mat3-type)
-          (float-type mat3-type mat3-type)
+          (mat3-type vec3-type mat3-type)
+          (vec3-type mat3-type mat3-type)
           (mat4-type mat4-type mat4-type)
-          (mat4-type float-type mat4-type)
-          (float-type mat4-type mat4-type)))
+          (mat4-type vec4-type vec4-type)
+          (vec4-type mat4-type vec4-type)))
 
 (define div-type
   (a+b->c (int-type int-type int-type)
@@ -1805,10 +1926,11 @@
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a a) (list bool-type))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type))))))
+           (qualified-type
+            (function-type (list a a) (list bool-type))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)))))))
 
 (define not-type
   (list (function-type (list bool-type) (list bool-type))))
@@ -1829,28 +1951,31 @@
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a) (list a))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type))))))
+           (qualified-type
+            (function-type (list a) (list a))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)))))))
 
 (define sqrt-type
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a) (list a))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type))))))
+           (qualified-type
+            (function-type (list a) (list a))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)))))))
 
 (define min/max-type
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a a) (list a))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type))))))
+           (qualified-type
+            (function-type (list a a) (list a))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)))))))
 
 (define trigonometry-type
   (list (function-type (list float-type) (list float-type))))
@@ -1859,10 +1984,11 @@
   (let ((a (fresh-type-variable)))
     (list (for-all-type
            (list a)
-           (function-type (list a a) (list a))
-           (predicate:or
-            (predicate:= a int-type)
-            (predicate:= a float-type))))))
+           (qualified-type
+            (function-type (list a a) (list a))
+            (predicate:or
+             (predicate:= a int-type)
+             (predicate:= a float-type)))))))
 
 (define texture-2d-ref-type
   (list (function-type (list sampler-2d-type vec2-type)
@@ -1928,17 +2054,28 @@
 
 ;; Compute all the valid permutations of substitutions that a
 ;; predicate could produce.
-(define (possible-substitutions pred)
+(define (possible-substitutions pred structs)
   (match pred
     (#t '())
     (('substitute from to)
      (list (list (cons from to))))
     (('= a b)
      (list (list (cons a b))))
+    (('struct-has? struct-var member member-var)
+     (filter-map (lambda (struct)
+                   (let ((member-type (struct-type-ref struct member)))
+                     (and member-type
+                          (list (cons struct-var struct)
+                                (cons member-var member-type)))))
+                 structs))
     (('or preds ...)
-     (concatenate (map possible-substitutions preds)))
+     (concatenate (map (lambda (pred)
+                         (possible-substitutions pred structs))
+                       preds)))
     (((or 'and 'list) preds ...)
-     (let loop ((in (map possible-substitutions preds)))
+     (let loop ((in (map (lambda (pred)
+                           (possible-substitutions pred structs))
+                         preds)))
        (match in
          (() '())
          ((options . rest)
@@ -1952,7 +2089,19 @@
                                         rest-options)))
                       options)))))))
 
+(define (find-structs exp)
+  (match exp
+    ((? struct-type?)
+     (list exp))
+    ((exps ...)
+     (append-map find-structs exps))
+    (_ '())))
+
 (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)))
   (match program
     (('t types ('top-level bindings body))
      (define bindings*
@@ -1960,7 +2109,8 @@
          (match bindings
            (() '())
            ((('function name ('t ((? for-all-type? type)) func)) . rest)
-            (define func-type (for-all-type-ref type))
+            (define qtype (for-all-type-ref type))
+            (define func-type (qualified-type-ref qtype))
             (append (map (lambda (subs)
                            (define type*
                              (apply-substitutions-to-type func-type subs))
@@ -1968,7 +2118,9 @@
                              (apply-substitutions-to-exp func subs))
                            `(function ,name (t (,type*) ,func*)))
                          (delete-duplicates
-                          (possible-substitutions (for-all-type-predicate type))))
+                          (possible-substitutions
+                           (qualified-type-predicate qtype)
+                           structs)))
                     (loop rest)))
            ((binding . rest)
             (cons binding (loop rest))))))
@@ -1983,7 +2135,9 @@
 ;; Transform a fully typed Seagull program into a string of GLSL code.
 
 (define (type-name type)
-  (primitive-type-name type))
+  (if (struct-type? type)
+      (struct-type-name type)
+      (primitive-type-name type)))
 
 (define (single-temp temps)
   (match temps
@@ -2157,6 +2311,19 @@
                        ", "))
   output-temps)
 
+(define (emit:struct-ref type exp member version port level)
+  (define input-temp
+    (match (emit-glsl exp version port level)
+      ((temp) temp)))
+  (define output-temp (unique-identifier))
+  (indent level port)
+  (format port "~a ~a = ~a.~a;\n"
+          (type-name type)
+          output-temp
+          input-temp
+          member)
+  (list output-temp))
+
 (define %type-name-map
   '((sampler-2d . sampler2D)))
 
@@ -2215,6 +2382,8 @@
      (emit:primcall type op args version port level))
     (('t types ('call operator args ...))
      (emit:call types operator args version port level))
+    (('t (type) ('struct-ref exp member))
+     (emit:struct-ref type exp member version port level))
     (('t _ ('outputs (names exps) ...))
      (emit:outputs names exps version port level))
     (('t _ ('top-level (bindings ...) body))