common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix %SYMBOL-VALUE-IN-THREAD when TLS index > 0 but not in TLS

Browse source 
This case should return :NO-TLS-VALUE, not :UNBOUND-IN-THREAD.
UNBOUND-IN-THREAD means there exists a binding that is valueless.
(Curse this overloaded term "bound")

Whether a symbol has ever had a TLS index assigned must not affect
the distinction between these. i.e. If *A-VAR* has a TLS index of 0,
and a thread does nothing more than loop repeatedly checking
  (%SYMBOL-VALUE-IN-THREAD '*A-VAR* *CURRENT-THREAD*)
then just because any thread decides to actually bind *A-VAR*,
the preceding inquiry can not magically change from :NO-TLS-VALUE
in the thread that never took any action to bind it.
This commit is contained in:
Douglas Katzman 2018-03-09 13:51:43 -05:00
parent dde8ed3fae
commit 32e65993b9
2 changed files with 8 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
src/code/target-thread.lisp
View file

@ -1795,21 +1795,17 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD."
#!+ppc ; only PPC uses a separate symbol for the TLS index lock
(!defglobal sb!vm::*tls-index-lock* 0)
(defun %symbol-value-in-thread (symbol thread)
(defun %symbol-value-in-thread (symbol thread)
;; Prevent the thread from dying completely while we look for the TLS
;; area...
(with-all-threads-lock
(if (thread-alive-p thread)
(let* ((offset (get-lisp-obj-address (symbol-tls-index symbol)))
(obj (sap-ref-lispobj (int-sap (thread-primitive-thread thread)) offset))
(tl-val (get-lisp-obj-address obj)))
(cond ((zerop offset)
(values nil :no-tls-value))
((or (eql tl-val sb!vm:no-tls-value-marker-widetag)
(eql tl-val sb!vm:unbound-marker-widetag))
(values nil :unbound-in-thread))
(t
(values obj :ok))))
(let ((val (sap-ref-lispobj (int-sap (thread-primitive-thread thread))
(get-lisp-obj-address (symbol-tls-index symbol)))))
(case (get-lisp-obj-address val)
(#.sb!vm:no-tls-value-marker-widetag (values nil :no-tls-value))
(#.sb!vm:unbound-marker-widetag (values nil :unbound-in-thread))
(t (values val :ok))))
(values nil :thread-dead))))
(defun %set-symbol-value-in-thread (symbol thread value)

2
tests/threads.pure.lisp
View file

@ -249,7 +249,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-in-thread))
(assert (equal (list *current-thread* 'this-is-new (list :read :no-tls-value))
(join-thread child)))))
(with-test (:name :symbol-value-in-thread.6 :skipped-on (not :sb-thread))