From 8b64d57b865fec6ba082dda965146b5e8aa877b3 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 28 Jun 2004 16:27:29 +0000 Subject: [PATCH] 0.8.12.6: Give sb-sprof a chance of working on non-x86 non-gencgc. ... implement search_dynamic_space and friends in cheneygc ... share component_ptr_from_pc between the GCs, and define an alien routine for it unconditionally ... (provide 'sb-sprof) --- NEWS | 2 + contrib/sb-sprof/sb-sprof.lisp | 31 +++++++++---- contrib/sb-sprof/sb-sprof.texinfo | 9 +++- src/code/debug-int.lisp | 2 - src/runtime/cheneygc.c | 35 +++++++++++++++ src/runtime/gc-common.c | 37 ++++++++------- src/runtime/gc-internal.h | 38 ++++++++++++++++ src/runtime/gencgc-internal.h | 1 - src/runtime/gencgc.c | 89 ++++++++----------------------------- version.lisp-expr | 2 +- 10 files changed, 147 insertions(+), 99 deletions(-) diff --git a/NEWS b/NEWS index 1284e6a..4963f83 100644 --- a/NEWS +++ b/NEWS @@ -2559,6 +2559,8 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12: The symbols are also exported from SB-PCL for backwards compatibility, but more so than before SB-PCL should be treated as an implementation-internal package. + * the SB-SPROF contrib now works on (most) non-x86 architectures. + It is known as of this release not to work on the Alpha, however. * fixed bug #333: CHECK-TYPE now ensures that the type error signalled, if any, has the right object to be accessed by TYPE-ERROR-DATUM. (reported by Tony Martinez) diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index 45d9859..fdeba62 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -27,7 +27,7 @@ ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -;;; Statistical profiler for x86. +;;; Statistical profiler. ;;; Overview: ;;; @@ -414,7 +414,7 @@ (deftype address () "Type used for addresses, for instance, program counters, code start/end locations etc." - '(unsigned-byte 32)) + '(unsigned-byte #+alpha 64 #-alpha 32)) (defconstant +unknown-address+ 0 "Constant representing an address that cannot be determined.") @@ -580,8 +580,19 @@ #-x86 (defun sigprof-handler (signal code scp) - (declare (ignore signal code scp)) - (error "Implement me.")) + (declare (ignore signal code)) + (when (and *sampling* + (< *samples-index* (length *samples*))) + (sb-sys:without-gcing + (with-alien ((scp (* os-context-t) :local scp)) + (locally (declare (optimize (inhibit-warnings 2))) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) + (ra (sap-ref-32 + (int-sap fp) + (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) + (record (sap-int pc-ptr)) + (record ra))))))) ;;; Map function FN over code objects in dynamic-space. FN is called ;;; with two arguments, the object and its size in bytes. @@ -922,8 +933,8 @@ ;;; Return a CALL-GRAPH structure for the current contents of ;;; *SAMPLES*. The result contain a list of nodes sorted by self-time -;;; in the FLAT-NODES slot, and a dag in Vertices, with call cycles -;;; reduced to Cycle structures. +;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles +;;; reduced to CYCLE structures. (defun make-call-graph () (stop-profiling) (show-progress "~&Computing call graph ") @@ -1100,7 +1111,7 @@ ((nil))) graph)) -;;;; Silly Examples +;;; silly examples (defun test-0 (n &optional (depth 0)) (declare (optimize (debug 3))) @@ -1113,4 +1124,8 @@ (with-profiling (:reset t :max-samples 1000 :report :graph) (test-0 7))) -;;; End of file. + +;;; provision +(provide 'sb-sprof) + +;;; end of file diff --git a/contrib/sb-sprof/sb-sprof.texinfo b/contrib/sb-sprof/sb-sprof.texinfo index 907017b..3031d82 100644 --- a/contrib/sb-sprof/sb-sprof.texinfo +++ b/contrib/sb-sprof/sb-sprof.texinfo @@ -7,8 +7,13 @@ taking samples of the program execution at regular intervals, instead of instrumenting functions like @code{profile} does. You might find @code{sb-sprof} more useful than @code{profile} when profiling functions in the @code{common-lisp}-package, SBCL internals, or code where the -instrumenting overhead is excessive. On the other hand it only works on -x86, and isn't completely reliable even there. +instrumenting overhead is excessive. + +This module is known not to work consistently on the Alpha platform, +for technical reasons related to the implementation of a machine +language idiom for marking sections of code to be treated as atomic by +the garbage collector; However, it should work on other platforms, +and the deficiency on the Alpha will eventually be rectified. @subsection Example Usage diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 62cfa08..bd9e7a0 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -542,11 +542,9 @@ (sap> control-stack-end x) (zerop (logand (sap-int x) #b11))))) -#!+x86 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+x86 (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c index 745c61b..23b62d7 100644 --- a/src/runtime/cheneygc.c +++ b/src/runtime/cheneygc.c @@ -569,7 +569,42 @@ scav_weak_pointer(lispobj *where, lispobj object) return WEAK_POINTER_NWORDS; } + +lispobj * +search_read_only_space(void *pointer) +{ + lispobj* start = (lispobj*)READ_ONLY_SPACE_START; + lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); + if ((pointer < (void *)start) || (pointer >= (void *)end)) + return NULL; + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *)pointer)); +} + +lispobj * +search_static_space(void *pointer) +{ + lispobj* start = (lispobj*)STATIC_SPACE_START; + lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0); + if ((pointer < (void *)start) || (pointer >= (void *)end)) + return NULL; + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *)pointer)); +} +lispobj * +search_dynamic_space(void *pointer) +{ + lispobj *start = (lispobj *) current_dynamic_space; + lispobj *end = (lispobj *) dynamic_space_free_pointer; + if ((pointer < (void *)start) || (pointer >= (void *)end)) + return NULL; + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *)pointer)); +} /* initialization. if gc_init can be moved to after core load, we could * combine these two functions */ diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index a3e7366..b266f42 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -15,21 +15,6 @@ */ /* - * GENerational Conservative Garbage Collector for SBCL x86 - */ - -/* - * This software is part of the SBCL system. See the README file for - * more information. - * - * This software is derived from the CMU CL system, which was - * written at Carnegie Mellon University and released into the - * public domain. The software is in the public domain and is - * provided with absolutely no warranty. See the COPYING and CREDITS - * files for more information. - */ - -/* * For a review of garbage collection techniques (e.g. generational * GC) and terminology (e.g. "scavenging") see Paul R. Wilson, * "Uniprocessor Garbage Collection Techniques". As of 20000618, this @@ -1807,3 +1792,25 @@ gc_init_tables(void) sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed; sizetab[FDEFN_WIDETAG] = size_boxed; } + + +/* Find the code object for the given pc, or return NULL on + failure. */ +lispobj * +component_ptr_from_pc(lispobj *pc) +{ + lispobj *object = NULL; + + if ( (object = search_read_only_space(pc)) ) + ; + else if ( (object = search_static_space(pc)) ) + ; + else + object = search_dynamic_space(pc); + + if (object) /* if we found something */ + if (widetag_of(*object) == CODE_HEADER_WIDETAG) + return(object); + + return (NULL); +} diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index 28d0efc..ac8d5bd 100644 --- a/src/runtime/gc-internal.h +++ b/src/runtime/gc-internal.h @@ -60,6 +60,44 @@ lispobj copy_unboxed_object(lispobj object, int nwords); lispobj copy_large_object(lispobj object, int nwords); lispobj copy_object(lispobj object, int nwords); +lispobj *search_read_only_space(void *pointer); +lispobj *search_static_space(void *pointer); +lispobj *search_dynamic_space(void *pointer); + +/* Scan an area looking for an object which encloses the given pointer. + * Return the object start on success or NULL on failure. */ +static lispobj * +search_space(lispobj *start, size_t words, lispobj *pointer) +{ + while (words > 0) { + size_t count = 1; + lispobj thing = *start; + + /* If thing is an immediate then this is a cons. */ + if (is_lisp_pointer(thing) + || ((thing & 3) == 0) /* fixnum */ + || (widetag_of(thing) == BASE_CHAR_WIDETAG) + || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG)) + count = 2; + else + count = (sizetab[widetag_of(thing)])(start); + + /* Check whether the pointer is within this object. */ + if ((pointer >= start) && (pointer < (start+count))) { + /* found it! */ + /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/ + return(start); + } + + /* Round up the count. */ + count = CEILING(count,2); + + start += count; + words -= count; + } + return (NULL); +} + #ifdef LISP_FEATURE_GENCGC #include "gencgc-internal.h" #else diff --git a/src/runtime/gencgc-internal.h b/src/runtime/gencgc-internal.h index 9ff5a19..c130b57 100644 --- a/src/runtime/gencgc-internal.h +++ b/src/runtime/gencgc-internal.h @@ -32,7 +32,6 @@ void gc_free_heap(void); inline int find_page_index(void *); inline void *page_address(int); int gencgc_handle_wp_violation(void *); -lispobj *search_dynamic_space(lispobj *); struct page { diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 9400f8c..ea90e34 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -1955,64 +1955,34 @@ scav_weak_pointer(lispobj *where, lispobj object) } -/* Scan an area looking for an object which encloses the given pointer. - * Return the object start on success or NULL on failure. */ -static lispobj * -search_space(lispobj *start, size_t words, lispobj *pointer) -{ - while (words > 0) { - size_t count = 1; - lispobj thing = *start; - - /* If thing is an immediate then this is a cons. */ - if (is_lisp_pointer(thing) - || ((thing & 3) == 0) /* fixnum */ - || (widetag_of(thing) == BASE_CHAR_WIDETAG) - || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG)) - count = 2; - else - count = (sizetab[widetag_of(thing)])(start); - - /* Check whether the pointer is within this object. */ - if ((pointer >= start) && (pointer < (start+count))) { - /* found it! */ - /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/ - return(start); - } - - /* Round up the count. */ - count = CEILING(count,2); - - start += count; - words -= count; - } - return (NULL); -} - -lispobj* -search_read_only_space(lispobj *pointer) +lispobj * +search_read_only_space(void *pointer) { - lispobj* start = (lispobj*)READ_ONLY_SPACE_START; - lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); - if ((pointer < start) || (pointer >= end)) + lispobj *start = (lispobj *) READ_ONLY_SPACE_START; + lispobj *end = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); + if ((pointer < (void *)start) || (pointer >= (void *)end)) return NULL; - return (search_space(start, (pointer+2)-start, pointer)); + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *) pointer)); } lispobj * -search_static_space(lispobj *pointer) +search_static_space(void *pointer) { - lispobj* start = (lispobj*)STATIC_SPACE_START; - lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0); - if ((pointer < start) || (pointer >= end)) + lispobj *start = (lispobj *)STATIC_SPACE_START; + lispobj *end = (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0); + if ((pointer < (void *)start) || (pointer >= (void *)end)) return NULL; - return (search_space(start, (pointer+2)-start, pointer)); + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *) pointer)); } /* a faster version for searching the dynamic space. This will work even * if the object is in a current allocation region. */ lispobj * -search_dynamic_space(lispobj *pointer) +search_dynamic_space(void *pointer) { int page_index = find_page_index(pointer); lispobj *start; @@ -2023,7 +1993,9 @@ search_dynamic_space(lispobj *pointer) return NULL; start = (lispobj *)((void *)page_address(page_index) + page_table[page_index].first_object_offset); - return (search_space(start, (pointer+2)-start, pointer)); + return (search_space(start, + (((lispobj *)pointer)+2)-start, + (lispobj *)pointer)); } /* Is there any possibility that pointer is a valid Lisp object @@ -4086,29 +4058,6 @@ alloc(int nbytes) new_obj = gc_alloc_with_region(nbytes,0,region,0); return (new_obj); } - - -/* Find the code object for the given pc, or return NULL on failure. - * - * FIXME: PC shouldn't be lispobj*, should it? Maybe void*? */ -lispobj * -component_ptr_from_pc(lispobj *pc) -{ - lispobj *object = NULL; - - if ( (object = search_read_only_space(pc)) ) - ; - else if ( (object = search_static_space(pc)) ) - ; - else - object = search_dynamic_space(pc); - - if (object) /* if we found something */ - if (widetag_of(*object) == CODE_HEADER_WIDETAG) /* if it's a code object */ - return(object); - - return (NULL); -} /* * shared support for the OS-dependent signal handlers which diff --git a/version.lisp-expr b/version.lisp-expr index f110d97..f593c3a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,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".) -"0.8.12.5" +"0.8.12.6" -- 1.7.10.4