[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-90-gd21537e

[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=d21537efb4a0edea30a7ab801909207d4bb69030

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

    better inlining of `apply' with rest arguments
    
    * module/language/tree-il/peval.scm (peval): Move up the find-definition
      helper.  Use it to speculatively destructure conses and lists into the
      tail position of an `apply' form.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add tests.

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

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

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 6773dff..e25a199 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -703,6 +703,47 @@ top-level bindings from ENV and return the resulting 
expression."
        ((vhash-assq var env) => cdr)
        (else (error "unbound var" var))))
 
+    ;; Find a value referenced a specific number of times.  This is a hack
+    ;; that's used for propagating fresh data structures like rest lists and
+    ;; prompt tags.  Usually we wouldn't copy consed data, but we can do so in
+    ;; some special cases like `apply' or prompts if we can account
+    ;; for all of its uses.
+    ;;
+    ;; You don't want to use this in general because it doesn't run the full
+    ;; partial evaluator, so it doesn't fold constant expressions, etc.
+    ;;
+    (define (find-definition x n-aliases)
+      (cond
+       ((lexical-ref? x)
+        (cond
+         ((lookup (lexical-ref-gensym x))
+          => (lambda (op)
+               (let ((y (or (operand-residual-value op)
+                            (visit-operand op counter 'value 10 10))))
+                 (cond
+                  ((and (lexical-ref? y)
+                        (= (lexical-refcount (lexical-ref-gensym x)) 1))
+                   ;; X is a simple alias for Y.  Recurse, regardless of
+                   ;; the number of aliases we were expecting.
+                   (find-definition y n-aliases))
+                  ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+                   ;; We found a definition that is aliased the right
+                   ;; number of times.  We still recurse in case it is a
+                   ;; lexical.
+                   (values (find-definition y 1)
+                           op))
+                  (else
+                   ;; We can't account for our aliases.
+                   (values #f #f))))))
+         (else
+          ;; A formal parameter.  Can't say anything about that.
+          (values #f #f))))
+       ((= n-aliases 1)
+        ;; Not a lexical: success, but only if we are looking for an
+        ;; unaliased value.
+        (values x #f))
+       (else (values #f #f))))
+
     (define (visit exp ctx)
       (loop exp env counter ctx))
 
@@ -1106,15 +1147,23 @@ top-level bindings from ENV and return the resulting 
expression."
                (make-application src (make-primitive-ref #f 'values) vals))))))
       (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply 
'@apply)))
           (proc args ... tail))
-       (match (for-value tail)
-         (($ <const> _ (args* ...))
-          (let ((args* (map (lambda (x) (make-const #f x)) args*)))
-            (for-tail (make-application src proc (append args args*)))))
-         (($ <application> _ ($ <primitive-ref> _ 'list) args*)
-          (for-tail (make-application src proc (append args args*))))
-         (tail
-          (let ((args (append (map for-value args) (list tail))))
-            (make-application src apply (cons (for-value proc) args))))))
+       (let lp ((tail* (find-definition tail 1)) (speculative? #t))
+         (match tail*
+           (($ <const> _ (args* ...))
+            (let ((args* (map (cut make-const #f <>) args*)))
+              (for-tail (make-application src proc (append args args*)))))
+           (($ <application> _ ($ <primitive-ref> _ 'cons) (head tail))
+            (for-tail (make-application src apply
+                                        (cons proc
+                                              (append args (list head 
tail))))))
+           (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+            (for-tail (make-application src proc (append args args*))))
+           (tail*
+            (if speculative?
+                (lp (for-value tail) #f)
+                (let ((args (append (map for-value args) (list tail*))))
+                  (make-application src apply
+                                    (cons (for-value proc) args))))))))
       (($ <application> src orig-proc orig-args)
        ;; todo: augment the global env with specialized functions
        (let revisit-proc ((proc (visit orig-proc 'operator)))
@@ -1408,37 +1457,6 @@ top-level bindings from ENV and return the resulting 
expression."
                (or () ((? constant-expression?))))
             #t)
            (_ #f)))
-       (define (find-definition x n-aliases)
-         (cond
-          ((lexical-ref? x)
-           (cond
-            ((lookup (lexical-ref-gensym x))
-             => (lambda (op)
-                  (let ((y (or (operand-residual-value op)
-                               (visit-operand op counter 'value 10 10))))
-                    (cond
-                     ((and (lexical-ref? y)
-                           (= (lexical-refcount (lexical-ref-gensym x)) 1))
-                      ;; X is a simple alias for Y.  Recurse, regardless of
-                      ;; the number of aliases we were expecting.
-                      (find-definition y n-aliases))
-                     ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
-                      ;; We found a definition that is aliased the right
-                      ;; number of times.  We still recurse in case it is a
-                      ;; lexical.
-                      (values (find-definition y 1)
-                              op))
-                     (else
-                      ;; We can't account for our aliases.
-                      (values #f #f))))))
-            (else
-             ;; A formal parameter.  Can't say anything about that.
-             (values #f #f))))
-          ((= n-aliases 1)
-           ;; Not a lexical: success, but only if we are looking for an
-           ;; unaliased value.
-           (values x #f))
-          (else (values #f #f))))
 
        (let ((tag (for-value tag))
              (body (for-tail body)))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index fdae7b1..01164e4 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -850,6 +850,35 @@
     (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
          (apply (primitive list) (const 1) (const 2) (lexical z _))))
 
+  (pass-if-peval resolve-primitives
+    ;; Unmutated lists can get inlined.
+    (let ((args (list 2 3)))
+      (apply (lambda (x y z w)
+               (list x y z w))
+             0 1 args))
+    (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
+
+  (pass-if-peval resolve-primitives
+    ;; However if the list might have been mutated, it doesn't propagate.
+    (let ((args (list 2 3)))
+      (foo! args)
+      (apply (lambda (x y z w)
+               (list x y z w))
+             0 1 args))
+    (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
+         (begin
+           (apply (toplevel foo!) (lexical args _))
+           (apply (primitive @apply)
+                  (lambda ()
+                    (lambda-case
+                     (((x y z w) #f #f #f () (_ _ _ _))
+                      (apply (primitive list)
+                             (lexical x _) (lexical y _)
+                             (lexical z _) (lexical w _)))))
+                  (const 0)
+                  (const 1)
+                  (lexical args _)))))
+
   (pass-if-peval
    ;; Constant folding: cons of #nil does not make list
    (cons 1 #nil)


hooks/post-receive
-- 
GNU Guile