[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-93-g91c763e

[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=91c763ee3f195dc0e26339608da01250d6924009

The branch, stable-2.0 has been updated
       via  91c763ee3f195dc0e26339608da01250d6924009 (commit)
      from  85edd670f5674bd4c25547936b1faf61e2d7a397 (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 91c763ee3f195dc0e26339608da01250d6924009
Author: Andy Wingo <address@hidden>
Date:   Fri Feb 15 15:20:40 2013 +0100

    local rewrite for apply to a let-bound rest list
    
    * module/language/tree-il/peval.scm (peval): Add a special-case inlining
      pattern for apply to a let-bound rest arg that preserves effect
      ordering.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add a test, and
      update an older test with a better result.

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

Summary of changes:
 module/language/tree-il/peval.scm |   32 ++++++++++++++++++++++++++++++++
 test-suite/tests/peval.test       |   31 ++++++++++++++++++++++++++-----
 2 files changed, 58 insertions(+), 5 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 8955313..da3f4a8 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -437,6 +437,13 @@ top-level bindings from ENV and return the resulting 
expression."
              new))
          vars))
 
+  (define (fresh-temporaries ls)
+    (map (lambda (elt)
+           (let ((new (gensym "tmp ")))
+             (record-new-temporary! 'tmp new 1)
+             new))
+         ls))
+
   (define (assigned-lexical? sym)
     (var-set? (lookup-var sym)))
 
@@ -872,6 +879,31 @@ top-level bindings from ENV and return the resulting 
expression."
              (begin
                (record-operand-use op)
                (make-lexical-set src name (operand-sym op) (for-value exp))))))
+      (($ <let> src
+          (names ... rest)
+          (gensyms ... rest-sym)
+          (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
+          ($ <application> asrc
+             ($ <primitive-ref> _ (or 'apply '@apply))
+             (proc args ...
+                   ($ <lexical-ref> _
+                      (? (cut eq? <> rest))
+                      (? (lambda (sym)
+                           (and (eq? sym rest-sym)
+                                (= (lexical-refcount sym) 1))))))))
+       (let* ((tmps (make-list (length rest-args) 'tmp))
+              (tmp-syms (fresh-temporaries tmps)))
+         (for-tail
+          (make-let src
+                    (append names tmps)
+                    (append gensyms tmp-syms)
+                    (append vals rest-args)
+                    (make-application
+                     asrc
+                     proc
+                     (append args
+                             (map (cut make-lexical-ref #f <> <>)
+                                  tmps tmp-syms)))))))
       (($ <let> src names gensyms vals body)
        (define (compute-alias exp)
          ;; It's very common for macros to introduce something like:
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index da63344..923b0d1 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -943,12 +943,33 @@
     (lambda ()
       (lambda-case
        ((() #f #f #f () ())
+        (let (_) (_) ((apply (toplevel foo!)))
+             (let (z) (_) ((toplevel z))
+                  (apply (primitive 'list)
+                         (lexical z _)
+                         (lexical _ _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Rest args referenced more than once are not destructured.
+    (lambda ()
+      (let ((args (list 'foo)))
+        (set-car! args 'bar)
+        (@apply
+         (lambda (z x)
+           (list z x))
+         z
+         args)))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
         (let (args) (_)
-             ((apply (primitive list) (apply (toplevel foo!))))
-             (apply (primitive @apply)
-                    (lambda . _)
-                    (toplevel z)
-                    (lexical args _)))))))
+             ((apply (primitive list) (const foo)))
+             (begin
+               (apply (primitive set-car!) (lexical args _) (const bar))
+               (apply (primitive @apply)
+                     (lambda . _)
+                     (toplevel z)
+                     (lexical args _))))))))
 
   (pass-if-peval resolve-primitives
     ;; Let-values inlining, even with consumers with rest args.


hooks/post-receive
-- 
GNU Guile