[Sbcl-commits] CVS: sbcl/src/compiler dfo.lisp,1.16,1.17 ir1opt.lisp,1.82,1.83

[Alexey D. <ade...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv12569/src/compiler

Modified Files:
	dfo.lisp ir1opt.lisp 
Log Message:
0.8.5.40:
        * Fix PFD bug MISC.172: restart IR1-OPTIMIZE-RETURN after
          assignment-convertion;
        * fix PFD bug MISC.173: in FIND-DFO-AUX skip blocks to be
          deleted.


Index: dfo.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dfo.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- dfo.lisp	15 Sep 2003 09:21:38 -0000	1.16
+++ dfo.lisp	15 Nov 2003 18:34:34 -0000	1.17
@@ -22,7 +22,7 @@
   (let ((head (component-head component)))
     (do ()
 	((dolist (ep (block-succ head) t)
-	   (unless (block-flag ep)
+	   (unless (or (block-flag ep) (block-delete-p ep))
 	     (find-dfo-aux ep head component)
 	     (return nil))))))
   (let ((num 0))
@@ -89,7 +89,7 @@
 (defun find-dfo-aux (block head component)
   (unless (eq (block-component block) component)
     (join-components component (block-component block)))
-  (unless (block-flag block)
+  (unless (or (block-flag block) (block-delete-p block))
     (setf (block-flag block) t)
     (dolist (succ (block-succ block))
       (find-dfo-aux succ head component))

Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -d -r1.82 -r1.83
--- ir1opt.lisp	14 Nov 2003 04:49:06 -0000	1.82
+++ ir1opt.lisp	15 Nov 2003 18:34:34 -0000	1.83
@@ -456,7 +456,7 @@
                            (lambda-tail-set (combination-lambda use))))
                  (when (combination-p use)
                    (when (nth-value 1 (maybe-convert-tail-local-call use))
-                     (return-from find-result-type (values)))))
+                     (return-from find-result-type t))))
                 (t
                  (use-union (node-derived-type use))))))
       (let ((int
@@ -466,7 +466,7 @@
               ;; )
               ))
 	(setf (return-result-type node) int))))
-  (values))
+  nil)
 
 ;;; Do stuff to realize that something has changed about the value
 ;;; delivered to a return node. Since we consider the return values of
@@ -482,22 +482,25 @@
 ;;; results of the calls.
 (defun ir1-optimize-return (node)
   (declare (type creturn node))
-  (let* ((tails (lambda-tail-set (return-lambda node)))
-	 (funs (tail-set-funs tails)))
-    (collect ((res *empty-type* values-type-union))
-      (dolist (fun funs)
-	(let ((return (lambda-return fun)))
-	  (when return
-	    (when (node-reoptimize return)
-	      (setf (node-reoptimize return) nil)
-	      (find-result-type return))
-	    (res (return-result-type return)))))
+  (tagbody
+   :restart
+     (let* ((tails (lambda-tail-set (return-lambda node)))
+            (funs (tail-set-funs tails)))
+       (collect ((res *empty-type* values-type-union))
+                (dolist (fun funs)
+                  (let ((return (lambda-return fun)))
+                    (when return
+                      (when (node-reoptimize return)
+                        (setf (node-reoptimize return) nil)
+                        (when (find-result-type return)
+                          (go :restart)))
+                      (res (return-result-type return)))))
 
-      (when (type/= (res) (tail-set-type tails))
-	(setf (tail-set-type tails) (res))
-	(dolist (fun (tail-set-funs tails))
-	  (dolist (ref (leaf-refs fun))
-	    (reoptimize-lvar (node-lvar ref)))))))
+                (when (type/= (res) (tail-set-type tails))
+                  (setf (tail-set-type tails) (res))
+                  (dolist (fun (tail-set-funs tails))
+                    (dolist (ref (leaf-refs fun))
+                      (reoptimize-lvar (node-lvar ref))))))))
 
   (values))