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.

diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 6d5d6a7..18dcaec 100644 (file)
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -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))

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index d7bdf0e..3c67e0f 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -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)))))
-
-      (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)))))))
+  (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))))))))
 
   (values))
 \f

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 37698fa..0b07cfc 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -868,3 +868,75 @@
                      (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
               0 0 -5)
              -16))
+
+;;; MISC.172
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline list apply))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (labels ((%f12 (f12-1 f12-2)
+                            (labels ((%f2 (f2-1 f2-2)
+                                       (flet ((%f6 ()
+                                               (flet ((%f18
+                                                           (f18-1
+                                                            &optional (f18-2 a)
+                                                            (f18-3 -207465075)
+                                                            (f18-4 a))
+                                                         (return-from %f12 b)))
+                                                 (%f18 -3489553
+                                                       -7
+                                                       (%f18 (%f18 150 -64 f12-1)
+                                                             (%f18 (%f18 -8531)
+                                                                   11410)
+                                                             b)
+                                                       56362666))))
+                                         (labels ((%f7
+                                                      (f7-1 f7-2
+                                                            &optional (f7-3 (%f6)))
+                                                    7767415))
+                                           f12-1))))
+                              (%f2 b -36582571))))
+                   (apply #'%f12 (list 774 -4413)))))
+              0 1 2)
+             774))
+
+;;; MISC.173
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline values))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (flet ((%f11
+                            (f11-1 f11-2
+                                   &optional (f11-3 c) (f11-4 7947114)
+                                   (f11-5
+                                    (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
+                                             8134))
+                                      (multiple-value-call #'%f3
+                                        (values (%f3 -30637724 b) c)))))
+                          (setq c 555910)))
+                   (if (and nil (%f11 a a))
+                       (if (%f11 a 421778 4030 1)
+                           (labels ((%f7
+                                        (f7-1 f7-2
+                                              &optional
+                                              (f7-3
+                                               (%f11 -79192293
+                                                     (%f11 c a c -4 214720)
+                                                     b
+                                                     b
+                                                     (%f11 b 985)))
+                                              (f7-4 a))
+                                      b))
+                             (%f11 c b -25644))
+                           54)
+                       -32326608))))
+              1 2 3)
+             -32326608))

diff --git a/version.lisp-expr b/version.lisp-expr
index 04d36c9..58201ba 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.5.39"
+"0.8.5.40"