0.8.10.13:

        * Fix bug in stack analysis: allow freeing of discontinuous
          UVL blocks.

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index cf74775..5fb2c0f 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1097,7 +1097,7 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
                (let ((it ,test)) (declare (ignorable it)),@body)
                (acond ,@rest))))))
 
-;;; (binding* ({(name initial-value [flag])}*) body)
+;;; (binding* ({(names initial-value [flag])}*) body)
 ;;; FLAG may be NIL or :EXIT-IF-NULL
 ;;;
 ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
@@ -1115,7 +1115,15 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
                      (symbol
                       (values (list names) nil))
                      (list
-                      (values names nil)))
+                      (collect ((new-names) (ignorable))
+                        (dolist (name names)
+                          (when (eq name nil)
+                            (setq name (gensym))
+                            (ignorable name))
+                          (new-names name))
+                        (values (new-names)
+                                (when (ignorable)
+                                  `((declare (ignorable ,@(ignorable)))))))))
                  (setq form `(multiple-value-bind ,names
                                  ,initial-value
                                ,@declarations

diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 83ce8f9..6ab9bfd 100644 (file)
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -182,35 +182,51 @@
 ;;; wastes only space.
 (defun discard-unused-values (block1 block2)
   (declare (type cblock block1 block2))
-  (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
-         (block2-stack (ir2-block-start-stack (block-info block2)))
-         (cleanup-code
-          (cond ((eq (car block1-stack) (car block2-stack))
-                 (binding* ((preserved-count (mismatch block1-stack block2-stack)
-                              :exit-if-null)
-                            (n-last-preserved (1- preserved-count))
-                            (nipped-count (- (length block1-stack)
-                                             (length block2-stack)))
-                            (n-last-nipped (+ n-last-preserved nipped-count)))
-                   (aver (equal (nthcdr (1+ n-last-nipped) block1-stack)
-                                (nthcdr preserved-count block2-stack)))
-                   (compiler-notify "%NIP-VALUES emitted")
-                   `(%nip-values ',(elt block1-stack n-last-nipped)
-                                 ',(elt block1-stack n-last-preserved)
-                                 ,@(loop for moved in block1-stack
-                                         repeat preserved-count
-                                         collect `',moved))))
-                (t
-                 (let* ((n-popped (- (length block1-stack)
-                                     (length block2-stack)))
-                       (last-popped (elt block1-stack (1- n-popped))))
-                   (when *check-consistency*
-                     (aver (equal block2-stack (nthcdr n-popped block1-stack))))
-                   `(%pop-values ',last-popped))))))
-    (when cleanup-code
+  (collect ((cleanup-code))
+    (labels ((find-popped (before after)
+               ;; Returns (VALUES popped last-popped rest), where
+               ;; BEFORE = (APPEND popped rest) and
+               ;; (EQ (FIRST rest) (FIRST after))
+               (if (null after)
+                   (values before (first (last before)) nil)
+                   (loop with first-preserved = (car after)
+                         for last-popped = nil then maybe-popped
+                         for rest on before
+                         for maybe-popped = (car rest)
+                         while (neq maybe-popped first-preserved)
+                         collect maybe-popped into popped
+                         finally (return (values popped last-popped rest)))))
+             (discard (before-stack after-stack)
+               (cond
+                 ((eq (car before-stack) (car after-stack))
+                  (binding* ((moved-count (mismatch before-stack after-stack)
+                                          :exit-if-null)
+                             ((moved qmoved)
+                              (loop for moved-lvar in before-stack
+                                    repeat moved-count
+                                    collect moved-lvar into moved
+                                    collect `',moved-lvar into qmoved
+                                    finally (return (values moved qmoved))))
+                             (q-last-moved (car (last qmoved)))
+                             ((nil last-nipped rest)
+                              (find-popped (nthcdr moved-count before-stack)
+                                           (nthcdr moved-count after-stack))))
+                    (cleanup-code
+                     `(%nip-values ',last-nipped ,q-last-moved
+                       ,@qmoved))
+                    (discard (nconc moved rest) after-stack)))
+                 (t
+                  (multiple-value-bind (popped last-popped rest)
+                      (find-popped before-stack after-stack)
+                    (declare (ignore popped))
+                    (cleanup-code `(%pop-values ',last-popped))
+                    (discard rest after-stack))))))
+      (discard (ir2-block-end-stack (block-info block1))
+               (ir2-block-start-stack (block-info block2))))
+    (when (cleanup-code)
       (let* ((block (insert-cleanup-code block1 block2
                                          (block-start-node block2)
-                                         cleanup-code))
+                                         `(progn ,@(cleanup-code))))
              (2block (make-ir2-block block)))
         (setf (block-info block) 2block)
         (add-to-emit-order 2block (block-info block1))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 11c73a3..a0715b7 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1202,6 +1202,38 @@
             (denominator
              (progv nil nil (values (boole boole-and 0 v9)))))))))
    1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+  (multiple-value-call #'list
+    (eval '(values 11 12))
+    (eval '(values 13 14))
+    (block ext
+      (return-from non-continuous-stack-test
+        (multiple-value-call #'list
+          (eval '(values :b1 :b2))
+          (eval '(values :b3 :b4))
+          (block int
+            (return-from ext
+              (multiple-value-call (eval #'values)
+                (eval '(values 1 2))
+                (eval '(values 3 4))
+                (block ext
+                  (return-from int
+                    (multiple-value-call (eval #'values)
+                      (eval '(values :a1 :a2))
+                      (eval '(values :a3 :a4))
+                      (block int
+                        (return-from ext
+                          (multiple-value-call (eval #'values)
+                            (eval '(values 5 6))
+                            (eval '(values 7 8))
+                            (if x
+                                :ext
+                                (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
 \f
 ;;; MISC.275
 (assert

diff --git a/version.lisp-expr b/version.lisp-expr
index 1f9f5c1..8ed0eef 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.10.12"
+"0.8.10.13"