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)
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)
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.
-;;; Statistical profiler for x86.
+;;; Statistical profiler.
;;; Overview:
;;;
(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.")
#-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.
;;; 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 ")
((nil)))
graph))
-;;;; Silly Examples
+;;; silly examples
(defun test-0 (n &optional (depth 0))
(declare (optimize (debug 3)))
(with-profiling (:reset t :max-samples 1000 :report :graph)
(test-0 7)))
-;;; End of file.
+
+;;; provision
+(provide 'sb-sprof)
+
+;;; end of file
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
(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)
return WEAK_POINTER_NWORDS;
}
+\f
+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));
+}
\f
/* initialization. if gc_init can be moved to after core load, we could
* combine these two functions */
*/
/*
- * 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
sizetab[INSTANCE_HEADER_WIDETAG] = size_boxed;
sizetab[FDEFN_WIDETAG] = size_boxed;
}
+
+\f
+/* 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);
+}
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
inline int find_page_index(void *);
inline void *page_address(int);
int gencgc_handle_wp_violation(void *);
-lispobj *search_dynamic_space(lispobj *);
\f
struct page {
}
\f
-/* 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;
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
new_obj = gc_alloc_with_region(nbytes,0,region,0);
return (new_obj);
}
-
-\f
-/* 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);
-}
\f
/*
* shared support for the OS-dependent signal handlers which
;;; 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"
projects / sbcl.git / commitdiff