diff options
author | Andy Wingo <wingo@pobox.com> | 2021-05-24 11:07:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-05-24 11:09:24 +0200 |
commit | 17aab66e75136cf23c7f0d4942b61d6947f98f9b (patch) | |
tree | e02324740728284c9a749399bfb6f9cc253dfe2c | |
parent | f499754bc8291a044c5034b634ac02a01bde9b49 (diff) | |
download | guile-17aab66e75136cf23c7f0d4942b61d6947f98f9b.tar.gz |
Fix bug in eq-constant? propagation in CSE if kf == kt
* module/language/cps/cse.scm (compute-out-edges): Only propagate
constant to successor if successor not kf.
* test-suite/tests/compiler.test ("cse auxiliary definitions"):
("closure conversion"): Refactor.
("constant propagation"): New test.
Fixes #48368.
-rw-r--r-- | module/language/cps/cse.scm | 6 | ||||
-rw-r--r-- | test-suite/tests/compiler.test | 130 |
2 files changed, 70 insertions, 66 deletions
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 55cf5490e..47c0f90e6 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -360,9 +360,9 @@ for a label, it isn't known to be constant at that label." (_ bool)) (match (and (< pred succ) (intmap-ref out pred)) (($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v))) - (if (eqv? kt succ) - (adjoin-constant consts v c) - consts)) + (if (eqv? kf succ) + consts + (adjoin-constant consts v c))) (_ consts))))))) (define (propagate-analysis analysis label out) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 254aaa720..466f2b821 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -302,73 +302,77 @@ '(3 #t #f #nil ())))) (with-test-prefix "cse auxiliary definitions" - (define test-code - '(begin - (define count 1) - (set! count count) ;; Avoid inlining - - (define (main) - (define (trampoline thunk) - (let loop ((i 0) (result #f)) - (cond - ((< i 1) - (loop (+ i 1) (thunk))) - (else - (unless (= result 42) (error "bad result" result)) - result)))) - (define (test n) - (let ((matrix (make-vector n))) - (let loop ((i (- n 1))) - (when (>= i 0) - (vector-set! matrix i (make-vector n 42)) - (loop (- i 1)))) - (vector-ref (vector-ref matrix 0) 0))) - - (trampoline (lambda () (test count)))) - main)) - - (define test-proc #f) - (pass-if "compiling test works" - (begin - (set! test-proc (compile test-code)) - (procedure? test-proc))) - - (pass-if-equal "test terminates without error" 42 - (test-proc))) + (define test-proc + (compile + '(begin + (define count 1) + (set! count count) ;; Avoid inlining + + (define (main) + (define (trampoline thunk) + (let loop ((i 0) (result #f)) + (cond + ((< i 1) + (loop (+ i 1) (thunk))) + (else + (unless (= result 42) (error "bad result" result)) + result)))) + (define (test n) + (let ((matrix (make-vector n))) + (let loop ((i (- n 1))) + (when (>= i 0) + (vector-set! matrix i (make-vector n 42)) + (loop (- i 1)))) + (vector-ref (vector-ref matrix 0) 0))) + + (trampoline (lambda () (test count)))) + main))) + + (pass-if-equal "running test" 42 (test-proc))) (with-test-prefix "closure conversion" - (define test-code - '(lambda (arg) - (define (A a) - (let loop ((ls a)) - (cond ((null? ls) - (B a)) - ((pair? ls) - (if (list? (car ls)) - (loop (cdr ls)) - #t)) - (else #t)))) - (define (B b) - (let loop ((ls b)) - (cond ((null? ls) - (map A b)) - ((pair? ls) - (if (list? (car ls)) - (loop (cdr ls)) - (error "bad" b))) - (else - (error "bad" b))))) - (B arg))) - - (define test-proc #f) - (pass-if "compiling test works" - (begin - (set! test-proc (compile test-code)) - (procedure? test-proc))) - - (pass-if-equal "test terminates without error" '(#t #t) + (define test-proc + (compile + '(lambda (arg) + (define (A a) + (let loop ((ls a)) + (cond ((null? ls) + (B a)) + ((pair? ls) + (if (list? (car ls)) + (loop (cdr ls)) + #t)) + (else #t)))) + (define (B b) + (let loop ((ls b)) + (cond ((null? ls) + (map A b)) + ((pair? ls) + (if (list? (car ls)) + (loop (cdr ls)) + (error "bad" b))) + (else + (error "bad" b))))) + (B arg)))) + + (pass-if-equal "running test" '(#t #t) (test-proc '((V X) (Y Z))))) +(with-test-prefix "constant propagation" + (define test-proc + (compile + '(lambda (a b) + (let ((c (if (and (eq? a 'foo) + (eq? b 'bar)) + 'qux + a))) + c)))) + + (pass-if-equal "one two" 'one (test-proc 'one 'two)) + (pass-if-equal "one bar" 'one (test-proc 'one 'bar)) + (pass-if-equal "foo bar" 'qux (test-proc 'foo 'bar)) + (pass-if-equal "foo two" 'foo (test-proc 'foo 'two))) + (with-test-prefix "read-and-compile tree-il" (let ((code "\ |