From b18df732481502bca0040c56685979712ec58754 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Jun 2009 19:19:44 +0000 Subject: [PATCH] 1.0.29.19: robustify SYMBOL-VALUE-IN-THREAD * Deal with UNBOUND-MARKER-WIDETAG, bogus values, and GC potentially moving the object. * Disable one of the test on Darwin as it deadlocks for reasons which seem to have nothing to do with S-V-I-T, but rather re-entrancy and signal-handler safety of OS provided C functions. --- src/code/target-thread.lisp | 83 +++++++++++++++++++++++++++---------------- tests/threads.pure.lisp | 55 +++++++++++++++++----------- version.lisp-expr | 2 +- 3 files changed, 89 insertions(+), 51 deletions(-) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 7cf305d..a73ec31 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -37,14 +37,16 @@ read by the function THREAD-ERROR-THREAD.")) (cell-error-name condition) (thread-error-thread condition) (ecase problem - (:unbound "the symbol is unbound in thread.") - (:dead "the thread has exited.")))))) + (:unbound-in-thread "the symbol is unbound in thread.") + (:no-tls-value "the symbol has no thread-local value.") + (:thread-dead "the thread has exited.") + (:invalid-tls-value "the thread-local value is not valid.")))))) #!+sb-doc (:documentation - "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to the -symbol being unbound in target thread, or the target thread having exited. The -offending symbol can be accessed using CELL-ERROR-NAME, and the offending -thread using THREAD-ERROR-THREAD.")) + "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to eg. +the symbol not having a thread-local value, or the target thread having +exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the +offending thread using THREAD-ERROR-THREAD.")) (define-condition join-thread-error (thread-error) () (:report (lambda (c s) @@ -1085,17 +1087,40 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" sb!vm::thread-next-slot))))))) (defun %symbol-value-in-thread (symbol thread) - ;; Prevent the thread from dying completely while we look for the TLS - ;; area... + ;; Prevent the thread from dying completely while we look for the TLS + ;; area... (with-all-threads-lock - (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes - (sb!vm::symbol-tls-index symbol))) - (tl-val (sap-ref-word (%thread-sap thread) offset))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (values nil :unbound) - (values (make-lisp-obj tl-val) :bound))) - (values nil :dead)))) + (loop + (if (thread-alive-p thread) + (let* ((epoch sb!kernel::*gc-epoch*) + (offset (* sb!vm:n-word-bytes + (sb!vm::symbol-tls-index symbol))) + (tl-val (sap-ref-word (%thread-sap thread) offset))) + (cond ((zerop offset) + (return (values nil :no-tls-value))) + ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) + (eql tl-val sb!vm:unbound-marker-widetag)) + (return (values nil :unbound-in-thread))) + (t + (multiple-value-bind (obj ok) (make-lisp-obj tl-val nil) + ;; The value we constructed may be invalid if a GC has + ;; occurred. That is harmless, though, since OBJ is + ;; either in a register or on stack, and we are + ;; conservative on both on GENCGC -- so a bogus object + ;; is safe here as long as we don't return it. If we + ;; ever port threads to a non-conservative GC we must + ;; pin the TL-VAL address before constructing OBJ, or + ;; make WITH-ALL-THREADS-LOCK imply WITHOUT-GCING. + ;; + ;; The reason we don't just rely on TL-VAL pinning the + ;; object is that the call to MAKE-LISP-OBJ may cause + ;; bignum allocation, at which point TL-VAL might not + ;; be alive anymore -- hence the epoch check. + (when (eq epoch sb!kernel::*gc-epoch*) + (if ok + (return (values obj :ok)) + (return (values obj :invalid-tls-value)))))))) + (return (values nil :thread-dead)))))) (defun %set-symbol-value-in-thread (symbol thread value) (with-pinned-objects (value) @@ -1103,17 +1128,15 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;; area... (with-all-threads-lock (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes - (sb!vm::symbol-tls-index symbol))) - (sap (%thread-sap thread)) - (tl-val (sap-ref-word sap offset))) - (cond ((eql tl-val sb!vm::no-tls-value-marker-widetag) - (values nil :unbound)) + (let ((offset (* sb!vm:n-word-bytes + (sb!vm::symbol-tls-index symbol)))) + (cond ((zerop offset) + (values nil :no-tls-value)) (t - (setf (sap-ref-word sap offset) + (setf (sap-ref-word (%thread-sap thread) offset) (get-lisp-obj-address value)) - (values value :bound)))) - (values nil :dead)))))) + (values value :ok)))) + (values nil :thread-dead)))))) (defun symbol-value-in-thread (symbol thread &optional (errorp t)) "Return the local value of SYMBOL in THREAD, and a secondary value of T @@ -1127,11 +1150,11 @@ NIL, and a secondary value of NIL. Can also be used with SETF to change the thread-local value of SYMBOL. SYMBOL-VALUE-IN-THREAD is primarily intended as a debugging tool, and not as a -mechanism form inter-thread communication." +mechanism for inter-thread communication." (declare (symbol symbol) (thread thread)) #!+sb-thread (multiple-value-bind (res status) (%symbol-value-in-thread symbol thread) - (if (eq :bound status) + (if (eq :ok status) (values res t) (if errorp (error 'symbol-value-in-thread-error @@ -1146,14 +1169,14 @@ mechanism form inter-thread communication." (error 'symbol-value-in-thread-error :name symbol :thread thread - :info (list :read :unbound)) + :info (list :read :unbound-in-thread)) (values nil nil)))) (defun (setf symbol-value-in-thread) (value symbol thread &optional (errorp t)) (declare (symbol symbol) (thread thread)) #!+sb-thread (multiple-value-bind (res status) (%set-symbol-value-in-thread symbol thread value) - (if (eq :bound status) + (if (eq :ok status) (values res t) (if errorp (error 'symbol-value-in-thread-error @@ -1168,7 +1191,7 @@ mechanism form inter-thread communication." (error 'symbol-value-in-thread-error :name symbol :thread thread - :info (list :write :unbound)) + :info (list :write :unbound-in-thread)) (values nil nil)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index b8ca206..8bfeea8 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -180,28 +180,41 @@ (assert (= 42 (join-thread child))) (assert (eq :from-child (symbol-value 'this-is-new)))))) -#+sb-thread +;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks, +;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an +;;; interrupted malloc in one thread can apparently block a free in another. There +;;; are also some indications that pthread_mutex_lock is not re-entrant. +#+(and sb-thread (not darwin)) (with-test (:name symbol-value-in-thread.3) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (running t) (noise (make-thread (lambda () (loop while running - do (setf * (make-array 1024))))))) - - (loop repeat 10000 - do (let* ((mom-mark (cons t t)) - (kid-mark (cons t t)) - (child (make-thread (lambda () - (wait-on-semaphore semaphore) - (let ((old (symbol-value-in-thread 'this-is-new parent))) - (setf (symbol-value-in-thread 'this-is-new parent) - (make-array 24 :initial-element kid-mark)) - old))))) - (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark)) - (signal-semaphore semaphore) - (assert (eq mom-mark (aref (join-thread child) 0))) - (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0)))))) + do (setf * (make-array 1024)) + ;; Busy-wait a bit so we don't TOTALLY flood the + ;; system with GCs: a GC occurring in the middle of + ;; S-V-I-T causes it to start over -- we want that + ;; to occur occasionally, but not _all_ the time. + (loop repeat (random 128) + do (setf ** *))))))) + (write-string "; ") + (dotimes (i 15000) + (when (zerop (mod i 200)) + (write-char #\.) + (force-output)) + (let* ((mom-mark (cons t t)) + (kid-mark (cons t t)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (let ((old (symbol-value-in-thread 'this-is-new parent))) + (setf (symbol-value-in-thread 'this-is-new parent) + (make-array 24 :initial-element kid-mark)) + old))))) + (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark)) + (signal-semaphore semaphore) + (assert (eq mom-mark (aref (join-thread child) 0))) + (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0)))))) (setf running nil) (join-thread noise))) @@ -228,7 +241,7 @@ (cell-error-name e) (sb-thread::symbol-value-in-thread-error-info e)))))))) (signal-semaphore semaphore) - (assert (equal (list *current-thread* 'this-is-new (list :read :unbound)) + (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread)) (join-thread child))))) #+sb-thread @@ -246,7 +259,7 @@ (sb-thread::symbol-value-in-thread-error-info e)))))))) (signal-semaphore semaphore) (let ((res (join-thread child)) - (want (list *current-thread* name (list :write :unbound)))) + (want (list *current-thread* name (list :write :no-tls-value)))) (unless (equal res want) (error "wanted ~S, got ~S" want res))))) @@ -258,7 +271,8 @@ (symbol-value-in-thread-error (e) (assert (eq child (thread-error-thread e))) (assert (eq 'this-is-new (cell-error-name e))) - (assert (equal (list :read :dead) (sb-thread::symbol-value-in-thread-error-info e))))))) + (assert (equal (list :read :thread-dead) + (sb-thread::symbol-value-in-thread-error-info e))))))) #+sb-thread (with-test (:name symbol-value-in-thread.8) @@ -268,4 +282,5 @@ (symbol-value-in-thread-error (e) (assert (eq child (thread-error-thread e))) (assert (eq 'this-is-new (cell-error-name e))) - (assert (equal (list :write :dead) (sb-thread::symbol-value-in-thread-error-info e))))))) + (assert (equal (list :write :thread-dead) + (sb-thread::symbol-value-in-thread-error-info e))))))) diff --git a/version.lisp-expr b/version.lisp-expr index e321dac..0d6ee76 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.29.18" +"1.0.29.19" -- 1.7.10.4