0.8.7.13:

        * Stack analysis: propagate liveness information from
          NLEs. (fixes bug 299, PFD's MISC.185, 186, 231, 232, 235,
          236, 237).

BUGS

@@ -1228,21 +1228,6 @@ WORKAROUND:
   returns, values returned by (EXT) must be removed from under that of
   (INT).
 
-299: (aka PFD MISC.186)
-    * (defun foo ()
-        (declare (optimize (debug 1)))
-        (multiple-value-call #'list
-          (if (eval t) (eval '(values :a :b :c)) nil) ; (*)
-          (catch 'foo (throw 'foo (values :x :y)))))
-    FOO
-    * (foo)
-    (:X :Y)
-
-  Operator THROW is represented with a call of a not returning funny
-  function %THROW, unknown values stack after the call is empty, so
-  the unknown values LVAR (*) is considered to be dead after the call
-  and, thus, before it and is popped by the stack analysis.
-
 300: (reported by Peter Graves) Function PEEK-CHAR checks PEEK-TYPE
   argument type only after having read a character. This is caused
   with EXPLICIT-CHECK attribute in DEFKNOWN. The similar problem

NEWS

@@ -2243,6 +2243,9 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7:
     type when called with 1 argument; PEEK-CHAR checked type of
     PEEK-TYPE only after having read first character from a
     stream. (reported by Peter Graves)
+  * fixed some bugs revealed by Paul Dietz' test suite:
+    ** in stack analysys liveness information is propagated from
+       non-local entry points.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

OPTIMIZATIONS

@@ -169,3 +169,11 @@ then cons up a bignum for it:
     ((89 125 16) (ASH A (MIN 18 -706)))
     (T (DPB -3 (BYTE 30 30) -1))))
 --------------------------------------------------------------------------------
+#16
+(do ((i 0 (1+ i)))
+    ((= i (the (integer 0 100) n)))
+  ...)
+
+It is commonly expected for Python to derive (FIXNUMP I). (If ``='' is
+replaced with ``>='', Python will do.)
+--------------------------------------------------------------------------------

src/compiler/ir1-translators.lisp

@@ -69,6 +69,7 @@
   result of Value-Form."
   (unless (symbolp name)
     (compiler-error "The block name ~S is not a symbol." name))
+  (start-block start)
   (ctran-starts-block next)
   (let* ((dummy (make-ctran))
 	 (entry (make-entry))
@@ -162,6 +163,7 @@
   to the next statement following that tag. A Tag must an integer or a
   symbol. A statement must be a list. Other objects are illegal within the
   body."
+  (start-block start)
   (ctran-starts-block next)
   (let* ((dummy (make-ctran))
 	 (entry (make-entry))

src/compiler/ir1opt.lisp

@@ -323,19 +323,21 @@
     (when (block-start next)  ; NEXT is not an END-OF-COMPONENT marker
       (cond ( ;; We cannot combine with a successor block if:
              (or
-              ;; The successor has more than one predecessor.
+              ;; the successor has more than one predecessor;
               (rest (block-pred next))
-              ;; The successor is the current block (infinite loop).
+              ;; the successor is the current block (infinite loop);
               (eq next block)
-              ;; The next block has a different cleanup, and thus
+              ;; the next block has a different cleanup, and thus
               ;; we may want to insert cleanup code between the
-              ;; two blocks at some point.
+              ;; two blocks at some point;
               (not (eq (block-end-cleanup block)
                        (block-start-cleanup next)))
-              ;; The next block has a different home lambda, and
+              ;; the next block has a different home lambda, and
               ;; thus the control transfer is a non-local exit.
               (not (eq (block-home-lambda block)
-                       (block-home-lambda next))))
+                       (block-home-lambda next)))
+              ;; Stack analysis phase wants ENTRY to start a block.
+              (entry-p (block-start-node next)))
              nil)
             (t
              (join-blocks block next)

src/compiler/ir1util.lisp

@@ -220,6 +220,25 @@
       ((:inside-block)
        (node-ends-block (ctran-use ctran)))))
   (values))
+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+  (declare (type ctran ctran))
+  (aver (not (ctran-next ctran)))
+  (ecase (ctran-kind ctran)
+    (:inside-block
+     (let ((block (ctran-block ctran))
+           (node (ctran-use ctran)))
+       (aver (not (block-last block)))
+       (aver node)
+       (setf (block-last block) node)
+       (setf (node-next node) nil)
+       (setf (ctran-use ctran) nil)
+       (setf (ctran-kind ctran) :unused)
+       (setf (ctran-block ctran) nil)
+       (link-blocks block (ctran-starts-block ctran))))
+    (:block-start)))
 
 ;;;;
 
