~ chicken-core (chicken-5) 7eb95c52acc4f57a2dd66c36090d87fdce62412f

commit 7eb95c52acc4f57a2dd66c36090d87fdce62412f
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Mon May 25 17:42:01 2015 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Mon May 25 17:42:01 2015 +0200

    Re-walk `if` nodes after dropping branches
    
    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)`.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index ef0e5fb2..26469f44 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -493,48 +493,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 344e4451..ff82d981 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))
+
 )