>From f4fa41e0de76caf743ced8e1d1e42c60ce250456 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 15 Dec 2013 16:04:27 +0100 Subject: [PATCH 1/2] Fix #1068 (partially!) by removing returnvar-passing from CPS-conversion --- compiler.scm | 53 +++++++++++++++++++++------------------------- tests/compiler-tests.scm | 9 ++++++++ tests/syntax-tests.scm | 14 +++++++++++- 3 files changed, 46 insertions(+), 30 deletions(-) diff --git a/compiler.scm b/compiler.scm index 0398eef..f356eaf 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 45b6bfd..444aa50 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 a5f4323..89481cd 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)) -- 1.7.10.4