From: Alastair Bridgewater <nyef@arisu.lisphacker.com>
Date: Tue, 22 Nov 2011 18:44:06 +0000 (-0500)
Subject: Fix symbol-value-in-thread GC race condition.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d6e6a3798dc767045cd7495f483bd4d0b6250d00;p=sbcl.git

Fix symbol-value-in-thread GC race condition.

  * SVIT was using SAP-REF-WORD and MAKE-LISP-OBJ while the GC was
enabled, which is mostly-safe on x86oids, but technically breaks
the consistency rules for the GC.  Failures due to badly-timed GC
(well-timed GC?) have been observed on PPC.

  * Instead of SAP-REF-WORD, checking for specific tags, then
using MAKE-LISP-OBJ and checking for validity and GC epoch, which
is a badly-broken approach, use SAP-REF-LISPOBJ to obtain the
value and then check the tags with GET-LISP-OBJ-ADDRESS, a far
safer approach, with lower overhead, and not subject to random GC
lossage.
---

diff --git a/NEWS b/NEWS
index 5906f33..b69cc16 100644
--- a/NEWS
+++ b/NEWS
@@ -71,6 +71,8 @@ changes relative to sbcl-1.0.53:
     <integer> <(complex double)>), EXPT now uses double-precision throughout
     instead of partially calculating only to single-precision.  (lp#741564;
     thanks to Lutz Euler)
+  * bug fix: SYMBOL-VALUE-IN-THREAD is no longer able to construct bogus
+    objects when interrupted by GC on PPC.
 
 changes in sbcl-1.0.53 relative to sbcl-1.0.52:
   * enhancement: on 64-bit targets, in src/compiler/generic/early-vm.lisp,
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index d451bb1..06d49c2 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1527,34 +1527,17 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD."
     (with-all-threads-lock
       (loop
         (if (thread-alive-p thread)
-            (let* ((epoch sb!kernel::*gc-epoch*)
-                   (offset (sb!kernel:get-lisp-obj-address
+            (let* ((offset (sb!kernel:get-lisp-obj-address
                             (sb!vm::symbol-tls-index symbol)))
-                   (tl-val (sap-ref-word (%thread-sap thread) offset)))
+                   (obj (sap-ref-lispobj (%thread-sap thread) offset))
+                   (tl-val (sb!kernel:get-lisp-obj-address obj)))
               (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 obj :ok)))))
             (return (values nil :thread-dead))))))
 
   (defun %set-symbol-value-in-thread (symbol thread value)
@@ -1568,8 +1551,8 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD."
               (cond ((zerop offset)
                      (values nil :no-tls-value))
                     (t
-                     (setf (sap-ref-word (%thread-sap thread) offset)
-                           (get-lisp-obj-address value))
+                     (setf (sap-ref-lispobj (%thread-sap thread) offset)
+                           value)
                      (values value :ok))))
             (values nil :thread-dead)))))