actually inline call-with-values to tree-il's <let-values>

* module/srfi/srfi-11.scm (let-values): In the one-clause case, avoid
  going through temporary variables.

* module/language/tree-il/inline.scm (inline!): Add another case:
  (call-with-values (lambda () ...) (lambda ... ...) -> let-values.

* module/language/tree-il/compile-glil.scm (flatten): Fix a bug
  compiling applications in "vals" context.

* module/language/tree-il/analyze.scm (analyze-lexicals): Fix a couple
  bugs with let-values and rest arguments.

4 files changed, 59 insertions, 21 deletions

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 35ddfaa3b..73ef8ba21 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -185,14 +185,14 @@
                         vars))
       
       ((<let-values> vars exp body)
-       (hashq-set! bound-vars proc
-                   (let lp ((out (hashq-ref bound-vars proc)) (in vars))
-                     (if (pair? in)
-                         (lp (cons (car in) out) (cdr in))
-                         (if (null? in) out (cons in out)))))
-       (lset-difference eq?
-                        (lset-union eq? (step exp) (step body))
-                        vars))
+       (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+                      (if (pair? in)
+                          (lp (cons (car in) out) (cdr in))
+                          (if (null? in) out (cons in out))))))
+         (hashq-set! bound-vars proc bound)
+         (lset-difference eq?
+                          (lset-union eq? (step exp) (step body))
+                          bound)))
       
       (else '())))
   
@@ -309,15 +309,23 @@
       ((<let-values> vars exp body)
        (let ((nmax (recur exp)))
          (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (max nmax (allocate! body proc n))
-               (let ((v (if (pair? vars) (car vars) vars)))
-                 (let ((v (car vars)))
-                   (hashq-set!
-                    allocation v
-                    (make-hashq proc
-                                `(#t ,(hashq-ref assigned v) . ,n)))
-                   (lp (cdr vars) (1+ n))))))))
+           (cond
+            ((null? vars)
+             (max nmax (allocate! body proc n)))
+            ((not (pair? vars))
+             (hashq-set! allocation vars
+                         (make-hashq proc
+                                     `(#t ,(hashq-ref assigned vars) . ,n)))
+             ;; the 1+ for this var
+             (max nmax (allocate! body proc (1+ n))))
+            (else               
+             (let ((v (if (pair? vars) (car vars) vars)))
+               (let ((v (car vars)))
+                 (hashq-set!
+                  allocation v
+                  (make-hashq proc
+                              `(#t ,(hashq-ref assigned v) . ,n)))
+                 (lp (cdr vars) (1+ n)))))))))
       
       (else n)))
 
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e3e45f56c..3d25dd181 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -391,7 +391,7 @@
            (case context
              ((tail) (emit-code src (make-glil-call 'goto/args len)))
              ((push) (emit-code src (make-glil-call 'call len)))
-             ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
+             ((vals) (emit-code src (make-glil-mv-call len LMVRA)))
              ((drop)
               (let ((MV (make-label)) (POST (make-label)))
                 (emit-code src (make-glil-mv-call len MV))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index c534f195b..fd3fbc921 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -37,8 +37,35 @@
   (post-order!
    (lambda (x)
      (record-case x
-       ((<application> proc args)
-        (and (lambda? proc) (null? args)
-             (lambda-body proc)))
+       ((<application> src proc args)
+        (cond
+
+         ;; ((lambda () x)) => x
+         ((and (lambda? proc) (null? args))
+          (lambda-body proc))
+
+         ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
+         ;; => (let-values (((a b . c) foo)) bar)
+         ;;
+         ;; Note that this is a singly-binding form of let-values. Also
+         ;; note that Scheme's let-values expands into call-with-values,
+         ;; then here we reduce it to tree-il's let-values.
+         ((and (primitive-ref? proc)
+               (eq? (primitive-ref-name proc) '@call-with-values)
+               (= (length args) 2)
+               (lambda? (cadr args)))
+          (let ((producer (car args))
+                (consumer (cadr args)))
+            (make-let-values src
+                             (lambda-names consumer)
+                             (lambda-vars consumer)
+                             (if (and (lambda? producer)
+                                      (null? (lambda-names producer)))
+                                 (lambda-body producer)
+                                 (make-application src producer '()))
+                             (lambda-body consumer))))
+
+         (else #f)))
+
        (else #f)))
    x))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index 8a41d00f7..22bda21a2 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -67,6 +67,9 @@
 (define-syntax let-values
   (lambda (x)
     (syntax-case x ()
+      ((_ ((binds exp)) b0 b1 ...)
+       (syntax (call-with-values (lambda () exp)
+                 (lambda binds b0 b1 ...))))
       ((_ (clause ...) b0 b1 ...)
        (let lp ((clauses (syntax (clause ...)))
                 (ids '())