From 178f27312ce8ae38f0afab3ad901c902c6b6a4c9 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 19 Sep 2010 13:07:37 +0000 Subject: [PATCH] 1.0.42.39: workaround for lp#308914 Detect and escape from endless loops in ORDER-UVL-SETS. --- NEWS | 1 + src/compiler/stack.lisp | 40 +++++++++++++++++++++++++--------------- tests/compiler.impure.lisp | 18 ++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 45 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index 6e88fdd..a7e593a 100644 --- 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 --- 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 diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 73f224b..a292eb2 100644 --- 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?")))) ;;;; 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 --- 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" -- 1.7.10.4