X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fstack.lisp;h=4eeae72338ca7c36b1eba32f16b7d78cb43847da;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=4ac4c7af2d82b5651b800da1dd2fd33a1b5b315c;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git

diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 4ac4c7a..4eeae72 100644
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -61,6 +61,7 @@
 ;;; been changed.
 (defun merge-uvl-live-sets (early late)
   (declare (type list early late))
+  ;; FIXME: O(N^2)
   (dolist (e late early)
     (pushnew e early)))
 
@@ -93,21 +94,28 @@
                      block
                      (lambda (dx-cleanup)
                        (dolist (lvar (cleanup-info dx-cleanup))
-                         (let* ((generator (lvar-use lvar))
-                                (block (node-block generator))
-                                (2block (block-info block)))
-                           ;; DX objects, living in the LVAR, are
-                           ;; alive in the environment, protected by
-                           ;; the CLEANUP. We also cannot move them
-                           ;; (because, in general, we cannot track
-                           ;; all references to them). Therefore,
-                           ;; everything, allocated deeper than a DX
-                           ;; object, should be kept alive until the
-                           ;; object is deallocated.
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-end-stack 2block)))
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-pushed 2block)))))))
+                         (do-uses (generator lvar)
+                           (let* ((block (node-block generator))
+                                  (2block (block-info block)))
+                             ;; DX objects, living in the LVAR, are alive in
+                             ;; the environment, protected by the CLEANUP. We
+                             ;; also cannot move them (because, in general, we
+                             ;; cannot track all references to them).
+                             ;; Therefore, everything, allocated deeper than a
+                             ;; DX object -- that is, before the DX object --
+                             ;; should be kept alive until the object is
+                             ;; deallocated.
+                             ;;
+                             ;; Since DX generators end their blocks, we can
+                             ;; find out UVLs allocated before them by looking
+                             ;; at the stack at the end of the block.
+                             ;;
+                             ;; FIXME: This is not quite true: REFs to DX
+                             ;; closures don't end their blocks!
+                             (setq new-end (merge-uvl-live-sets
+                                            new-end (ir2-block-end-stack 2block)))
+                             (setq new-end (merge-uvl-live-sets
+                                            new-end (ir2-block-pushed 2block))))))))
 
     (setf (ir2-block-end-stack 2block) new-end)
 
@@ -181,22 +189,32 @@
 
 (defun order-uvl-sets (component)
   (clear-flags component)
+  ;; KLUDGE: Workaround for lp#308914: we keep track of number of blocks
+  ;; needing repeats, and bug out if we get stuck.
   (loop with head = (component-head component)
-        with repeat-p do
-        (setq repeat-p nil)
-        (do-blocks (block component)
-          (unless (block-flag block)
-            (let ((pred (find-if #'block-flag (block-pred block))))
-              (when (and (eq pred head)
-                         (not (bind-p (block-start-node block))))
-                (let ((entry (nle-block-entry-block block)))
-                  (setq pred (if (block-flag entry) entry nil))))
-              (cond (pred
-                     (setf (block-flag block) t)
-                     (order-block-uvl-sets block pred))
-                    (t
-                     (setq repeat-p t))))))
-        while repeat-p))
+        with todo = 0
+        with last-todo = 0
+        do (psetq last-todo todo
+                  todo 0)
+        do (do-blocks (block component)
+             (unless (block-flag block)
+               (let ((pred (find-if #'block-flag (block-pred block))))
+                 (when (and (eq pred head)
+                            (not (bind-p (block-start-node block))))
+                   (let ((entry (nle-block-entry-block block)))
+                     (setq pred (if (block-flag entry) entry nil))))
+                 (cond (pred
+                        (setf (block-flag block) t)
+                        (order-block-uvl-sets block pred))
+                       (t
+                        (incf todo))))))
+        do (when (= last-todo todo)
+             ;; If the todo count is the same as on last iteration, it means
+             ;; we are stuck, which in turn means the unmarked blocks are
+             ;; actually unreachable, so UVL set ordering for them doesn't
+             ;; matter.
+             (return-from order-uvl-sets))
+        while (plusp todo)))
 
 ;;; 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