mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Fix inlining of tail list to apply.

Browse source 
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.
This commit is contained in:
Ian Price 2013-10-23 11:14:26 +01:00
parent 70511cc403
commit 265e7bd92a
2 changed files with 35 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/tree-il/peval.scm
View file

@ -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))))

16
test-suite/tests/peval.test
View file

@ -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 _))))))