mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +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 (cond
((lookup (lexical-ref-gensym x)) ((lookup (lexical-ref-gensym x))
=> (lambda (op) => (lambda (op)
(let ((y (or (operand-residual-value op) (if (var-set? (operand-var op))
(visit-operand op counter 'value 10 10) (values #f #f)
(operand-source op)))) (let ((y (or (operand-residual-value op)
(cond (visit-operand op counter 'value 10 10)
((and (lexical-ref? y) (operand-source op))))
(= (lexical-refcount (lexical-ref-gensym x)) 1)) (cond
;; X is a simple alias for Y. Recurse, regardless of ((and (lexical-ref? y)
;; the number of aliases we were expecting. (= (lexical-refcount (lexical-ref-gensym x)) 1))
(find-definition y n-aliases)) ;; X is a simple alias for Y. Recurse, regardless of
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) ;; the number of aliases we were expecting.
;; We found a definition that is aliased the right (find-definition y n-aliases))
;; number of times. We still recurse in case it is a ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
;; lexical. ;; We found a definition that is aliased the right
(values (find-definition y 1) ;; number of times. We still recurse in case it is a
op)) ;; lexical.
(else (values (find-definition y 1)
;; We can't account for our aliases. op))
(values #f #f)))))) (else
;; We can't account for our aliases.
(values #f #f)))))))
(else (else
;; A formal parameter. Can't say anything about that. ;; A formal parameter. Can't say anything about that.
(values #f #f)))) (values #f #f))))

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

@ -1223,4 +1223,18 @@
(call-with-prompt t (call-with-prompt t
(lambda () (abort-to-prompt t 1 2 3)) (lambda () (abort-to-prompt t 1 2 3))
(lambda (k x y z) (list x y z)))) (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 _))))))