From 556fa08244211057b003401daf76edf0c8754232 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Jun 2009 08:49:29 +0000 Subject: [PATCH] 1.0.29.14: implement SB-INTROSPECT:ALLOCATION-INFORMATION * Allows users to gain insights into allocation behaviour. --- NEWS | 2 + contrib/sb-introspect/sb-introspect.lisp | 109 +++++++++++++++++++++++++++++- contrib/sb-introspect/test-driver.lisp | 50 ++++++++++++++ src/code/debug-int.lisp | 6 +- src/code/early-source-location.lisp | 18 +++-- src/code/source-location.lisp | 10 ++- src/compiler/generic/vm-ir2tran.lisp | 8 ++- src/compiler/x86/float.lisp | 21 +++--- version.lisp-expr | 2 +- 9 files changed, 198 insertions(+), 28 deletions(-) diff --git a/NEWS b/NEWS index 3c85592..6530578 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,6 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- + * new feature: SB-INTROSPECT:ALLOCATION-INFORMATION provides information + about object allocation. * optimization: more efficient type-checks for FIXNUMs when the value is known to be a signed word on x86 and x86-64. * improvement: failure to provide requested stack allocation compiler notes diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 5aea963..aca9fdc 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -24,7 +24,8 @@ (defpackage :sb-introspect (:use "CL") - (:export "FUNCTION-ARGLIST" + (:export "ALLOCATION-INFORMATION" + "FUNCTION-ARGLIST" "FUNCTION-LAMBDA-LIST" "DEFTYPE-LAMBDA-LIST" "VALID-FUNCTION-NAME-P" @@ -619,4 +620,110 @@ macro MACRO-NAME is expanded. Returns a list of function name, definition-source pairs." (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name)) +;;;; ALLOCATION INTROSPECTION + +(defun allocation-information (object) + #+sb-doc + "Returns information about the allocation of OBJECT. Primary return value +indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK, +or :FOREIGN. + +Possible secondary return value provides additional information about the +allocation. + +For :HEAP objects the secondary value is a plist: + + :SPACE + Inficates the heap segment the object is allocated in. + + :GENERATION + Is the current generation of the object: 0 for nursery, 6 for pseudo-static + generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.) + + :LARGE + Indicates a \"large\" object subject to non-copying + promotion. (GENCGC and :SPACE :DYNAMIC only.) + + :PINNED + Indicates that the page(s) on which the object resides are kept live due + to conservative references. Note that object may reside on a pinned page + even if :PINNED in NIL if the GC has not had the need to mark the the page + as pinned. (GENCGC and :SPACE :DYNAMIC only.) + +For :STACK objects secondary value is the thread on whose stack the object is +allocated. + +Expected use-cases include introspection to gain insight into allocation and +GC behaviour and restricting memoization to heap-allocated arguments. + +Experimental: interface subject to change." + ;; FIXME: Would be nice to provide the size of the object as well, though + ;; maybe that should be a separate function, and something like MAP-PARTS + ;; for mapping over parts of arbitrary objects so users can get "deep sizes" + ;; as well if they want to. + ;; + ;; FIXME: For the memoization use-case possibly we should also provide a + ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC + ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for + ;; checking if an object has been stack-allocated by a given thread for + ;; testing purposes might not come amiss. + (if (typep object '(or fixnum character)) + (values :immediate nil) + (let ((plist + (sb-sys:without-gcing + ;; Disable GC so the object cannot move to another page while + ;; we have the address. + (let* ((addr (sb-kernel:get-lisp-obj-address object)) + (space + (cond ((< sb-vm:read-only-space-start addr + (* sb-vm:*read-only-space-free-pointer* + sb-vm:n-word-bytes)) + :read-only) + ((< sb-vm:static-space-start addr + (* sb-vm:*static-space-free-pointer* + sb-vm:n-word-bytes)) + :static) + ((< (sb-kernel:current-dynamic-space-start) addr + (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer))) + :dynamic)))) + (when space + #+gencgc + (if (eq :dynamic space) + (let ((index (sb-vm::find-page-index addr))) + (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index))) + (let ((flags (sb-alien:slot page 'sb-vm::flags))) + (list :space space + :generation (sb-alien:slot page 'sb-vm::gen) + :write-protected (logbitp 0 flags) + :pinned (logbitp 5 flags) + :large (logbitp 6 flags))))) + (list :space space)) + #-gencgc + (list :space space)))))) + (cond (plist + (values :heap plist)) + (t + (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object)))) + ;; FIXME: Check other stacks as well. + #+sb-thread + (dolist (thread (sb-thread:list-all-threads)) + (let ((c-start (sb-di::descriptor-sap + (sb-thread::%symbol-value-in-thread + 'sb-vm:*control-stack-start* + thread))) + (c-end (sb-di::descriptor-sap + (sb-thread::%symbol-value-in-thread + 'sb-vm:*control-stack-end* + thread)))) + (when (and c-start c-end) + (when (and (sb-sys:sap<= c-start sap) + (sb-sys:sap< sap c-end)) + (return-from allocation-information + (values :stack thread)))))) + #-sb-thread + (when (sb-vm:control-stack-pointer-valid-p sap nil) + (return-from allocation-information + (values :stack sb-thread::*current-thread*)))) + :foreign))))) + (provide 'sb-introspect) diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 2e82fe0..8bb29db 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -145,5 +145,55 @@ (load (merge-pathnames "xref-test.lisp" *load-pathname*)) +;;; Test allocation-information + +(defun tai (x kind info) + (multiple-value-bind (kind2 info2) (sb-introspect:allocation-information x) + (unless (eq kind kind2) + (error "wanted ~S, got ~S" kind kind2)) + (assert (equal info info2)))) + +(tai nil :heap '(:space :static)) +(tai t :heap '(:space :static)) +(tai 42 :immediate nil) +(tai #'cons :heap + #+gencgc + '(:space :dynamic :generation 6 :write-protected t :pinned nil :large nil) + #-gencgc + '(:space :dynamic)) +(let ((x (list 1 2 3))) + (declare (dynamic-extent x)) + (tai x :stack sb-thread:*current-thread*)) +#+sb-thread +(progn + (defun thread-tai () + (let ((x (list 1 2 3))) + (declare (dynamic-extent x)) + (let ((child (sb-thread:make-thread + (lambda () + (sb-introspect:allocation-information x))))) + (assert (equal (list :stack sb-thread:*current-thread*) + (multiple-value-list (sb-thread:join-thread child))))))) + (thread-tai) + (defun thread-tai2 () + (let* ((sem (sb-thread:make-semaphore)) + (obj nil) + (child (sb-thread:make-thread + (lambda () + (let ((x (list 1 2 3))) + (declare (dynamic-extent x)) + (setf obj x) + (sb-thread:wait-on-semaphore sem))) + :name "child"))) + (loop until obj) + (assert (equal (list :stack child) + (multiple-value-list + (sb-introspect:allocation-information obj)))) + (sb-thread:signal-semaphore sem) + (sb-thread:join-thread child) + nil)) + (thread-tai2)) + ;;;; Unix success convention for exit codes (sb-ext:quit :unix-status 0) + diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 234bcbf..19da16e 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -515,7 +515,7 @@ (defun fun-word-offset (fun) (fun-word-offset fun)) #!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) -(defun control-stack-pointer-valid-p (x) +(defun control-stack-pointer-valid-p (x &optional (aligned t)) (declare (type system-area-pointer x)) (let* (#!-stack-grows-downward-not-upward (control-stack-start @@ -526,11 +526,11 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))) + (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))) + (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) diff --git a/src/code/early-source-location.lisp b/src/code/early-source-location.lisp index bb2fcda..d5d00e3 100644 --- a/src/code/early-source-location.lisp +++ b/src/code/early-source-location.lisp @@ -24,19 +24,23 @@ (defvar *source-location-thunks* nil) ;; Will be redefined in src/code/source-location.lisp. -(defun source-location () +(defun source-location (&optional name) + (declare (ignore name)) nil) ;; Will be redefined in src/code/source-location.lisp #-sb-xc-host -(define-compiler-macro source-location () +(define-compiler-macro source-location (&optional name) (when (and (boundp '*source-info*) (symbol-value '*source-info*)) - `(cons ,(make-file-info-namestring - *compile-file-pathname* - (sb!c:get-toplevelish-file-info (symbol-value '*source-info*))) - ,(when (boundp '*current-path*) - (source-path-tlf-number (symbol-value '*current-path*)))))) + (let ((form `(cons ,(make-file-info-namestring + *compile-file-pathname* + (sb!c:get-toplevelish-file-info (symbol-value '*source-info*))) + ,(when (boundp '*current-path*) + (source-path-tlf-number (symbol-value '*current-path*)))))) + (when (eq 'replace name) + (break "early source location: ~S" form)) + form))) ;; If the whole source location tracking machinery has been loaded ;; (detected by the type of SOURCE-LOCATION), execute BODY. Otherwise diff --git a/src/code/source-location.lisp b/src/code/source-location.lisp index 3d488d2..0d39ac3 100644 --- a/src/code/source-location.lisp +++ b/src/code/source-location.lisp @@ -52,15 +52,19 @@ nil)))) #!+sb-source-locations -(define-compiler-macro source-location (&environment env) +(define-compiler-macro source-location (&optional name &environment env) (declare (ignore env)) - #-sb-xc-host (make-definition-source-location)) + #-sb-xc-host + (let ((loc (make-definition-source-location))) + (when (eq 'replace name) + (break "source location ~S" loc)) + loc)) ;; We need a regular definition of SOURCE-LOCATION for calls processed ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET. #!+sb-source-locations (setf (symbol-function 'source-location) - (lambda () (make-definition-source-location))) + (lambda (&optional name) (declare (ignore name)) (make-definition-source-location))) (/show0 "/Processing source location thunks") #!+sb-source-locations diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 5562c20..b0a2d3d 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -266,6 +266,8 @@ ;;; ...conses #!+stack-allocatable-fixed-objects -(defoptimizer (cons stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) - t) +(progn + (defoptimizer (cons stack-allocate-result) ((&rest args) node dx) + t) + (defoptimizer (%make-complex stack-allocate-result) ((&rest args) node dx) + t)) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index 183f979..20fbf29 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -507,16 +507,17 @@ (:node-var node) (:note "complex float to pointer coercion") (:generator 13 - (with-fixed-allocation (y - complex-single-float-widetag - complex-single-float-size - node) - (let ((real-tn (complex-single-reg-real-tn x))) - (with-tn@fp-top(real-tn) - (inst fst (ea-for-csf-real-desc y)))) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (with-tn@fp-top(imag-tn) - (inst fst (ea-for-csf-imag-desc y))))))) + (:break x y node) + (with-fixed-allocation (y + complex-single-float-widetag + complex-single-float-size + node) + (let ((real-tn (complex-single-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fst (ea-for-csf-real-desc y)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fst (ea-for-csf-imag-desc y))))))) (define-move-vop move-from-complex-single :move (complex-single-reg) (descriptor-reg)) diff --git a/version.lisp-expr b/version.lisp-expr index cc8762f..af99dab 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".) -"1.0.29.13" +"1.0.29.14" -- 1.7.10.4