From 85a570a6668fbca35a7a600ac3b2045bf2fb922a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 22 Mar 2011 17:00:17 +0000 Subject: [PATCH 1/1] 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. --- contrib/sb-introspect/introspect.lisp | 25 ++++++++++++++++++++++--- src/code/room.lisp | 20 ++++++++++++++++++++ src/code/target-thread.lisp | 28 +++++++++++++++------------- version.lisp-expr | 2 +- 4 files changed, 58 insertions(+), 17 deletions(-) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index ed8f256..95504de 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -886,7 +886,7 @@ indirect containers: FDEFINITIONs, EQL specializers, classes, and 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 @@ Experimental: interface subject to change." (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)) diff --git a/src/code/room.lisp b/src/code/room.lisp index 328ca45..4e12042 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -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* diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 8723a7f..bc478fa 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1200,20 +1200,22 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (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 diff --git a/version.lisp-expr b/version.lisp-expr index d894814..9ff5d33 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4