Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] 1.0.46.42: more on threads in SB-INTROSPECT:MAP-ROOT
From: Nikodemus Siivola <nikodemus@ra...> - 2011-03-22 17:00
|
1.0.46.42: more on threads in SB-INTROSPECT:MAP-ROOT
* Thread local values: filter out invalid values correctly (oops),
also change SB-THREAD::%THREAD-LOCAL-REFERENCES to work on current
thread only.
* References from stack: SB-VM::MAP-STACK-REFERENCES walks the
current thread stack looking for things that look like references
to heap objects.
* MAP-ROOT interrupts the thread it wants to check out, unless it is
the current one -- a bit tacky, but seems preferable to stopping
the world.
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5226
diff -u -r1.5226 version.lisp-expr
--- version.lisp-expr 22 Mar 2011 16:49:33 -0000 1.5226
+++ version.lisp-expr 22 Mar 2011 16:54:29 -0000
@@ -20,4 +20,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.46.41"
+"1.0.46.42"
Index: contrib/sb-introspect/introspect.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/introspect.lisp,v
retrieving revision 1.13
diff -u -r1.13 introspect.lisp
--- contrib/sb-introspect/introspect.lisp 20 Mar 2011 18:37:55 -0000 1.13
+++ contrib/sb-introspect/introspect.lisp 22 Mar 2011 16:54:30 -0000
@@ -886,7 +886,7 @@
thread-local symbol values in other threads fall into this category.
NOTE: calling MAP-ROOT with a THREAD does not currently map over
-conservative roots from the thread stack & interrupt contexts.
+conservative roots from the thread registers and interrupt contexts.
Experimental: interface subject to change."
(let ((fun (coerce function 'function))
@@ -928,8 +928,27 @@
(dotimes (i (- len nuntagged))
(call (sb-kernel:%instance-ref object i))))
(when (typep object 'sb-thread:thread)
- (dolist (value (sb-thread::%thread-local-values object))
- (call value))))
+ (cond ((eq object sb-thread:*current-thread*)
+ (dolist (value (sb-thread::%thread-local-references))
+ (call value))
+ (sb-vm::map-stack-references #'call))
+ (t
+ ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
+ ;; the alternative would be stopping the world...
+ #+sb-thread
+ (let ((sem (sb-thread:make-semaphore))
+ (refs nil))
+ (handler-case
+ (progn
+ (sb-thread:interrupt-thread
+ object
+ (lambda ()
+ (setf refs (sb-thread::%thread-local-references))
+ (sb-vm::map-stack-references (lambda (x)
(push x refs)))
+ (sb-thread:signal-semaphore sem)))
+ (sb-thread:wait-on-semaphore sem))
+ (sb-thread:interrupt-thread-error ()))
+ (mapc #'call refs))))))
(array
(if (simple-vector-p object)
(dotimes (i (length object))
Index: src/code/room.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/room.lisp,v
retrieving revision 1.51
diff -u -r1.51 room.lisp
--- src/code/room.lisp 8 May 2009 19:08:07 -0000 1.51
+++ src/code/room.lisp 22 Mar 2011 16:54:30 -0000
@@ -784,6 +784,26 @@
space)
res)))
+;;; Calls FUNCTION with all object that have (possibly conservative)
+;;; references to them on current stack.
+(defun map-stack-references (function)
+ (let ((end
+ (sb!di::descriptor-sap
+ #!+stack-grows-downward-not-upward *control-stack-end*
+ #!-stack-grows-downward-not-upward *control-stack-start*))
+ (sp (current-sp))
+ (seen nil))
+ (loop until #!+stack-grows-downward-not-upward (sap> sp end)
+ #!-stack-grows-downward-not-upward (sap< sp end)
+ do (multiple-value-bind (obj ok) (make-lisp-obj
(sap-ref-word sp 0) nil)
+ (when (and ok (typep obj '(not (or fixnum character))))
+ (unless (member obj seen :test #'eq)
+ (funcall function obj)
+ (push obj seen))))
+ (setf sp
+ #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
+ #!-stack-grows-downward-not-upward (sap- sp
n-word-bytes)))))
+
(defun map-referencing-objects (fun space object)
(declare (type spaces space) (inline map-allocated-objects))
(unless *ignore-after*
Index: src/code/target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.139
diff -u -r1.139 target-thread.lisp
--- src/code/target-thread.lisp 20 Mar 2011 18:37:55 -0000 1.139
+++ src/code/target-thread.lisp 22 Mar 2011 16:54:30 -0000
@@ -1200,20 +1200,22 @@
(define-alien-variable tls-index-start unsigned-int)
- ;; Get values from the TLS.
- (defun %thread-local-values (thread)
+ ;; Get values from the TLS area of the current thread.
+ (defun %thread-local-references ()
(without-gcing
- (when (thread-alive-p thread)
- (let ((sap (%thread-sap thread)))
- (loop for index from tls-index-start below
- (symbol-value 'sb!vm::*free-tls-index*)
- for value = (sap-ref-word sap (* sb!vm:n-word-bytes index))
- for obj = (sb!kernel:make-lisp-obj value nil)
- unless (or (typep obj '(or boolean fixnum character))
- (member value
- '(#.sb!vm:no-tls-value-marker-widetag
- #.sb!vm:unbound-marker-widetag)))
- collect obj))))))
+ (let ((sap (%thread-sap *current-thread*)))
+ (loop for index from tls-index-start
+ below (symbol-value 'sb!vm::*free-tls-index*)
+ for value = (sap-ref-word sap (* sb!vm:n-word-bytes index))
+ for (obj ok) = (multiple-value-list
(sb!kernel:make-lisp-obj value nil))
+ unless (or (not ok)
+ (typep obj '(or fixnum character))
+ (member value
+ '(#.sb!vm:no-tls-value-marker-widetag
+ #.sb!vm:unbound-marker-widetag))
+ (member obj seen :test #'eq))
+ collect obj into seen
+ finally (return seen))))))
(defun symbol-value-in-thread (symbol thread &optional (errorp t))
"Return the local value of SYMBOL in THREAD, and a secondary value of T
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] 1.0.46.42: more on threads in SB-INTROSPECT:MAP-ROOT | Nikodemus Siivola <nikodemus@ra...> |