mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Fix bug in eq-constant? propagation in CSE if kf == kt

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2021-05-24 11:07:14 +02:00
parent f499754bc8
commit 17aab66e75
2 changed files with 66 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/language/cps/cse.scm
View file

@ -360,9 +360,9 @@ for a label, it isn't known to be constant at that label."
(_ bool)) (_ bool))
(match (and (< pred succ) (intmap-ref out pred)) (match (and (< pred succ) (intmap-ref out pred))
(($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v))) (($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v)))
(if (eqv? kt succ) (if (eqv? kf succ)
(adjoin-constant consts v c) consts
consts)) (adjoin-constant consts v c)))
(_ consts))))))) (_ consts)))))))
(define (propagate-analysis analysis label out) (define (propagate-analysis analysis label out)

122
test-suite/tests/compiler.test
View file

@ -302,73 +302,77 @@
'(3 #t #f #nil ())))) '(3 #t #f #nil ()))))
(with-test-prefix "cse auxiliary definitions" (with-test-prefix "cse auxiliary definitions"
(define test-code (define test-proc
'(begin (compile
(define count 1) '(begin
(set! count count) ;; Avoid inlining (define count 1)
(set! count count) ;; Avoid inlining
(define (main) (define (main)
(define (trampoline thunk) (define (trampoline thunk)
(let loop ((i 0) (result #f)) (let loop ((i 0) (result #f))
(cond (cond
((< i 1) ((< i 1)
(loop (+ i 1) (thunk))) (loop (+ i 1) (thunk)))
(else (else
(unless (= result 42) (error "bad result" result)) (unless (= result 42) (error "bad result" result))
result)))) result))))
(define (test n) (define (test n)
(let ((matrix (make-vector n))) (let ((matrix (make-vector n)))
(let loop ((i (- n 1))) (let loop ((i (- n 1)))
(when (>= i 0) (when (>= i 0)
(vector-set! matrix i (make-vector n 42)) (vector-set! matrix i (make-vector n 42))
(loop (- i 1)))) (loop (- i 1))))
(vector-ref (vector-ref matrix 0) 0))) (vector-ref (vector-ref matrix 0) 0)))
(trampoline (lambda () (test count)))) (trampoline (lambda () (test count))))
main)) main)))
(define test-proc #f) (pass-if-equal "running test" 42 (test-proc)))
(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)))
(with-test-prefix "closure conversion" (with-test-prefix "closure conversion"
(define test-code (define test-proc
'(lambda (arg) (compile
(define (A a) '(lambda (arg)
(let loop ((ls a)) (define (A a)
(cond ((null? ls) (let loop ((ls a))
(B a)) (cond ((null? ls)
((pair? ls) (B a))
(if (list? (car ls)) ((pair? ls)
(loop (cdr ls)) (if (list? (car ls))
#t)) (loop (cdr ls))
(else #t)))) #t))
(define (B b) (else #t))))
(let loop ((ls b)) (define (B b)
(cond ((null? ls) (let loop ((ls b))
(map A b)) (cond ((null? ls)
((pair? ls) (map A b))
(if (list? (car ls)) ((pair? ls)
(loop (cdr ls)) (if (list? (car ls))
(error "bad" b))) (loop (cdr ls))
(else (error "bad" b)))
(error "bad" b))))) (else
(B arg))) (error "bad" b)))))
(B arg))))
(define test-proc #f) (pass-if-equal "running test" '(#t #t)
(pass-if "compiling test works"
(begin
(set! test-proc (compile test-code))
(procedure? test-proc)))
(pass-if-equal "test terminates without error" '(#t #t)
(test-proc '((V X) (Y Z))))) (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" (with-test-prefix "read-and-compile tree-il"
(let ((code (let ((code
"\ "\