[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-92-g85edd67

[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=85edd670f5674bd4c25547936b1faf61e2d7a397

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

    inline call-with-values consumers with optional and/or rest args
    
    * module/language/tree-il/peval.scm (peval): Inline call-with-values
      whose consumers have optional and rest arguments.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add test.

commit 8598dd8d28d16fe1ec92dfc49f6517992f1598ec
Author: Andy Wingo <address@hidden>
Date:   Fri Feb 15 14:15:15 2013 +0100

    more rest argument inlining improvements
    
    * module/language/tree-il/peval.scm (peval): Correct comment on
      find-definition, and allow a find-definition to fall back on a source
      expression.  Avoid copying non-constant expressions.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add a test that
      inlining rest arguments works with complicated argument expressions,
      and a test that order of effects in rest args is preserved.

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

Summary of changes:
 module/language/tree-il/peval.scm |   49 ++++++++++++++---------
 test-suite/tests/peval.test       |   78 +++++++++++++++++++++++++++++++++++++
 2 files changed, 107 insertions(+), 20 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index e25a199..8955313 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -516,7 +516,7 @@ top-level bindings from ENV and return the resulting 
expression."
      (else
       (residualize-call))))
 
-  (define (inline-values exp src names gensyms body)
+  (define (inline-values src exp nmin nmax consumer)
     (let loop ((exp exp))
       (match exp
         ;; Some expression types are always singly-valued.
@@ -532,18 +532,16 @@ top-level bindings from ENV and return the resulting 
expression."
              ($ <toplevel-set>)         ; could return zero values in
              ($ <toplevel-define>)      ; the future
              ($ <module-set>)           ;
-             ($ <dynset>))              ; 
-         (and (= (length names) 1)
-              (make-let src names gensyms (list exp) body)))
-        (($ <application> src
-            ($ <primitive-ref> _ (? singly-valued-primitive? name)))
-         (and (= (length names) 1)
-              (make-let src names gensyms (list exp) body)))
+             ($ <dynset>)               ;
+             ($ <application> src
+                ($ <primitive-ref> _ (? singly-valued-primitive?))))
+         (and (<= nmin 1) (or (not nmax) (>= nmax 1))
+              (make-application src (make-lambda #f '() consumer) (list exp))))
 
         ;; Statically-known number of values.
         (($ <application> src ($ <primitive-ref> _ 'values) vals)
-         (and (= (length names) (length vals))
-              (make-let src names gensyms vals body)))
+         (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
+              (make-application src (make-lambda #f '() consumer) vals)))
 
         ;; Not going to copy code into both branches.
         (($ <conditional>) #f)
@@ -709,8 +707,9 @@ top-level bindings from ENV and return the resulting 
expression."
     ;; 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.
+    ;; You don't want to use this in general because it introduces a slight
+    ;; nonlinearity by running peval again (though with a small effort and size
+    ;; counter).
     ;;
     (define (find-definition x n-aliases)
       (cond
@@ -719,7 +718,8 @@ top-level bindings from ENV and return the resulting 
expression."
          ((lookup (lexical-ref-gensym x))
           => (lambda (op)
                (let ((y (or (operand-residual-value op)
-                            (visit-operand op counter 'value 10 10))))
+                            (visit-operand op counter 'value 10 10)
+                            (operand-source op))))
                  (cond
                   ((and (lexical-ref? y)
                         (= (lexical-refcount (lexical-ref-gensym x)) 1))
@@ -967,11 +967,13 @@ top-level bindings from ENV and return the resulting 
expression."
        ;; reconstruct the let-values, pevaling the consumer.
        (let ((producer (for-values producer)))
          (or (match consumer
-               (($ <lambda-case> src req #f #f #f () gensyms body #f)
-                (cond
-                 ((inline-values producer src req gensyms body)
-                  => for-tail)
-                 (else #f)))
+               (($ <lambda-case> src req opt rest #f inits gensyms body #f)
+                (let* ((nmin (length req))
+                       (nmax (and (not rest) (+ nmin (if opt (length opt) 
0)))))
+                  (cond
+                   ((inline-values lv-src producer nmin nmax consumer)
+                    => for-tail)
+                   (else #f))))
                (_ #f))
              (make-let-values lv-src producer (for-tail consumer)))))
       (($ <dynwind> src winder body unwinder)
@@ -1148,15 +1150,22 @@ top-level bindings from ENV and return the resulting 
expression."
       (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply 
'@apply)))
           (proc args ... tail))
        (let lp ((tail* (find-definition tail 1)) (speculative? #t))
+         (define (copyable? x)
+           ;; Inlining a result from find-definition effectively copies it,
+           ;; relying on the let-pruning to remove its original binding.  We
+           ;; shouldn't copy non-constant expressions.
+           (or (not speculative?) (constant-expression? x)))
          (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))
+           (($ <application> _ ($ <primitive-ref> _ 'cons)
+               ((and head (? copyable?)) (and tail (? copyable?))))
             (for-tail (make-application src apply
                                         (cons proc
                                               (append args (list head 
tail))))))
-           (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+           (($ <application> _ ($ <primitive-ref> _ 'list)
+               (and args* ((? copyable?) ...)))
             (for-tail (make-application src proc (append args args*))))
            (tail*
             (if speculative?
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 01164e4..da63344 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -25,6 +25,7 @@
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
   #:use-module (language glil)
+  #:use-module (rnrs bytevectors) ;; for the bytevector primitives
   #:use-module (srfi srfi-13))
 
 (define peval
@@ -879,6 +880,83 @@
                   (const 1)
                   (lexical args _)))))
 
+  (pass-if-peval resolve-primitives
+    ;; Here the `args' that gets built by the application of the lambda
+    ;; takes more than effort "10" to visit.  Test that we fall back to
+    ;; the source expression of the operand, which is still a call to
+    ;; `list', so the inlining still happens.
+    (lambda (bv offset n)
+      (let ((x (bytevector-ieee-single-native-ref
+                bv
+                (+ offset 0)))
+            (y (bytevector-ieee-single-native-ref
+                bv
+                (+ offset 4))))
+        (let ((args (list x y)))
+          (@apply
+           (lambda (bv offset x y)
+             (bytevector-ieee-single-native-set!
+              bv
+              (+ offset 0)
+              x)
+             (bytevector-ieee-single-native-set!
+              bv
+              (+ offset 4)
+              y))
+           bv
+           offset
+           args))))
+    (lambda ()
+      (lambda-case
+       (((bv offset n) #f #f #f () (_ _ _))
+        (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
+                                 (lexical bv _)
+                                 (apply (primitive +)
+                                        (lexical offset _) (const 0)))
+                          (apply (primitive bytevector-ieee-single-native-ref)
+                                 (lexical bv _)
+                                 (apply (primitive +)
+                                        (lexical offset _) (const 4))))
+             (begin
+               (apply (primitive bytevector-ieee-single-native-set!)
+                     (lexical bv _)
+                     (apply (primitive +)
+                            (lexical offset _) (const 0))
+                     (lexical x _))
+               (apply (primitive bytevector-ieee-single-native-set!)
+                      (lexical bv _)
+                      (apply (primitive +)
+                             (lexical offset _) (const 4))
+                      (lexical y _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Here we ensure that non-constant expressions are not copied.
+    (lambda ()
+      (let ((args (list (foo!))))
+        (@apply
+         (lambda (z x)
+           (list z x))
+         ;; This toplevel ref might raise an unbound variable exception.
+         ;; The effects of `(foo!)' must be visible before this effect.
+         z
+         args)))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
+        (let (args) (_)
+             ((apply (primitive list) (apply (toplevel foo!))))
+             (apply (primitive @apply)
+                    (lambda . _)
+                    (toplevel z)
+                    (lexical args _)))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Let-values inlining, even with consumers with rest args.
+    (call-with-values (lambda () (values 1 2))
+      (lambda args
+        (apply list args)))
+    (apply (primitive list) (const 1) (const 2)))
+
   (pass-if-peval
    ;; Constant folding: cons of #nil does not make list
    (cons 1 #nil)


hooks/post-receive
-- 
GNU Guile