bug#15533: optimizing away noticeable effects

[Ian Price <ianprice90@googlemail.com>]

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