~ chicken-core (chicken-5) 3e302a402bb20f8ffc2975eb77edcfe2f7c0e36c
commit 3e302a402bb20f8ffc2975eb77edcfe2f7c0e36c
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Dec 15 16:04:27 2013 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Fri Jan 3 20:27:55 2014 +0100
Fix #1068 (partially!) by removing returnvar-passing from CPS-conversion
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/compiler.scm b/compiler.scm
index 0398eefb..f356eaf0 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1688,12 +1688,11 @@
(define (perform-cps-conversion node)
- (define (cps-lambda id returnvar llist subs k)
- (let ([t1 (or returnvar (gensym 'k))])
+ (define (cps-lambda id llist subs k)
+ (let ([t1 (gensym 'k)])
(k (make-node
'##core#lambda (list id #t (cons t1 llist) 0)
- (list (walk (gensym-f-id)
- (car subs)
+ (list (walk (car subs)
(lambda (r)
(make-node '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) )
@@ -1701,42 +1700,40 @@
(and (eq? (node-class node) '##core#variable)
(eq? (car (node-parameters node)) var)))
- (define (walk returnvar n k)
+ (define (walk n k)
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
(case (node-class n)
((##core#variable quote ##core#undefined ##core#primitive) (k n))
((if) (let* ((t1 (gensym 'k))
- (t2 (or returnvar (gensym 'r)))
+ (t2 (gensym 'r))
(k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
(make-node
'let
(list t1)
(list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
(list (k (varnode t2))) )
- (walk #f (car subs)
+ (walk (car subs)
(lambda (v)
(make-node 'if '()
(list v
- (walk #f (cadr subs) k1)
- (walk #f (caddr subs) k1) ) ) ) ) ) ) ) )
+ (walk (cadr subs) k1)
+ (walk (caddr subs) k1) ) ) ) ) ) ) ) )
((let)
(let loop ((vars params) (vals subs))
(if (null? vars)
- (walk #f (car vals) k)
- (walk (car vars)
- (car vals)
+ (walk (car vals) k)
+ (walk (car vals)
(lambda (r)
(if (node-for-var? r (car vars)) ; Don't generate unneccessary lets
(loop (cdr vars) (cdr vals))
(make-node 'let
(list (car vars))
(list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) )
- ((lambda ##core#lambda) (cps-lambda (gensym-f-id) returnvar (first params) subs k))
+ ((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
((set!) (let ((t1 (gensym 't)))
- (walk #f
- (car subs)
+ (walk (car subs)
(lambda (r)
(make-node 'let (list t1)
(list (make-node 'set! (list (first params)) (list r))
@@ -1748,24 +1745,23 @@
(cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
;; mark to avoid leaf-routine optimization
(mark-variable id '##compiler#callback-lambda)
- ;; maybe pass returnvar here?
- (cps-lambda id #f (first (node-parameters lam)) (node-subexpressions lam) k) ) )
+ (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
##core#inline_loc_update)
(walk-inline-call class params subs k) )
- ((##core#call) (walk-call returnvar (car subs) (cdr subs) params k))
- ((##core#callunit) (walk-call-unit returnvar (first params) k))
+ ((##core#call) (walk-call (car subs) (cdr subs) params k))
+ ((##core#callunit) (walk-call-unit (first params) k))
((##core#the ##core#the/result)
;; remove "the" nodes, as they are not used after scrutiny
- (walk returnvar (car subs) k))
+ (walk (car subs) k))
((##core#typecase)
;; same here, the last clause is chosen, exp is dropped
- (walk returnvar (last subs) k))
+ (walk (last subs) k))
(else (bomb "bad node (cps)")) ) ) )
- (define (walk-call returnvar fn args params k)
+ (define (walk-call fn args params k)
(let ((t0 (gensym 'k))
- (t3 (or returnvar (gensym 'r))) )
+ (t3 (gensym 'r)) )
(make-node
'let (list t0)
(list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
@@ -1773,13 +1769,13 @@
(walk-arguments
args
(lambda (vars)
- (walk #f fn
+ (walk fn
(lambda (r)
(make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
- (define (walk-call-unit returnvar unitname k)
+ (define (walk-call-unit unitname k)
(let ((t0 (gensym 'k))
- (t3 (or returnvar (gensym 'r))) )
+ (t3 (gensym 'r)) )
(make-node
'let (list t0)
(list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
@@ -1800,8 +1796,7 @@
(loop (cdr args) (cons (car args) vars)) )
(else
(let ((t1 (gensym 'a)))
- (walk t1
- (car args)
+ (walk (car args)
(lambda (r)
(if (node-for-var? r t1) ; Don't generate unneccessary lets
(loop (cdr args) (cons (varnode t1) vars) )
@@ -1818,7 +1813,7 @@
##core#inline_loc_ref ##core#inline_loc_update))
(every atomic? (node-subexpressions n)) ) ) ) )
- (walk #f node values) )
+ (walk node values) )
;;; Foreign callback stub type:
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 45b6bfd4..444aa508 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -217,6 +217,15 @@
(gp-test)
+;; 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)))
+
;; Test that encode-literal/decode-literal use the proper functions
;; to decode number literals.
(assert (equal? '(+inf.0 -inf.0) (list (fp/ 1.0 0.0) (fp/ -1.0 0.0))))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index a5f4323b..89481cd7 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1113,6 +1113,18 @@ take
(bar foo))
bar))
+;; Obscure letrec issue #1068
+(t 1 (letrec ((foo (lambda () 1))
+ (bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
+ tmp)))
+ (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)))))
+ tmp)))
+ (bar #f)))
+
(t 1 (letrec* ((foo 1)
(bar foo))
- bar))
+ bar))
Trap