~ chicken-core (chicken-5) 05d663cccb4ea37b3f86f5020dbde8c29613a591
commit 05d663cccb4ea37b3f86f5020dbde8c29613a591
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Dec 29 16:57:14 2013 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Fri Jan 3 20:27:55 2014 +0100
Fix for #1068 (2): don't allow captured lambdas to get replaced.
This caused issues with letrec-like constructs: by replacing variables with
complex lambda expressions lexical scoping would be broken and references
to variables could be moved around to a location where the variable was
out of scope.
More generally, the optimization which replaces variables completely
ignores all scoping rules, which can cause issues if the values being
moved about refer to other variables in the same scope. For unknown
reasons, this hasn't caused issues in other situations yet.
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/compiler.scm b/compiler.scm
index f356eaf0..6a84060b 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -2169,14 +2169,15 @@
(when (eq? '##core#variable (node-class value))
(let* ([name (first (node-parameters value))]
[nrefs (get db name 'references)] )
- (when (or (and (not (get db name 'unknown)) (get db name 'value))
- (and (not (get db name 'captured))
- nrefs
- (= 1 (length nrefs))
- (not assigned)
- (not (get db name 'assigned))
- (or (not (variable-visible? name))
- (not (get db name 'global))) ) )
+ (when (and (not captured)
+ (or (and (not (get db name 'unknown)) (get db name 'value))
+ (and (not (get db name 'captured))
+ nrefs
+ (= 1 (length nrefs))
+ (not assigned)
+ (not (get db name 'assigned))
+ (or (not (variable-visible? name))
+ (not (get db name 'global))) ) ))
(quick-put! plist 'replacable name)
(put! db name 'replacing #t) ) ) ) )
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 444aa508..078cb0d3 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -220,11 +220,22 @@
;; Optimizer would "lift" inner-bar out of its let and replace
;; outer-bar with it, even though it wasn't visible yet. Caused by
;; broken cps-conversion (underlying problem for #1068).
-(let ((outer-bar (##core#undefined)))
- (let ((inner-bar (let ((tmp (lambda (x) (if x '1 (outer-bar '#t)))))
- tmp)))
- (set! outer-bar inner-bar)
- (outer-bar #f)))
+(assert (equal? 1 (let ((outer-bar (##core#undefined)))
+ (let ((inner-bar (let ((tmp (lambda (x)
+ (if x '1 (outer-bar '#t)))))
+ tmp)))
+ (set! outer-bar inner-bar)
+ (outer-bar #f)))))
+
+;; Slightly modified version which broke after fixing the above due
+;; to replacement optimization getting triggered. This replacement
+;; caused outer-bar to get replaced by inner-bar, even within itself,
+;; thereby causing an undefined variable reference.
+(assert (equal? 1 (let ((outer-bar (##core#undefined)))
+ (let ((inner-bar (lambda (x)
+ (if x '1 (outer-bar outer-bar)))))
+ (set! outer-bar inner-bar)
+ (outer-bar '#f)))))
;; Test that encode-literal/decode-literal use the proper functions
;; to decode number literals.
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 89481cd7..59f7d63d 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1119,6 +1119,10 @@ take
tmp)))
(bar #f)))
+;; Deeper issue uncovered by fixing the above issue
+(t 1 (letrec ((bar (lambda (x) (if x 1 (bar bar)))))
+ (bar #f)))
+
;; Just to verify (this has always worked)
(t 1 (letrec* ((foo (lambda () 1))
(bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
Trap