@@ -658,6 +677,30 @@
     (setf (block-prev next) block))
   (values))
 
+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block)
+  (loop for cleanup = (block-end-cleanup block)
+        then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+        while cleanup
+        do (let ((mess-up (cleanup-mess-up cleanup)))
+             (case (cleanup-kind cleanup)
+               ((:block :tagbody)
+                (aver (entry-p mess-up))
+                (loop for exit in (entry-exits mess-up)
+                      for nlx-info = (find-nlx-info exit)
+                      do (funcall fun nlx-info)))
+               ((:catch :unwind-protect)
+                (aver (combination-p mess-up))
+                (let* ((arg-lvar (first (basic-combination-args mess-up)))
+                       (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+                (funcall fun nlx-info)))))))
+
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
 (declaim (ftype (sfunction (component) (values)) clear-flags))

src/compiler/stack.lisp

@@ -43,73 +43,62 @@
 
 ;;;; annotation graph walk
 
-;;; Do a backward walk in the flow graph simulating the run-time stack
-;;; of unknown-values lvars and annotating the blocks with the result.
-;;;
-;;; BLOCK is the block that is currently being walked and STACK is the
-;;; stack of unknown-values lvars in effect immediately after
-;;; block. We simulate the stack by popping off the unknown-values
-;;; generated by this block (if any) and pushing the lvars for
-;;; values received by this block. (The role of push and pop are
-;;; interchanged because we are doing a backward walk.)
-;;;
-;;; If we run into a values generator whose lvar isn't on
-;;; stack top, then the receiver hasn't yet been reached on any walk
-;;; to this use. In this case, we ignore the push for now, counting on
-;;; Annotate-Dead-Values to clean it up if we discover that it isn't
-;;; reachable at all.
-;;;
-;;; If our final stack isn't empty, then we walk all the predecessor
-;;; blocks that don't have all the lvars that we have on our
-;;; START-STACK on their END-STACK. This is our termination condition
-;;; for the graph walk. We put the test around the recursive call so
-;;; that the initial call to this function will do something even
-;;; though there isn't initially anything on the stack.
-;;;
-;;; We can use the tailp test, since the only time we want to bottom
-;;; out with a non-empty stack is when we intersect with another path
-;;; from the same top level call to this function that has more values
-;;; receivers on that path. When we bottom out in this way, we are
-;;; counting on DISCARD-UNUSED-VALUES doing its thing.
-;;;
-;;; When we do recurse, we check that predecessor's END-STACK is a
-;;; subsequence of our START-STACK. There may be extra stuff on the
-;;; top of our stack because the last path to the predecessor may have
-;;; discarded some values that we use. There may be extra stuff on the
-;;; bottom of our stack because this walk may be from a values
-;;; receiver whose lifetime encloses that of the previous walk.
-;;;
-;;; If a predecessor block is the component head, then it must be the
-;;; case that this is a NLX entry stub. If so, we just stop our walk,
-;;; since the stack at the exit point doesn't have anything to do with
-;;; our stack.
-(defun stack-simulation-walk (block stack)
-  (declare (type cblock block) (list stack))
-  (let ((2block (block-info block)))
-    (setf (ir2-block-end-stack 2block) stack)
-    (let ((new-stack stack))
-      (dolist (push (reverse (ir2-block-pushed 2block)))
-	(if (eq (car new-stack) push)
-	    (pop new-stack)
-	    (aver (not (member push new-stack)))))
+;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has
+;;; been changed.
+(defun merge-stacks (early late)
+  (declare (type list early late))
+  (cond ((null early) late)
+        ((null late) early)
+        ((tailp early late) late)
+        ((tailp late early) early)
+        ;; FIXME
+        (t (bug "Lexical unwinding of UVL stack is not implemented."))))
 
-      (dolist (pop (reverse (ir2-block-popped 2block)))
-	(push pop new-stack))
+;;; Update information on stacks of unknown-values LVARs on the
+;;; boundaries of BLOCK. Return true if the start stack has been
+;;; changed.
+(defun stack-update (block)
+  (declare (type cblock block))
+  (declare (optimize (debug 3)))
+  (let* ((2block (block-info block))
+         (end (ir2-block-end-stack 2block))
+         (new-end end)
+         (cleanup (block-end-cleanup block))
+         (found-similar-p nil))
+    (dolist (succ (block-succ block))
+      #+nil
+      (when (and (< block succ)
+                 (eq cleanup (block-end-cleanup succ)))
+        (setq found-similar-p t))
+      (setq new-end (merge-stacks new-end (ir2-block-start-stack (block-info succ)))))
+    (unless found-similar-p
+      (map-block-nlxes (lambda (nlx-info)
+                         (let* ((nle (nlx-info-target nlx-info))
+                                (nle-start-stack (ir2-block-start-stack
+                                                  (block-info nle)))
+                                (exit-lvar (nlx-info-lvar nlx-info)))
+                           (when (eq exit-lvar (car nle-start-stack))
+                             (pop nle-start-stack))
+                           (setq new-end (merge-stacks new-end
+                                                       nle-start-stack))))
+                       block))
 
-      (setf (ir2-block-start-stack 2block) new-stack)
+    (setf (ir2-block-end-stack 2block) new-end)
+    (let ((start new-end))
+      (dolist (push (reverse (ir2-block-pushed 2block)))
+        (if (eq (car start) push)
+            (pop start)
+            (aver (not (member push start)))))
 
-      (when new-stack
-	(dolist (pred (block-pred block))
-	  (if (eq pred (component-head (block-component block)))
-	      (aver (find block
-			  (physenv-nlx-info (block-physenv block))
-			  :key #'nlx-info-target))
-	      (let ((pred-stack (ir2-block-end-stack (block-info pred))))
-		(unless (tailp new-stack pred-stack)
-		  (aver (search pred-stack new-stack))
-		  (stack-simulation-walk pred new-stack))))))))
+      (dolist (pop (reverse (ir2-block-popped 2block)))
+        (push pop start))
 
-  (values))
+      (cond ((equal-but-no-car-recursion start
+                                         (ir2-block-start-stack 2block))
+             nil)
+            (t
+             (setf (ir2-block-start-stack 2block) start)
+             t)))))
 
 ;;; Do stack annotation for any values generators in Block that were
 ;;; unreached by all walks (i.e. the lvar isn't live at the point that
@@ -125,6 +114,8 @@
 ;;; If we see a pushed lvar that is the LVAR of a tail call, then we
 ;;; ignore it, since the tail call didn't actually push anything. The
 ;;; tail call must always the last in the block.
+;;;
+;;; [This function also fixes End-Stack in NLEs.]
 (defun annotate-dead-values (block)
   (declare (type cblock block))
   (let* ((2block (block-info block))
@@ -144,6 +135,34 @@
 	       (setq popping t))))))
 
   (values))
+
+;;; For every NLE block push all LVARs that are live in its ENTRY to
+;;; its start stack. (We cannot pop unused LVARs on a control transfer
+;;; to an NLE block, so we must do it later.)
+(defun fix-nle-block-stacks (component)
+  (declare (type component component))
+  (dolist (block (block-succ (component-head component)))
+    (let ((start-node (block-start-node block)))
+      (unless (bind-p start-node)
+        (let* ((2block (block-info block))
+               (start-stack (block-start-stack 2block))
+               (nlx-ref (ctran-next (node-next start-node)))
+               (nlx-info (constant-value (ref-leaf nlx-ref)))
+               (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info)))
+               (entry-block (node-block mess-up))
+               (entry-stack (ir2-block-start-stack (block-info entry-block)))
+               (exit-lvar (nlx-info-lvar nlx-info)))
+          (when (and exit-lvar
+                     (eq exit-lvar (car start-stack)))
+            (when *check-consistency*
+              (aver (not (memq exit-var entry-stack))))
+            (push exit-var entry-stack))
+          (when *check-consistency*
+            (aver (subsetp start-stack entry-stack)))
+          (setf (ir2-block-start-stack 2block) entry-stack)
+          (setf (ir2-block-end-stack 2block) entry-stack)
+                                        ; ANNOTATE-DEAD-VALUES will do the rest
+          )))))
 
 ;;; This is called when we discover that the stack-top unknown-values
 ;;; lvar at the end of BLOCK1 is different from that at the start of
