Re: [Sbcl-devel] Patch for review: *default-special-bindings* for new threads

[Max M. <ma...@op...>]

At Sat, 29 Jul 2006 13:26:35 +0200,


G=E1bor Melis wrote:
>=20
> Here is a scenario in which this approach fails to protect against=20
> threads sharing a binding. A library has a special that it declares=20
> thread local. Threads started after the library is loaded will=20
> correctly have thread local bindings for the special. But a thread that=20
> was started before the library was loaded will see the global binding=20
> of the special. If such a thread calls into the lib or accesses the=20
> value of the special in another way lossage is imminent. How can such a=20
> thread depend on that special? Lots of ways: defining an around method=20
> on a method which called, calling callbacks, using symbol-value and=20
> find-symbol.  Any kind of dependency injection has a chance to fall=20
> flat.
>=20
> In case it is not clear yet, I argue that this solution is a good one if =

> and only if there is a single thread in the system at the time of=20
> define-thread-local-*. That constraint is trivially satisfied by sbcl=20
> internals but makes it dangerously overpromising for user code.
>=20
> How to make it safe for user code?
>=20
> 1) check if there is only one thread at the time of=20
> define-thread-local-*
>=20
> Bleh. I'd hate not being able to load a library because multiple threads =

> are running.
>=20
> or
>=20
> 2) thread local specials must have no global binding
>=20
> Makes sense to me. How to implement it is another question.

Any critique to the following approach?

Below code is a method of injecting a thread-local value into threads
that are already running, tt handles 2 cases :

  a) (defun my-thread () (print *var*) (setq *var* 'local-to-this-thread))

  In the above case if the (make-symbol-thread-local) was executed
  before thread entered print form, it would get a default per/thread
  value. The setq would set a per-thread value

  b) (defun my-thread () (let ((*var* 'local-value-a)) (print *var*))
  (print *var) (setq *var* 'local-to-this-tread))

  In the above case when thread already have a special bound, and
  (make-symbol-thread-local...) is executed somewhere else while
  thread is inside of the (let) form, then once thread exits the (let)
  form then new thread-local value of *var* would be restored instead
  of the old global value

  (I tested it with as much as 16 threads on 4 way opteron, so IMHO
  its pretty safe).=20


;;; make the symbol thread local and default to value
;;; in all running threads
(defun make-symbol-thread-local (symbol value)
  (unless (eq (sb-c::info :variable :kind symbol) :special)
    (error "Symbol ~S must be special variable" symbol))
  (progv (list symbol) nil
    ;; above progv binds the symbol in the current thread making
    ;; sure that TLS index is allocated
    (let ((tls-index (sb-vm::symbol-tls-index symbol)))
      (sb-vm::without-gcing=20
	(sb-kernel::gc-stop-the-world)
	;; all threads except this one are now stopped so
	;; we should be safe to do do our thing now
	(fix-symbol-value-in-all-threads symbol tls-index value)
	(sb-kernel::gc-start-the-world)
	)))
  (values))

(defun fix-symbol-value-in-all-threads (symbol tls-index value)
  (declare (type symbol symbol) (type fixnum tls-index))
  (loop
     as thread-sap =3D (alien-sap (extern-alien "all_threads" (* t)))
     then (sb-vm::sap-ref-sap thread-sap (* sb-vm:n-word-bytes
				     sb-vm::thread-next-slot))
     while (not (sb-vm::sap=3D thread-sap (sb-vm::int-sap 0)))
     do (fix-symbol-value-in-one-thread thread-sap symbol tls-index value))
  (values))
	=20
(defun fix-symbol-value-in-one-thread (thread-sap symbol tls-index value)
  (declare (type system-area-pointer thread-sap)=20
	   (type symbol symbol)=20
	   (type fixnum tls-index))
  (let ((was-bound-p nil))
    (loop=20
       ;; search the binding stack for the first binding of symbol
       with end =3D (sb-vm::sap-ref-sap thread-sap (* sb-vm::n-word-bytes
						    sb-vm::thread-binding-stack-pointer-slot))
       as bsp =3D (sb-vm::sap-ref-sap thread-sap (* sb-vm::n-word-bytes
						  sb-vm::thread-binding-stack-start-slot))
       then (sb-vm::sap+ bsp (* sb-vm::binding-size sb-vm:n-word-bytes))
       while (sb-vm::sap< bsp end)
       as previous-value =3D (sb-vm::make-lisp-obj (sb-vm::sap-ref-word bsp=
 0))
       as binding-symbol =3D (sb-vm::make-lisp-obj (sb-vm::sap-ref-word bsp=
 sb-vm::n-word-bytes))
       ;; if found the binding for a symbol, update the previous value
       ;; so that after unbind the new default per-thread value is restored
       when (eq binding-symbol symbol)
       do (setq was-bound-p t)
       and do (setf (sb-vm::sap-ref-word bsp 0)=20
		    (sb-kernel::get-lisp-obj-address value))
       and return nil)
    (unless was-bound-p
      ;; if symbol was not bound in the thread, then set the TLS value
      ;; directly. This creates a situation where a thread have a TLS=20
      ;; value of a special without the previous value of the special
      ;; being on the binding stack, therefore such thread would never see
      ;; the global value even again.
      ;;
      ;; In case I discover it does cause problems we can also update
      ;; the binding stack here and add an entry
      (setf (sb-vm::sap-ref-word thread-sap (* sb-vm::n-word-bytes tls-inde=
x))
	    (sb-kernel::get-lisp-obj-address value))))
  (values))

;;; testing

(defparameter *test1* 'global-value)      ;; will become local

(defun get-symbol-global-value (symbol)
  ;; below progv forces to use global symbol value
  (progv (list symbol) (list (sb-kernel:make-lisp-obj
			      sb-vm::no-tls-value-marker-widetag))
    (symbol-value symbol)))

(defun set-symbol-global-value (symbol value)
  ;; below progv forces to set global symbol value
  (progv (list symbol) (list (sb-kernel:make-lisp-obj
			      sb-vm::no-tls-value-marker-widetag))
    (setf (symbol-value symbol) value)))


(assert (eq (get-symbol-global-value '*test1*) 'global-value))

(defun thread-fun ()
  (loop=20
     (cond ((eq *test1* 'global-value) nil)
	   ((eq *test1* 'local-value)
	    (setq *test1* 'baz) (return nil))
	   (t (error "Invalid value ~S" *test1*)))))

(defun test-1 ()
  (set-symbol-global-value '*test1* 'global-value)
  ; number of threads to start
  (dotimes (i 4) (sb-thread::make-thread #'thread-fun))
  (make-symbol-thread-local '*test1* 'local-value)
  ;; now change global value
  (set-symbol-global-value '*test1* 'blah)
  (assert (eq (get-symbol-global-value '*test1*) 'blah))
  ;; this changes this local thread value
  (setq *test1* 'foobar)
  (assert (eq (symbol-value '*test1*) 'foobar))
  )
=20