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)

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

@ -302,7 +302,8 @@
'(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
(compile
'(begin '(begin
(define count 1) (define count 1)
(set! count count) ;; Avoid inlining (set! count count) ;; Avoid inlining
@ -325,19 +326,13 @@
(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
(compile
'(lambda (arg) '(lambda (arg)
(define (A a) (define (A a)
(let loop ((ls a)) (let loop ((ls a))
@ -358,17 +353,26 @@
(error "bad" b))) (error "bad" b)))
(else (else
(error "bad" b))))) (error "bad" b)))))
(B arg))) (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
"\ "\