Add let-values and let*-values.

1 files changed, 203 insertions, 14 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index e72a796..ef6ec1f 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -308,6 +308,23 @@
              (bindings* (map list (lookup-all names env*) exps*)))
         `(let ,bindings* ,(expand `(begin ,@body) stage env*)))))
 
+(define (expand:let-values names exps body stage env)
+  (if (null? names)
+      (expand body stage env)
+      (let* ((exps* (map (lambda (exp)
+                           (expand exp stage env))
+                         exps))
+             (env* (fold (lambda (names* env*)
+                          (compose-envs (alpha-convert names*) env*))
+                         env
+                         names))
+             (bindings* (map list
+                             (map (lambda (names*)
+                                    (lookup-all names* env*))
+                                  names)
+                             exps*)))
+        `(let-values ,bindings* ,(expand `(begin ,@body) stage env*)))))
+
 (define (expand:let* bindings body stage env)
   (match bindings
     (() (expand body stage env))
@@ -317,6 +334,15 @@
              stage
              env))))
 
+(define (expand:let*-values bindings body stage env)
+  (match bindings
+    (() (expand body stage env))
+    ((binding . rest)
+     (expand `(let-values (,binding)
+                (let*-values ,rest ,body))
+             stage
+             env))))
+
 (define (expand:lambda params body stage env)
   (define env* (compose-envs (alpha-convert params) env))
   (define params* (lookup-all params env*))
@@ -509,6 +535,8 @@
      (expand:if predicate consequent alternate stage env))
     (('let (((? symbol? names) exps) ...) body ...)
      (expand:let names exps body stage env))
+    (('let-values ((((? symbol? names) ...) exps) ...) body ...)
+     (expand:let-values names exps body stage env))
     (('lambda ((? symbol? params) ...) body ...)
      (expand:lambda params body stage env))
     (('values exps ...)
@@ -527,6 +555,8 @@
      (expand:begin body stage env))
     (('let* (bindings ...) body)
      (expand:let* bindings body stage env))
+    (('let*-values (bindings ...) body)
+     (expand:let*-values bindings body stage env))
     (('+ args ...)
      (expand:+ args stage env))
     (('- args ...)
@@ -568,6 +598,9 @@
 ;; have constant arguments.  This will make the type inferencer's job
 ;; a bit easier.
 
+(define (simplify:list exps env)
+  (map (lambda (exp) (simplify-exp exp env)) exps))
+
 (define (simplify:if predicate consequent alternate env)
   `(if ,(simplify-exp predicate env)
        ,(simplify-exp consequent env)
@@ -577,15 +610,10 @@
   `(lambda ,params ,(simplify-exp body env)))
 
 (define (simplify:values exps env)
-  `(values ,@(map (lambda (exp)
-                    (simplify-exp exp env))
-                  exps)))
+  `(values ,@(simplify:list exps env)))
 
 (define (simplify:let names exps body env)
-  (define exps*
-    (map (lambda (exp)
-           (simplify-exp exp env))
-         exps))
+  (define exps* (simplify:list exps env))
   ;; Extend environment with known constants.
   (define env*
     (fold (lambda (name exp env*)
@@ -624,6 +652,47 @@
 (define (simplify:array-ref array-exp index-exp env)
   `(array-ref ,(simplify-exp array-exp env)
               ,(simplify-exp index-exp env)))
+(define (simplify:let-values names exps body env)
+  (define exps* (simplify:list exps env))
+  ;; Extend environment with known constants.
+  (define env*
+    (fold (lambda (names exp env)
+            (match exp
+              ((? immediate?)
+               (match names
+                 ((name)
+                  (extend-env name exp env))))
+              (('values vals ...)
+               (fold (lambda (name val env)
+                       (if (immediate? val)
+                           (extend-env name val env)
+                           env))
+                     env names vals))
+              (_ env)))
+          env names exps*))
+  ;; Drop all bindings for constant expressions.
+  (define bindings
+    (filter-map (lambda (names exp)
+                  (match exp
+                    ((? immediate?) #f)
+                    (('values vals ...)
+                     (define-values (names* exps*)
+                       (unzip2
+                        (filter-map (lambda (name val)
+                                      (if (immediate? val)
+                                          #f
+                                          (list name val)))
+                                    names vals)))
+                     (if (null? names*)
+                         #f
+                         (list names* exps*)))
+                    (_ (list names exp))))
+                names exps*))
+  ;; If there are no bindings left, remove the 'let' entirely.
+  (if (null? bindings)
+      (simplify-exp body env*)
+      `(let-values ,bindings
+         ,(simplify-exp body env*))))
 
 ;; 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
@@ -671,6 +740,8 @@
      (simplify:let names exps body env))
     (('primcall (and (or '+ '- '* '/) op) x y)
      (simplify:arithmetic op x y env))
+    (('let-values ((names exps) ...) body)
+     (simplify:let-values names exps body env))
     (('primcall operator args ...)
      (simplify:primcall operator args env))
     (('call operator args ...)
@@ -723,7 +794,7 @@
      (unused-variable? var body))
     (('values exps ...)
      (unused-in-list? exps))
-    (('let ((names exps) ...) body)
+    (((or 'let 'let-values) ((names exps) ...) body)
      (and (unused-in-list? exps)
           (unused-variable? var body)))
     (('primcall operator args ...)
@@ -756,16 +827,32 @@
   (prune:list exps))
 
 (define (prune:let names exps body)
+  (define exps* (prune:list exps))
+  (define body* (prune body))
   (define bindings
     (filter-map (lambda (name exp)
-                  (if (unused-variable? name body)
+                  (if (unused-variable? name body*)
                       #f
                       (list name exp)))
+                names exps*))
+  ;; Remove 'let' if all bindings are dead.
+  (if (null? bindings)
+      body*
+      `(let ,bindings ,body*)))
+
+(define (prune:let-values names exps body)
+  (define bindings
+    (filter-map (lambda (names exp)
+                  (if (every (lambda (name)
+                               (unused-variable? name body))
+                             names)
+                      #f
+                      (list names exp)))
                 names exps))
   ;; Remove 'let' if all bindings are dead.
   (if (null? bindings)
       (prune body)
-      `(let ,bindings ,(prune body))))
+      `(let-values ,bindings ,(prune body))))
 
 (define (prune:primcall operator args)
   `(primcall ,operator ,@(prune:list args)))
@@ -813,6 +900,8 @@
      (prune:values exps))
     (('let ((names exps) ...) body)
      (prune:let names exps body))
+    (('let-values ((names exps) ...) body)
+     (prune:let-values names exps body))
     (('primcall operator args ...)
      (prune:primcall operator args))
     (('call operator args ...)
@@ -875,6 +964,10 @@
      (define bound-vars* (append names bound-vars))
      (and (check-free-variables-in-list exps bound-vars* top-level-vars)
           (check-free-variables body bound-vars* top-level-vars)))
+    (('let-values ((names exps) ...) body)
+     (define bound-vars* (append (concatenate names) bound-vars))
+     (and (check-free-variables-in-list exps bound-vars* top-level-vars)
+          (check-free-variables body bound-vars* top-level-vars)))
     (('lambda (params ...) body)
      (check-free-variables body params top-level-vars))
     (('values exps ...)
@@ -942,6 +1035,41 @@
               `(let ,bindings ,body*))
           env*))
 
+(define (hoist:let-values names exps body)
+  (define-values (exps* exps-env)
+    (hoist:list exps))
+  (define-values (body* body-env)
+    (hoist-functions body))
+  ;; Remove all lambda bindings...
+  (define bindings
+    (filter-map (lambda (names exp)
+                  (match names
+                    ((name)
+                     (match exp
+                       (('lambda _ _)
+                        #f)
+                       (_ (list (list name) exp))))
+                    (_
+                     (list names exp))))
+                names exps*))
+  ;; ...and add them to the top-level environment.
+  (define env*
+    (fold (lambda (name exp env)
+            (match names
+              ((name)
+               (match exp
+                 (('lambda _ _)
+                  (extend-env name exp env))
+                 (_ env)))
+              (_ env)))
+          (compose-envs exps-env body-env)
+          names exps*))
+  ;; If there are no bindings left, remove the 'let-values'.
+  (values (if (null? bindings)
+              body*
+              `(let-values ,bindings ,body*))
+          env*))
+
 (define (hoist:lambda params body)
   (define-values (body* body-env)
     (hoist-functions body))
@@ -995,6 +1123,8 @@
      (hoist:if predicate consequent alternate))
     (('let ((names exps) ...) body)
      (hoist:let names exps body))
+    (('let-values ((names exps) ...) body)
+     (hoist:let-values names exps body))
     (('lambda (params ...) body)
      (hoist:lambda params body))
     (('values exps ...)
@@ -2028,11 +2158,53 @@
   (define-values (pred combined-subs)
     (eval-predicate* (compose-predicates exp-pred body-pred)
                      (compose-substitutions exp-subs body-subs)))
+  (define bindings
+    (map (lambda (name exp)
+           (let ((num-types (length (texp-types exp))))
+             (unless (= num-types 1)
+               (seagull-type-error (format #f "expected 1 value, got ~a"
+                                           num-types)
+                                   (list name exp)
+                                   infer:let))
+            (list name (apply-substitutions-to-texp exp combined-subs))))
+         names exps*))
+  (values (texp (texp-types body*)
+                `(let ,bindings
+                   ,(apply-substitutions-to-texp body* combined-subs)))
+          combined-subs
+          pred))
+
+(define (infer:let-values names exps body env)
+  (define-values (exps* exp-subs exp-pred)
+    (infer:list exps env))
+  (define exp-types (map texp-types exps*))
+  (define env*
+    (fold (lambda (names types env)
+            (fold extend-env env names (map list types)))
+          (apply-substitutions-to-env env exp-subs)
+          names
+          exp-types))
+  (define-values (body* body-subs body-pred)
+    (infer-exp body env*))
+  (define-values (pred combined-subs)
+    (eval-predicate* (compose-predicates exp-pred body-pred)
+                     (compose-substitutions exp-subs body-subs)))
+  (define bindings
+    (map (lambda (names exp)
+           (let ((num-names (length names))
+                 (num-types (length (texp-types exp))))
+             (unless (= num-names num-types)
+               (seagull-type-error (format #f "expected ~a ~a, got ~a"
+                                           num-names
+                                           (if (= num-names 1) "value" "values")
+                                           num-types)
+                                   (list names exp)
+                                   infer:let-values))
+             (list names
+                   (apply-substitutions-to-texp exp combined-subs))))
+         names exps*))
   (values (texp (texp-types body*)
-                `(let ,(map (lambda (name exp)
-                              (list name (apply-substitutions-to-texp
-                                          exp combined-subs)))
-                            names exps*)
+                `(let-values ,bindings
                    ,(apply-substitutions-to-texp body* combined-subs)))
           combined-subs
           pred))
@@ -2136,6 +2308,8 @@
      (infer:if predicate consequent alternate env))
     (('let ((names exps) ...) body)
      (infer:let names exps body env))
+    (('let-values ((names exps) ...) body)
+     (infer:let-values names exps body env))
     (('lambda (params ...) body)
      (infer:lambda params body env))
     (('values exps ...)
@@ -2755,6 +2929,19 @@
   (emit:declarations (texp-types body) let-temps body-temps port level)
   let-temps)
 
+(define (emit:let-values types names exps body stage version port level)
+  (define names* (concatenate names))
+  (define binding-temps
+    (append-map (lambda (exp)
+                  (emit-glsl exp stage version port level))
+                exps))
+  (define binding-types (append-map texp-types exps))
+  (emit:declarations binding-types names* binding-temps 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)
+
 (define %primcall-map
   '((float->int . int)
     (int->float . float)
@@ -2878,6 +3065,8 @@
      (emit:values exps stage version port level))
     (('t types ('let ((names exps) ...) body))
      (emit:let types names exps body stage version port level))
+    (('t types ('let-values ((names exps) ...) body))
+     (emit:let-values types names exps body stage version port level))
     (('t (type) ('primcall (? binary-operator? op) a b))
      (emit:binary-operator type op a b stage version port level))
     (('t (type) ('primcall (? unary-operator? op) a))