[Guile-commits] branch main updated: Fix bug in eq-constant? propagation in CSE if kf == kt

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch main
in repository guile.

The following commit(s) were added to refs/heads/main by this push:
     new 17aab66  Fix bug in eq-constant? propagation in CSE if kf == kt
17aab66 is described below

commit 17aab66e75136cf23c7f0d4942b61d6947f98f9b
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon May 24 11:07:14 2021 +0200

    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.
---
 module/language/cps/cse.scm    |   6 +-
 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 55cf549..47c0f90 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 254aaa7..466f2b8 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
          "\