From ee6b0bb09dbf48e83c6e0ac7b7f1699bae34108a Mon Sep 17 00:00:00 2001 From: Ian Price Date: Wed, 23 Oct 2013 11:14:26 +0100 Subject: [PATCH] Fix inlining of tail list to apply. Fixes . * 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. + ;; + (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