[Chicken-hackers] [PATCH] Re-walk `if` nodes after dropping branches

[Evan Hanson]

This makes sure the scrutinizer uses the new type of each node after
converting it into a non-conditional form. For example, the expression
`(if #t 1 2.0)` should have the type `fixnum` after dropping the
unreachable branch, rather than its original type `(or fixnum float)`.
---
 scrutinizer.scm                 | 85 +++++++++++++++++++++--------------------
 tests/specialization-test-1.scm |  4 ++
 2 files changed, 47 insertions(+), 42 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6c181cb..f03f799 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -494,48 +494,49 @@
                           (c (second subs))
                           (a (third subs))
                           (nor0 noreturn))
-                     (when (and (always-true rt loc n) specialize)
-                       (set! dropped-branches (add1 dropped-branches))
-                       (copy-node!
-                        (build-node-graph
-                         `(let ((,(gensym) ,tst)) ,c))
-                        n))
-                     (let* ((r1 (walk c e loc dest tail (cons (car tags) flow) 
#f))
-                            (nor1 noreturn))
-                       (set! noreturn #f)
-                       (let* ((r2 (walk a e loc dest tail (cons (cdr tags) 
flow) #f))
-                              (nor2 noreturn))
-                         (set! noreturn (or nor-1 nor0 (and nor1 nor2)))
-                         ;; when only one branch is noreturn, add blist 
entries for
-                         ;; all in other branch:
-                         (when (or (and nor1 (not nor2))
-                                   (and nor2 (not nor1)))
-                           (let ((yestag (if nor1 (cdr tags) (car tags))))
-                             (for-each
-                              (lambda (ble)
-                                (when (eq? (cdar ble) yestag)
-                                  (d "adding blist entry ~a for single 
returning conditional branch"
-                                     ble)
-                                  (add-to-blist (caar ble) (car flow) (cdr 
ble))))
-                              blist)))
-                         (cond ((and (not (eq? '* r1)) (not (eq? '* r2)))
-                                ;;(dd " branches: ~s:~s / ~s:~s" nor1 r1 nor2 
r2)
-                                (cond ((and (not nor1) (not nor2)
-                                            (not (= (length r1) (length r2))))
-                                       (report 
-                                        loc
-                                        (sprintf
-                                            "branches in conditional 
expression differ in the number of results:~%~%~a"
-                                          (pp-fragment n)))
-                                       '*)
-                                      (nor1 r2)
-                                      (nor2 r1)
-                                      (else
-                                       (dd "merge branch results: ~s + ~s" r1 
r2)
-                                       (map (lambda (t1 t2)
-                                              (simplify-type `(or ,t1 ,t2)))
-                                            r1 r2))))
-                               (else '*)))))))
+                     (cond
+                       ((and (always-true rt loc n) specialize)
+                        ;; drop branch and re-walk updated node
+                        (set! dropped-branches (add1 dropped-branches))
+                        (copy-node! (build-node-graph `(let ((,(gensym) ,tst)) 
,c)) n)
+                        (walk n e loc dest tail flow ctags))
+                       (else
+                        (let* ((r1 (walk c e loc dest tail (cons (car tags) 
flow) #f))
+                               (nor1 noreturn))
+                          (set! noreturn #f)
+                          (let* ((r2 (walk a e loc dest tail (cons (cdr tags) 
flow) #f))
+                                (nor2 noreturn))
+                            (set! noreturn (or nor-1 nor0 (and nor1 nor2)))
+                            ;; when only one branch is noreturn, add blist 
entries for
+                            ;; all in other branch:
+                            (when (or (and nor1 (not nor2))
+                                     (and nor2 (not nor1)))
+                              (let ((yestag (if nor1 (cdr tags) (car tags))))
+                               (for-each
+                                (lambda (ble)
+                                  (when (eq? (cdar ble) yestag)
+                                    (d "adding blist entry ~a for single 
returning conditional branch"
+                                       ble)
+                                    (add-to-blist (caar ble) (car flow) (cdr 
ble))))
+                                blist)))
+                            (cond ((and (not (eq? '* r1)) (not (eq? '* r2)))
+                                  ;;(dd " branches: ~s:~s / ~s:~s" nor1 r1 
nor2 r2)
+                                  (cond ((and (not nor1) (not nor2)
+                                              (not (= (length r1) (length 
r2))))
+                                         (report
+                                          loc
+                                          (sprintf
+                                              "branches in conditional 
expression differ in the number of results:~%~%~a"
+                                            (pp-fragment n)))
+                                         '*)
+                                        (nor1 r2)
+                                        (nor2 r1)
+                                        (else
+                                         (dd "merge branch results: ~s + ~s" 
r1 r2)
+                                         (map (lambda (t1 t2)
+                                                (simplify-type `(or ,t1 ,t2)))
+                                              r1 r2))))
+                                 (else '*)))))))))
                 ((let)
                  ;; before CPS-conversion, `let'-nodes may have multiple 
bindings
                  (let loop ((vars params) (body subs) (e2 '()))
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 344e445..ff82d98 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -56,4 +56,8 @@ return n;}
                          "         C_fix(2));")))))
   (assert (equal? '(1 2) result)))
 
+;; dropped conditional branch is ignored
+(compiler-typecase (if #t 'a "a")
+  (symbol 1))
+
 )
-- 
2.1.4