[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-34-gbca488f

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=bca488f186ce662e8c41b8ac1675fa2f03bb3fc2

The branch, master has been updated
       via  bca488f186ce662e8c41b8ac1675fa2f03bb3fc2 (commit)
      from  4dcd84998fc61e15920aea83c4420c7357b9be46 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit bca488f186ce662e8c41b8ac1675fa2f03bb3fc2
Author: Andy Wingo <address@hidden>
Date:   Thu Aug 6 11:48:16 2009 +0200

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/analyze.scm      |   42 +++++++++++++++++------------
 module/language/tree-il/compile-glil.scm |    2 +-
 module/language/tree-il/inline.scm       |   33 +++++++++++++++++++++--
 module/srfi/srfi-11.scm                  |    3 ++
 4 files changed, 59 insertions(+), 21 deletions(-)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 35ddfaa..73ef8ba 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 e3e45f5..3d25dd1 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 c534f19..fd3fbc9 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 8a41d00..22bda21 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 '())


hooks/post-receive
-- 
GNU Guile