From b3907e261afc6af9954b8232b662e04f519f8158 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Wed, 13 Sep 2006 21:37:28 +0000 Subject: [PATCH] 0.9.16.29: The new timer.impure test added in 0.9.16.21 uncovered some completely unrelated problems in a different test. Multiple simultaneous FIND-SYMBOLs on the same package could cause the package to become corrupted in a way that would cause further accesses to it to loop infinitely. This seems a bit harsh. * Remove the optimization (moving the table from which a symbol was found to the front of the package's table list) which was causing this problem. It didn't seem to have much of an performance effect anyway. * Fix the test that was accidentally triggering this bug and add a new test specifically for it. --- src/code/target-package.lisp | 19 +++++++++++++++---- tests/threads.impure.lisp | 17 +++++++++++++++-- tests/timer.impure.lisp | 32 ++++++++++++++++++++++---------- version.lisp-expr | 2 +- 4 files changed, 53 insertions(+), 17 deletions(-) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index c9ff756..914e9ea 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -694,8 +694,7 @@ error if any of PACKAGES is not a valid package designator." (values symbol nil)))))))) ;;; Check internal and external symbols, then scan down the list -;;; of hashtables for inherited symbols. When an inherited symbol -;;; is found pull that table to the beginning of the list. +;;; of hashtables for inherited symbols. (defun find-symbol* (string length package) (declare (simple-string string) (type index length)) @@ -716,8 +715,20 @@ error if any of PACKAGES is not a valid package designator." ((null table) (values nil nil)) (with-symbol (found symbol (car table) string length hash ehash) (when found - (unless (eq prev head) - (shiftf (cdr prev) (cdr table) (cdr head) table)) + ;; At this point we used to move the table to the + ;; beginning of the list, probably on the theory that we'd + ;; soon be looking up further items there. Unfortunately + ;; that was very much non-thread safe. Since the failure + ;; mode was nasty (corruption of the package in a way + ;; which would make symbol lookups loop infinitely) and it + ;; would be triggered just by doing reads to a resource + ;; that users can't do their own locking on, that code has + ;; been removed. If we ever add locking to packages, + ;; resurrecting that code might make sense, even though it + ;; didn't seem to have much of an performance effect in + ;; normal use. + ;; + ;; -- JES, 2006-09-13 (return-from find-symbol* (values symbol :inherited)))))))) ;;; Similar to FIND-SYMBOL, but only looks for an external symbol. diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index ed87761..43a60f3 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -654,6 +654,19 @@ (format t "infodb test done~%") +(with-test (:name (:backtrace)) + ;; Printing backtraces from several threads at once used to hang the + ;; whole SBCL process (discovered by accident due to a timer.impure + ;; test misbehaving). The cause was that packages weren't even + ;; thread-safe for only doing FIND-SYMBOL, and while printing + ;; backtraces a loot of symbol lookups need to be done due to + ;; *PRINT-ESCAPE*. + (let* ((threads (loop repeat 10 + collect (sb-thread:make-thread + (lambda () + (dotimes (i 1000) + (with-output-to-string (*debug-io*) + (sb-debug::backtrace 10)))))))) + (wait-for-threads threads))) - - +(format t "backtrace test done~%") diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp index 8a66453..220c659 100644 --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp @@ -13,6 +13,10 @@ (use-package :test-util) +(defmacro raises-timeout-p (&body body) + `(handler-case (progn (progn ,@body) nil) + (sb-ext:timeout () t))) + (with-test (:name (:timer :relative)) (let* ((has-run-p nil) (timer (make-timer (lambda () (setq has-run-p t)) @@ -84,10 +88,6 @@ (sleep 2) (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*)))))) -(defmacro raises-timeout-p (&body body) - `(handler-case (progn (progn ,@body) nil) - (sb-ext:timeout () t))) - (with-test (:name (:with-timeout :timeout)) (assert (raises-timeout-p (sb-ext:with-timeout 0.2 @@ -110,14 +110,26 @@ (sb-ext:with-timeout 2 (sleep 2)))))) +(defun wait-for-threads (threads) + (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01))) + #+sb-thread (with-test (:name (:with-timeout :many-at-the-same-time)) - (loop repeat 10 do - (sb-thread:make-thread - (lambda () - (sb-ext:with-timeout 0.5 - (sleep 5) - (assert nil)))))) + (let ((ok t)) + (let ((threads (loop repeat 10 collect + (sb-thread:make-thread + (lambda () + (handler-case + (sb-ext:with-timeout 0.5 + (sleep 5) + (setf ok nil) + (format t "~%not ok~%")) + (timeout () + ))))))) + (assert (not (raises-timeout-p + (sb-ext:with-timeout 20 + (wait-for-threads threads))))) + (assert ok)))) #+sb-thread (with-test (:name (:with-timeout :dead-thread)) diff --git a/version.lisp-expr b/version.lisp-expr index b3d0e9f..6c804ea 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".) -"0.9.16.28" +"0.9.16.29" -- 1.7.10.4