bug#15533: optimizing away noticeable effects

bug#15533: optimizing away noticeable effects

[Ian Price]

I was peeved today to come across a bug that manifested itself when I
removed a pk from a particular value in my code.

Time to play "spot the difference"

scheme@(guile-user)> ,optimize (define (foo f arg)
  (let* ((l '())
         (m (if (pair? arg)
                (begin
                  (set! l (cdr arg))
                  (car arg))
                arg)))
    (lambda () (apply f m l))))
$14 = (define (foo f arg)
  (let ((m (if (pair? arg)
             (begin (begin (cdr arg) (if #f #f)) (car arg))
             arg)))
    (lambda () (f m))))

scheme@(guile-user)> ,optimize (define (foo2 f arg)
  (let* ((l '())
         (m (if (pair? arg)
                (begin
                  (set! l (cdr arg))
                  (car arg))
                arg)))
    (lambda () (apply f m (pk l)))))
$15 = (define (foo2 f arg)
  (let* ((l '())
         (m (if (pair? arg)
              (begin (set! l (cdr arg)) (car arg))
              arg)))
    (lambda () (apply f m (pk l)))))

and if you actually define those procedures and run them

scheme@(guile-user)> ((foo list '(a b c)))
$16 = (a)
scheme@(guile-user)> ((foo2 list '(a b c)))

;;; ((b c))
$17 = (a b c)

I'm currently on the lua branch, which means branches from master at
6871327742d3e1a0966aa8fed04c911311c12c2a (Aug 31). I'll try on a more
recent master or stable when I have time.

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

bug#15533: optimizing away noticeable effects

[Mark H Weaver]

Ian Price <ianprice90@googlemail.com> writes:

> scheme@(guile-user)> ,optimize (define (foo f arg)
>   (let* ((l '())
>          (m (if (pair? arg)
>                 (begin
>                   (set! l (cdr arg))
>                   (car arg))
>                 arg)))
>     (lambda () (apply f m l))))
> $14 = (define (foo f arg)
>   (let ((m (if (pair? arg)
>              (begin (begin (cdr arg) (if #f #f)) (car arg))
>              arg)))
>     (lambda () (f m))))

I can confirm that the same thing happens on the stable-2.0 branch.

     Mark

bug#15533: optimizing away noticeable effects

[Mark H Weaver]

Mark H Weaver <mhw@netris.org> writes:

> Ian Price <ianprice90@googlemail.com> writes:
>
>> scheme@(guile-user)> ,optimize (define (foo f arg)
>>   (let* ((l '())
>>          (m (if (pair? arg)
>>                 (begin
>>                   (set! l (cdr arg))
>>                   (car arg))
>>                 arg)))
>>     (lambda () (apply f m l))))
>> $14 = (define (foo f arg)
>>   (let ((m (if (pair? arg)
>>              (begin (begin (cdr arg) (if #f #f)) (car arg))
>>              arg)))
>>     (lambda () (f m))))
>
> I can confirm that the same thing happens on the stable-2.0 branch.

Further investigation has revealed that 'peval' incorrectly removes the
'l' from the call to 'apply'.

     Mark

bug#15533: optimizing away noticeable effects

[Mark H Weaver]

Mark H Weaver <mhw@netris.org> writes:

> Mark H Weaver <mhw@netris.org> writes:
>
>> Ian Price <ianprice90@googlemail.com> writes:
>>
>>> scheme@(guile-user)> ,optimize (define (foo f arg)
>>>   (let* ((l '())
>>>          (m (if (pair? arg)
>>>                 (begin
>>>                   (set! l (cdr arg))
>>>                   (car arg))
>>>                 arg)))
>>>     (lambda () (apply f m l))))
>>> $14 = (define (foo f arg)
>>>   (let ((m (if (pair? arg)
>>>              (begin (begin (cdr arg) (if #f #f)) (car arg))
>>>              arg)))
>>>     (lambda () (f m))))
>>
>> I can confirm that the same thing happens on the stable-2.0 branch.
>
> Further investigation has revealed that 'peval' incorrectly removes the
> 'l' from the call to 'apply'.

stis pointed out that 2.0.5 does not have this bug.  I'm currently doing
a git bisect to determine which commit introduced the bug.

     Mark

bug#15533: optimizing away noticeable effects

[Mark H Weaver]

Ian Price <ianprice90@googlemail.com> writes:

> scheme@(guile-user)> ,optimize (define (foo f arg)
>   (let* ((l '())
>          (m (if (pair? arg)
>                 (begin
>                   (set! l (cdr arg))
>                   (car arg))
>                 arg)))
>     (lambda () (apply f m l))))
> $14 = (define (foo f arg)
>   (let ((m (if (pair? arg)
>              (begin (begin (cdr arg) (if #f #f)) (car arg))
>              arg)))
>     (lambda () (f m))))

Using git bisect, I've determined that this bug was introduced in the
following commit:

commit d21537efb4a0edea30a7ab801909207d4bb69030
Author: Andy Wingo <wingo@pobox.com>
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.

Andy, would you be willing to investigate further?

     Mark

bug#15533: optimizing away noticeable effects

[Ian Price]

Mark H Weaver <mhw@netris.org> writes:

> Using git bisect, I've determined that this bug was introduced in the
> following commit:
>
> commit d21537efb4a0edea30a7ab801909207d4bb69030
> Author: Andy Wingo <wingo@pobox.com>
> 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.

Thanks for bisecting mark, I've had a little look and this is the right
patch. The actual error occurs at the very beginning of the loop, in the
variable tail*.

Originally, this was a call (for-value tail), which returned a
lexical-ref. Now it is a call (find-definition tail) which returns a
const ().

We obviously need to have a check for mutability when referring to a
variable, the question is where?

Does it make sense to add it to find-definition? or should we add it
before the use in that case?

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

bug#15533: optimizing away noticeable effects

[Ian Price]

Ian Price <ianprice90@googlemail.com> writes:

> Does it make sense to add it to find-definition? or should we add it
> before the use in that case?

I've decided that it does, and I've made the following (tentative)
change on my own guile install.

         (cond
          ((lookup (lexical-ref-gensym x))
           => (lambda (op)
-               (let ((y (or (operand-residual-value op)
-                            (visit-operand op counter 'value 10 10)
-                            (operand-source op))))
-                 (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))))))
+               (if (var-set? (operand-var op))
+                   (values #f #f)
+                   
+                 ;; var-set? (operand-var ) => #f #f ?
+                 (let ((y (or (operand-residual-value op)
+                              (visit-operand op counter 'value 10 10)
+                              (operand-source op))))
+                   (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)))))))

It's a little invasive because of the 'if', but the meat of it is

+               (if (var-set? (operand-var op))
+                   (values #f #f)

The check for mutability needs to come before the let, since that's
where we do the lookup for a value, so it would be too late.

If Andy is happy with this change, I'll add a test, and push a commit,
but I'm going leave it to his discretion.

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

bug#15533: optimizing away noticeable effects

[Ian Price]

[-- Attachment #1: Type: text/plain, Size: 374 bytes --]

Ian Price <ianprice90@googlemail.com> writes:

> If Andy is happy with this change, I'll add a test, and push a commit,
> but I'm going leave it to his discretion.

Andy OKed it on IRC, so I've attached the patch.

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: peval fix --]
[-- Type: text/x-patch, Size: 4129 bytes --]

From ee6b0bb09dbf48e83c6e0ac7b7f1699bae34108a Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Wed, 23 Oct 2013 11:14:26 +0100
Subject: [PATCH] Fix inlining of tail list to apply.

Fixes <http://bugs.gnu.org/15533>.

* module/language/tree-il/peval.scm (peval): Final list argument to
  `apply' should not be inlined if it is mutable.
* test-suite/tests/peval.test ("partial evaluation"): Add test.
---
 module/language/tree-il/peval.scm | 38 ++++++++++++++++++++------------------
 test-suite/tests/peval.test       | 16 +++++++++++++++-
 2 files changed, 35 insertions(+), 19 deletions(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index a6e4076..bd92edc 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -716,24 +716,26 @@ top-level bindings from ENV and return the resulting expression."
         (cond
          ((lookup (lexical-ref-gensym x))
           => (lambda (op)
-               (let ((y (or (operand-residual-value op)
-                            (visit-operand op counter 'value 10 10)
-                            (operand-source op))))
-                 (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))))))
+               (if (var-set? (operand-var op))
+                   (values #f #f)
+                   (let ((y (or (operand-residual-value op)
+                                (visit-operand op counter 'value 10 10)
+                                (operand-source op))))
+                     (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))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 923b0d1..5b003d2 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1223,4 +1223,18 @@
       (call-with-prompt t
                         (lambda () (abort-to-prompt t 1 2 3))
                         (lambda (k x y z) (list x y z))))
-    (apply (primitive 'list) (const 1) (const 2) (const 3))))
+    (apply (primitive 'list) (const 1) (const 2) (const 3)))
+
+  (pass-if-peval resolve-primitives
+   ;; Should not inline tail list to apply if it is mutable.
+   ;; <http://debbugs.gnu.org/15533>
+   (let ((l '()))
+     (if (pair? arg)
+         (set! l arg))
+     (apply f l))
+   (let (l) (_) ((const ()))
+        (begin
+          (if (apply (primitive pair?) (toplevel arg))
+              (set! (lexical l _) (toplevel arg))
+              (void))
+          (apply (primitive @apply) (toplevel f) (lexical l _))))))
-- 
1.7.11.7

bug#15533: optimizing away noticeable effects

[Ian Price]

Following prompting from mark weaver on IRC. I rebased this patch, and
pushed to stable-2.0.

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"