From 344a1f088581303c92da333ddddc9aeb9c212ba9 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 20 Mar 2011 18:37:55 +0000 Subject: [PATCH] 1.0.46.40: more comprehensive MAP-ROOT * EXT defaults to T and provides: ** EQL specializers on the object ** symbol values in other threads ** MACRO-FUNCTION on symbols * Threads map to thread-local values as well, courtesy of SB-THREAD::%THREAD-LOCAL-VALUES. * Don't report multiple references to the same object. --- contrib/sb-introspect/introspect.lisp | 69 ++++++++++++++++++--------------- src/code/target-thread.lisp | 19 ++++++++- src/runtime/thread.c | 13 ++++--- version.lisp-expr | 2 +- 4 files changed, 64 insertions(+), 39 deletions(-) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 862c866..ed8f256 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -871,33 +871,39 @@ Experimental: interface subject to change." (values :stack sb-thread::*current-thread*)))) :foreign))))) -(defun map-root (function object &key simple ext) - "Call FUNCTION with all non-immediate objects pointed to by OBJECT. Returns -OBJECT. +(defun map-root (function object &key simple (ext t)) + "Call FUNCTION with all non-immediate objects pointed to by OBJECT. +Returns OBJECT. -If SIMPLE is true, elides those pointers that are not notionally part of -certain built-in objects, but backpointers to a conceptual parent: eg. elides -the pointer from a SYMBOL to the corresponding PACKAGE. +If SIMPLE is true (default is NIL), elides those pointers that are not +notionally part of certain built-in objects, but backpointers to a +conceptual parent: eg. elides the pointer from a SYMBOL to the +corresponding PACKAGE. -If EXT is true, includes some pointers that are not actually contained in the -object, but in well-known indirect containers. For example, symbols in SBCL do -not directly point to their SYMBOL-FUNCTION or class by the same name, but -when :EXT T is used MAP-ROOT will also walk the function and class (if any) -associated with the symbol. +If EXT is true (default is T), includes some pointers that are not +actually contained in the object, but found in certain well-known +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, nor over thread-local symbol -bindings. +NOTE: calling MAP-ROOT with a THREAD does not currently map over +conservative roots from the thread stack & interrupt contexts. Experimental: interface subject to change." - (let ((fun (coerce function 'function))) + (let ((fun (coerce function 'function)) + (seen (sb-int:alloc-xset))) (flet ((call (part) - (when (member (sb-kernel:lowtag-of part) - `(,sb-vm:instance-pointer-lowtag - ,sb-vm:list-pointer-lowtag - ,sb-vm:fun-pointer-lowtag - ,sb-vm:other-pointer-lowtag)) + (when (and (member (sb-kernel:lowtag-of part) + `(,sb-vm:instance-pointer-lowtag + ,sb-vm:list-pointer-lowtag + ,sb-vm:fun-pointer-lowtag + ,sb-vm:other-pointer-lowtag)) + (not (sb-int:xset-member-p part seen))) + (sb-int:add-to-xset part seen) (funcall fun part)))) + (when ext + (let ((table sb-pcl::*eql-specializer-table*)) + (call (sb-ext:with-locked-hash-table (table) + (gethash object table))))) (etypecase object ((or bignum float sb-sys:system-area-pointer fixnum)) (sb-ext:weak-pointer @@ -920,7 +926,10 @@ Experimental: interface subject to change." (sb-kernel:%instance-layout object)) 0))) (dotimes (i (- len nuntagged)) - (call (sb-kernel:%instance-ref object i))))) + (call (sb-kernel:%instance-ref object i)))) + (when (typep object 'sb-thread:thread) + (dolist (value (sb-thread::%thread-local-values object)) + (call value)))) (array (if (simple-vector-p object) (dotimes (i (length object)) @@ -957,18 +966,16 @@ Experimental: interface subject to change." sb-vm::funcallable-instance-info-offset) do (call (sb-kernel:%funcallable-instance-info object i)))) (symbol - (when (boundp object) - (let ((local (symbol-value object))) - (handler-case - ;; Possibly bound only in the current thread -- and we don't - ;; have GLOBAL-BOUNDP. - (let ((global (sb-ext:symbol-global-value object))) - (unless (eq local global) - (call global))) - (unbound-variable () - nil)))) + (when ext + (dolist (thread (sb-thread:list-all-threads)) + (call (sb-thread:symbol-value-in-thread object thread nil)))) + (handler-case + ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg. + (call (sb-ext:symbol-global-value object)) + (unbound-variable ())) (when (and ext (ignore-errors (fboundp object))) (call (fdefinition object)) + (call (macro-function object)) (let ((class (find-class object nil))) (when class (call class)))) (call (symbol-plist object)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 1d8cdcd..8723a7f 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1196,7 +1196,24 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (setf (sap-ref-word (%thread-sap thread) offset) (get-lisp-obj-address value)) (values value :ok)))) - (values nil :thread-dead)))))) + (values nil :thread-dead))))) + + (define-alien-variable tls-index-start unsigned-int) + + ;; Get values from the TLS. + (defun %thread-local-values (thread) + (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)))))) (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/src/runtime/thread.c b/src/runtime/thread.c index ee11e0f..ca265b8 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -344,6 +344,12 @@ free_thread_struct(struct thread *th) THREAD_STRUCT_SIZE); } +#ifdef LISP_FEATURE_SB_THREAD +/* FIXME: should be MAX_INTERRUPTS -1 ? */ +const unsigned int tls_index_start = + MAX_INTERRUPTS + sizeof(struct thread)/sizeof(lispobj); +#endif + /* this is called from any other thread to create the new one, and * initialize all parts of it that can be initialized from another * thread @@ -387,12 +393,7 @@ create_thread_struct(lispobj initial_function) { per_thread->dynamic_values[i] = NO_TLS_VALUE_MARKER_WIDETAG; if (all_threads == 0) { if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) { - SetSymbolValue - (FREE_TLS_INDEX, - /* FIXME: should be MAX_INTERRUPTS -1 ? */ - make_fixnum(MAX_INTERRUPTS+ - sizeof(struct thread)/sizeof(lispobj)), - 0); + SetSymbolValue(FREE_TLS_INDEX,make_fixnum(tls_index_start),0); SetSymbolValue(TLS_INDEX_LOCK,make_fixnum(0),0); } #define STATIC_TLS_INIT(sym,field) \ diff --git a/version.lisp-expr b/version.lisp-expr index bd1fc2d..c751f72 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.39" +"1.0.46.40" -- 1.7.10.4