t) into test-forms
finally (return `(progn ,@test-forms))))
) ; EVAL-WHEN
-
+
(macrolet
((define-rfc1321-tests (test-list)
`(progn
--- /dev/null
+@node Specials
+@comment node-name, next, previous, up
+@chapter Specials
+
+@menu
+* Overview::
+* Binding and unbinding::
+@end menu
+
+@node Overview
+@section Overview
+
+Unithread SBCL uses a shallow binding scheme: the current value of a
+symbol is stored directly in its value slot. Accessing specials is
+pretty fast but it's still a lot slower than accessing lexicals.
+
+With multithreading it's slightly more complicated. The symbol's value
+slot contains the global value and each symbol has a @code{TLS-INDEX}
+slot that - when it's first bound - is set to a unique index of the
+thread local area reserved for this purpose. The tls index is
+initially zero and at index zero in the tls @code{NO-TLS-VALUE-MARKER}
+resides. @code{NO-TLS-VALUE-MARKER} is different from
+@code{UNBOUND-MARKER} to allow @code{PROGV} to bind a special to no
+value locally in a thread.
+
+@node Binding and unbinding
+@section Binding and unbinding
+
+Binding goes like this: the binding stack pointer (bsp) is bumped, old
+value and symbol are stored at bsp - 1, new value is stored in
+symbol's value slot or the tls.
+
+Unbinding: the symbol's value is restored from bsp - 1, value and
+symbol at bsp - 1 are set to zero, and finally bsp is decremented.
+
+The @code{UNBIND-TO-HERE} VOP assists in unwinding the stack. It
+iterates over the bindings on the binding stack until it reaches the
+prescribed point. For each binding with a non-zero symbol it does an
+@code{UNBIND}.
+
+How can a binding's symbol be zero? @code{BIND} is not pseudo atomic
+(for performance reasons) and it can be interrupted by a signal. If
+the signal hits after the bsp is incremented but before the values on
+the stack are set the symbol is zero because a thread starts with a
+zeroed tls plus @code{UNBIND} and @code{UNBIND-TO-HERE} both zero the
+binding being unbound.
+
+Zeroing the binding's symbol would not be enough as the binding's
+value can be moved or garbage collected and if the above interrupt
+initiates gc (or be @code{SIG_STOP_FOR_GC}) it will be greeted by a
+garbage pointer.
+
+Furthermore, @code{BIND} must always write the value to the binding
+stack first and the symbol second because the symbol being non-zero
+means validity to @code{UNBIND-TO-HERE}.
(loadw value bsp-tn (- binding-value-slot binding-size))
(#!+gengc storew-and-remember-slot #!-gengc storew
value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)))
(inst beq symbol skip)
(#!+gengc storew-and-remember-slot #!-gengc storew
value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(emit-label skip)
(loadw symbol bsp-tn (- binding-symbol-slot binding-size))
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
(inst comb := symbol zero-tn skip)
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
SKIP
(loadw symbol bsp-tn (- binding-symbol-slot binding-size))
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(inst addu bsp-tn bsp-tn (* -2 n-word-bytes))))
(inst beq symbol zero-tn skip)
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(emit-label skip)
(loadw symbol bsp-tn (- binding-symbol-slot binding-size))
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-symbol-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
(inst beq skip)
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-symbol-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(emit-label skip)
(loadw symbol bsp-tn (- binding-symbol-slot binding-size))
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
(inst b :eq skip)
(loadw value bsp-tn (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew zero-tn bsp-tn (- binding-value-slot binding-size))
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(emit-label skip)
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
value)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
(store-binding-stack-pointer bsp)))
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
(store-symbol-value bsp *binding-stack-pointer*)))
#!+sb-thread
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
value)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index tls-index) value)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
(store-binding-stack-pointer bsp)))
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
(store-symbol-value bsp *binding-stack-pointer*)))
tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
#!+sb-thread (inst fs-segment-prefix)
#!+sb-thread (inst mov (make-ea :dword :scale 1 :index tls-index) value)
+ (storew 0 bsp (- binding-value-slot binding-size))
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(lambda ()
(sb-ext:run-program "sleep" '("1") :search t :wait nil)))
+;;;; Binding stack safety
+
+(defparameter *x* nil)
+(defparameter *n-gcs-requested* 0)
+(defparameter *n-gcs-done* 0)
+
+(let ((counter 0))
+ (defun make-something-big ()
+ (let ((x (make-string 32000)))
+ (incf counter)
+ (let ((counter counter))
+ (sb-ext:finalize x (lambda () (format t " ~S" counter)
+ (force-output)))))))
+
+(defmacro wait-for-gc ()
+ `(progn
+ (incf *n-gcs-requested*)
+ (loop while (< *n-gcs-done* *n-gcs-requested*))))
+
+(defun send-gc ()
+ (loop until (< *n-gcs-done* *n-gcs-requested*))
+ (format t "G" *n-gcs-requested* *n-gcs-done*)
+ (force-output)
+ (sb-ext:gc)
+ (incf *n-gcs-done*))
+
+(defun exercise-binding ()
+ (loop
+ (let ((*x* (make-something-big)))
+ (let ((*x* 42))
+ ;; at this point the binding stack looks like this:
+ ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
+ t))
+ (wait-for-gc)
+ ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
+ ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
+ ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
+ ;; unbinding but values are not).
+ (let ((*x* nil))
+ ;; bump bsp as if a BIND had just started
+ (incf sb-vm::*binding-stack-pointer* 2)
+ (wait-for-gc)
+ (decf sb-vm::*binding-stack-pointer* 2))))
+
+(with-test (:name (:binding-stack-gc-safety))
+ (let (threads)
+ (unwind-protect
+ (progn
+ (push (sb-thread:make-thread #'exercise-binding) threads)
+ (push (sb-thread:make-thread (lambda ()
+ (loop
+ (send-gc))))
+ threads)
+ (sleep 4))
+ (mapc #'sb-thread:terminate-thread threads))))
+
+(format t "~&binding test done~%")
+
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
;;; 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.6.47"
+"0.9.6.48"
projects / sbcl.git / commitdiff