mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 19:20:23 +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))
(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)

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

@ -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 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)))
(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))
(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)))
(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
(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))))
(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)
(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
"\