summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2021-05-24 11:07:14 +0200
committerAndy Wingo <wingo@pobox.com>2021-05-24 11:09:24 +0200
commit17aab66e75136cf23c7f0d4942b61d6947f98f9b (patch)
treee02324740728284c9a749399bfb6f9cc253dfe2c
parentf499754bc8291a044c5034b634ac02a01bde9b49 (diff)
downloadguile-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.scm6
-rw-r--r--test-suite/tests/compiler.test130
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
"\