[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-89-g564f5e7

[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=564f5e70543f771e1e7c5aa57cee6f8b8d20c9ed

The branch, stable-2.0 has been updated
       via  564f5e70543f771e1e7c5aa57cee6f8b8d20c9ed (commit)
      from  30c3dac7a671cfdfadf8452c4ff9117fc0a5b8c0 (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 564f5e70543f771e1e7c5aa57cee6f8b8d20c9ed
Author: Andy Wingo <address@hidden>
Date:   Fri Feb 15 11:19:10 2013 +0100

    procedures with rest arguments can get inlined
    
    * module/language/tree-il/peval.scm (peval): Allow inlining of
      procedures with rest arguments.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add a test.

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

Summary of changes:
 module/language/tree-il/peval.scm |   40 +++++++++++++++++++++++-------------
 test-suite/tests/peval.test       |    8 +++++++
 2 files changed, 33 insertions(+), 15 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 9a409d6..6773dff 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1221,15 +1221,35 @@ top-level bindings from ENV and return the resulting 
expression."
               (or (fold-constants src name args ctx)
                   (make-application src proc args))))
            (($ <lambda> _ _
-               ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
-            ;; Simple case: no rest, no keyword arguments.
+               ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
+            ;; Simple case: no keyword arguments.
             ;; todo: handle the more complex cases
             (let* ((nargs (length orig-args))
                    (nreq (length req))
                    (nopt (if opt (length opt) 0))
                    (key (source-expression proc)))
+              (define (inlined-application)
+                (make-let src
+                          (append req
+                                  (or opt '())
+                                  (if rest (list rest) '()))
+                          gensyms
+                          (if (> nargs (+ nreq nopt))
+                              (append (list-head orig-args (+ nreq nopt))
+                                      (list
+                                       (make-application
+                                        #f
+                                        (make-primitive-ref #f 'list)
+                                        (drop orig-args (+ nreq nopt)))))
+                              (append orig-args
+                                      (drop inits (- nargs nreq))
+                                      (if rest
+                                          (list (make-const #f '()))
+                                          '())))
+                          body))
+
               (cond
-               ((or (< nargs nreq) (> nargs (+ nreq nopt)))
+               ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
                 ;; An error, or effecting arguments.
                 (make-application src (for-call orig-proc)
                                   (map for-value orig-args)))
@@ -1254,12 +1274,7 @@ top-level bindings from ENV and return the resulting 
expression."
                               (lp (counter-prev counter)))))))
 
                 (log 'inline-recurse key)
-                (loop (make-let src (append req (or opt '()))
-                                gensyms
-                                (append orig-args
-                                        (drop inits (- nargs nreq)))
-                                body)
-                  env counter ctx))
+                (loop (inlined-application) env counter ctx))
                (else
                 ;; An integration at the top-level, the first
                 ;; recursion of a recursive procedure, or a nested
@@ -1290,12 +1305,7 @@ top-level bindings from ENV and return the resulting 
expression."
                       (make-top-counter effort-limit operand-size-limit
                                         abort key))))
                   (define result
-                    (loop (make-let src (append req (or opt '()))
-                                    gensyms
-                                    (append orig-args
-                                            (drop inits (- nargs nreq)))
-                                    body)
-                      env new-counter ctx))
+                    (loop (inlined-application) env new-counter ctx))
                       
                   (if counter
                       ;; The nested inlining attempt succeeded.
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index aa36182..fdae7b1 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -843,6 +843,14 @@
     (const #t))
 
   (pass-if-peval
+      ;; Applications of procedures with rest arguments can get inlined.
+      ((lambda (x y . z)
+         (list x y z))
+       1 2 3 4)
+    (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
+         (apply (primitive list) (const 1) (const 2) (lexical z _))))
+
+  (pass-if-peval
    ;; Constant folding: cons of #nil does not make list
    (cons 1 #nil)
    (apply (primitive cons) (const 1) (const '#nil)))


hooks/post-receive
-- 
GNU Guile