X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fstack.lisp;h=4eeae72338ca7c36b1eba32f16b7d78cb43847da;hb=178f27312ce8ae38f0afab3ad901c902c6b6a4c9;hp=51d416dbf9241be14f42ffa8cb7cf57bf9db6e23;hpb=0623c52c838b86cfcf3bd5a5b388324ac51ebaf9;p=sbcl.git

diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 51d416d..4eeae72 100644
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -189,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