1.0.42.39: workaround for lp#308914

 Detect and escape from endless loops in ORDER-UVL-SETS.

diff --git a/NEWS b/NEWS
index 6e88fdd..a7e593a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -43,6 +43,7 @@ changes relative to sbcl-1.0.42
     DEFUN when the symbol previously had a macro definition. (lp#576637)
   * bug fix: spurious ignore warnings even given (DECLARE IGNORE) in methods
     when parameter bindings mutated.  (reported by Faré Rideau; lp #611361)
+  * bug fix: workaround for compiler hang in ORDER-UVL-SETS (lp#308914)
 
 changes in sbcl-1.0.42 relative to sbcl-1.0.41
 

diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 51d416d..4eeae72 100644 (file)
--- 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)))
 \f
 ;;; 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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 73f224b..a292eb2 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1209,6 +1209,24 @@
       (bug-308951-foo z)
       (values x)))
   (assert (= 4 (bug-308951-bar 1))))
+
+(declaim (inline bug-308914-storage))
+(defun bug-308914-storage (x)
+  (the (simple-array flt (*)) (bug-308914-unknown x)))
+
+(with-test (:name :bug-308914-workaround)
+  ;; This used to hang in ORDER-UVL-SETS.
+  (handler-case
+      (with-timeout 10
+        (compile nil
+                 `(lambda (lumps &key cg)
+                    (let ((nodes (map 'list (lambda (lump)
+                                              (bug-308914-storage lump))
+                                      lumps)))
+                      (setf (aref nodes 0) 2)
+                      (assert (every #'~= (apply #'concatenate 'list nodes) '(2 3 6 9)))))))
+    (sb-ext:timeout ()
+      (error "Hang in ORDER-UVL-SETS?"))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
index bbbfc48..429c5bf 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".)
-"1.0.42.38"
+"1.0.42.39"