[Sbcl-commits] CVS: sbcl/src/compiler ir1opt.lisp,1.141,1.142

[Paul K. <pk...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv23751/src/compiler

Modified Files:
	ir1opt.lisp 
Log Message:
1.0.43.43: Merge more equivalent branches together

* Recognize cases of (if foo [leaf] [same leaf]), and compile the conditional
  branch away.  We used to only perform something similar to that when the
  branches jumped to exactly the same block.  We now detect simple cases of
  equivalent blocks.


Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.141
retrieving revision 1.142
diff -u -d -r1.141 -r1.142
--- ir1opt.lisp	12 Oct 2010 04:41:16 -0000	1.141
+++ ir1opt.lisp	12 Oct 2010 04:43:48 -0000	1.142
@@ -635,24 +635,43 @@
 
 ;;;; IF optimization
 
+;;; Utility: return T if both argument cblocks are equivalent.  For now,
+;;; detect only blocks that read the same leaf into the same lvar, and
+;;; continue to the same block.
+(defun cblocks-equivalent-p (x y)
+  (declare (type cblock x y))
+  (and (ref-p (block-start-node x))
+       (eq (block-last x) (block-start-node x))
+
+       (ref-p (block-start-node y))
+       (eq (block-last y) (block-start-node y))
+
+       (equal (block-succ x) (block-succ y))
+       (eql (ref-lvar (block-start-node x)) (ref-lvar (block-start-node y)))
+       (eql (ref-leaf (block-start-node x)) (ref-leaf (block-start-node y)))))
+
 ;;; Check whether the predicate is known to be true or false,
 ;;; deleting the IF node in favor of the appropriate branch when this
 ;;; is the case.
+;;; Similarly, when both branches are equivalent, branch directly to either
+;;; of them.
 ;;; Also, if the test has multiple uses, replicate the node when possible.
 (defun ir1-optimize-if (node)
   (declare (type cif node))
   (let ((test (if-test node))
         (block (node-block node)))
     (let* ((type (lvar-type test))
+           (consequent  (if-consequent  node))
+           (alternative (if-alternative node))
            (victim
             (cond ((constant-lvar-p test)
-                   (if (lvar-value test)
-                       (if-alternative node)
-                       (if-consequent node)))
+                   (if (lvar-value test) alternative consequent))
                   ((not (types-equal-or-intersect type (specifier-type 'null)))
-                   (if-alternative node))
+                   alternative)
                   ((type= type (specifier-type 'null))
-                   (if-consequent node)))))
+                   consequent)
+                  ((cblocks-equivalent-p alternative consequent)
+                   alternative))))
       (when victim
         (flush-dest test)
         (when (rest (block-succ block))