@@ -215,9 +234,16 @@
     (dolist (block generators)
       (find-pushed-lvars block))
 
-    (dolist (block receivers)
-      (unless (ir2-block-start-stack (block-info block))
-	(stack-simulation-walk block ())))
+    (loop for did-something = nil
+          do (do-blocks-backwards (block component)
+               (when (stack-update block)
+                 (setq did-something t)))
+          while did-something)
+
+    (when *check-consistency*
+      (dolist (block (block-succ (component-head component)))
+        (when (bind-p (block-start-node block))
+          (aver (null (ir2-block-start-stack (block-info block)))))))
 
     (dolist (block generators)
       (annotate-dead-values block))

tests/compiler.pure.lisp

@@ -1033,3 +1033,64 @@
      215067723)
     13739018))
 
+;;; bug 299 (reported by PFD)
+(assert
+ (equal (funcall
+         (compile
+          nil
+          '(lambda ()
+            (declare (optimize (debug 1)))
+            (multiple-value-call #'list
+              (if (eval t) (eval '(values :a :b :c)) nil)
+              (catch 'foo (throw 'foo (values :x :y)))))))
+        '(:a :b :c :x :y)))
+;;; MISC.185
+(assert (equal
+         (funcall
+          (compile
+           nil
+           '(lambda (a b c)
+             (declare (type (integer 5 155656586618) a))
+             (declare (type (integer -15492 196529) b))
+             (declare (type (integer 7 10) c))
+             (declare (optimize (speed 3)))
+             (declare (optimize (safety 1)))
+             (declare (optimize (debug 1)))
+             (flet ((%f3
+                        (f3-1 f3-2 f3-3
+                              &optional (f3-4 a) (f3-5 0)
+                              (f3-6
+                               (labels ((%f10 (f10-1 f10-2 f10-3)
+                                          0))
+                                 (apply #'%f10
+                                        0
+                                        a
+                                        (- (if (equal a b) b (%f10 c a 0))
+                                           (catch 'ct2 (throw 'ct2 c)))
+                                        nil))))
+                      0))
+               (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
+         0))
+;;; MISC.186
+(assert (eq
+         (eval
+          '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
+                          (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
+                  (vars '(b c))
+                  (fn1 `(lambda ,vars
+                          (declare (type (integer -2 19) b)
+                                   (type (integer -1520 218978) c)
+                                   (optimize (speed 3) (safety 1) (debug 1)))
+                          ,form))
+                  (fn2 `(lambda ,vars
+                          (declare (notinline logeqv apply)
+                                   (optimize (safety 3) (speed 0) (debug 0)))
+                          ,form))
+                  (cf1 (compile nil fn1))
+                  (cf2 (compile nil fn2))
+                  (result1 (multiple-value-list (funcall cf1 2 18886)))
+                  (result2 (multiple-value-list (funcall cf2 2 18886))))
+            (if (equal result1 result2)
+                :good
+                (values result1 result2))))
+         :good))