Add an xref facility, exported from sb-introspect.
* Support who-calls/macroexpands/binds/sets/references, with
full source path information for extra Slime-goodness.
* Only causes relatively small amounts of compilation slowdown
or fasl bloat, so enable it by default (unless (= SPEED 3)).
* Does not handle: expanded compiler-macros, code in macrolet
definition bodies, toplevel code
* Xref data is currently stored in a new simple-fun slot (the
FUN_RAW_ADDR mess has been cleaned up a little), in reverse
format (that is, we store who-is-called rather than who-calls).
* sb-introspect gets access to the simple-funs through the
infodb, so each lookup requires looping through the whole
db. This is snappy enough on my machine even with lots of
code loaded, but some other storage strategy might be
worth looking at later.
;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.1 relative to sbcl-1.0:
+ * new feature: the compiler stores cross-referencing information
+ abount function calls (who-calls), macroexpansion (who-macroexpands)
+ and special variables (who-binds, who-sets, who-references) for code
+ compiled with (< SPACE 3). This information is available through the
+ sb-introspect contrib.
* improvement: sb-sprof traces call stacks to an arbitrary depth on
x86/x86-64, rather than the previous fixed depth of 8
* bug fix: non-ascii command-line arguments are processed correctly
("src/compiler/dump")
("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp
+ ("src/compiler/xref")
("src/code/source-location")
("src/compiler/target-main" :not-host)
("src/compiler/ir1tran")
"DEFINITION-SOURCE-PLIST"
"DEFINITION-NOT-FOUND" "DEFINITION-NAME"
"FIND-FUNCTION-CALLEES"
- "FIND-FUNCTION-CALLERS"))
+ "FIND-FUNCTION-CALLERS"
+ "WHO-BINDS"
+ "WHO-CALLS"
+ "WHO-REFERENCES"
+ "WHO-SETS"
+ "WHO-MACROEXPANDS"))
(in-package :sb-introspect)
function))
(funcall fn obj))))))))
+;;; XREF facility
+
+(defun get-simple-fun (functoid)
+ (etypecase functoid
+ (sb-kernel::fdefn
+ (get-simple-fun (sb-vm::fdefn-fun functoid)))
+ ((or null sb-impl::funcallable-instance)
+ nil)
+ (function
+ (sb-kernel::%closure-fun functoid))))
+
+(defun collect-xref (kind-index wanted-name)
+ (let ((ret nil))
+ (dolist (env sb-c::*info-environment* ret)
+ ;; Loop through the infodb ...
+ (sb-c::do-info (env :class class :type type :name info-name
+ :value value)
+ ;; ... looking for function or macro definitions
+ (when (and (eql class :function)
+ (or (eql type :macro-function)
+ (eql type :definition)))
+ ;; Get a simple-fun for the definition, and an xref array
+ ;; from the table if available.
+ (let* ((simple-fun (get-simple-fun value))
+ (xrefs (when simple-fun
+ (sb-vm::%simple-fun-xrefs simple-fun)))
+ (array (when xrefs
+ (aref xrefs kind-index))))
+ ;; Loop through the name/path xref entries in the table
+ (loop for i from 0 below (length array) by 2
+ for xref-name = (aref array i)
+ for xref-path = (aref array (1+ i))
+ do (when (eql xref-name wanted-name)
+ (let ((source-location
+ (find-function-definition-source simple-fun)))
+ ;; Use the more accurate source path from
+ ;; the xref entry.
+ (setf (definition-source-form-path source-location)
+ xref-path)
+ (push (cons info-name source-location)
+ ret))))))))))
+
+(defun who-calls (function-name)
+ "Use the xref facility to search for source locations where the
+global function named FUNCTION-NAME is called. Returns a list of
+function name, definition-source pairs."
+ (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
+
+(defun who-binds (symbol)
+ "Use the xref facility to search for source locations where the
+special variable SYMBOL is rebound. Returns a list of function name,
+definition-source pairs."
+ (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
+
+(defun who-references (symbol)
+ "Use the xref facility to search for source locations where the
+special variable or constant SYMBOL is read. Returns a list of function
+name, definition-source pairs."
+ (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
+
+(defun who-sets (symbol)
+ "Use the xref facility to search for source locations where the
+special variable SYMBOL is written to. Returns a list of function name,
+definition-source pairs."
+ (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
+
+(defun who-macroexpands (macro-name)
+ "Use the xref facility to search for source locations where the
+macro MACRO-NAME is expanded. Returns a list of function name,
+definition-source pairs."
+ (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
+
(provide 'sb-introspect)
(assert (matchp-name :function 'cl-user::one 2))
(sb-profile:unprofile cl-user::one)
+;;; Test the xref facility
+
+(load (merge-pathnames "xref-test.lisp" *load-pathname*))
+
;;; Unix success convention for exit codes
(sb-ext:quit :unix-status 0)
--- /dev/null
+(defvar *a* nil)
+(defconstant +z+ 'zzz)
+
+(defun foo () 1)
+(defun bar (x) x)
+
+;; Should:
+;; reference *a*
+;; call bar
+;; not call foo
+;; not call xref/2
+(defun xref/1 ()
+ (flet ((foo ()
+ (bar *a*)))
+ (flet ((xref/2 ()
+ 1))
+ (foo)
+ (xref/2))))
+
+;; Should:
+;; reference *a*, set *a*, bind *a*
+;; call xref/1
+;; not bind b
+(defun xref/2 ()
+ (setf *a* *a*)
+ (let* ((b 1)
+ (*a* b))
+ (when nil
+ (xref/1))))
+
+(let ((x 1))
+ ;; Should:
+ ;; call bar
+ ;; not reference *a*
+ (defun xref/3 ()
+ (bar x))
+ ;; Should:
+ ;; not call bar
+ ;; reference *a*
+ (defun xref/4 ()
+ (setf x *a*)))
+
+
+(flet ((z ()
+ (xref/2)))
+ ;; Should:
+ ;; call xref/2
+ ;; not call z
+ (defun xref/5 ()
+ (z))
+ ;; Should:
+ ;; call xref/2
+ ;; not call z
+ (defun xref/6 ()
+ (z)))
+
+(defun xref/7 ()
+ (flet ((a ()
+ (xref/6)))
+ #'a))
+
+;; call xref/2
+(let ((a 1))
+ (defvar *b* (or (xref/2) a)))
+
+;; call xref/6
+(defvar *c* (xref/6))
+
+;; call xref/2 twice (not three times)
+(defun xref/8 ()
+ (flet ((a ()
+ (xref/2)))
+ (a)
+ (a)
+ (xref/2)))
+
+;; Methods work, even ones with lots of arguments.
+(defmethod xref/10 (a b c d e f g h (i fixnum))
+ (xref/2))
+
+;; Separate methods are indeed separate
+(defmethod xref/11 ((a fixnum))
+ (declare (ignore a))
+ (xref/2))
+
+(defmethod xref/11 ((a float))
+ (declare (ignore a))
+ (xref/3))
+
+(declaim (inline inline/1))
+(defun inline/1 ()
+ (xref/3)
+ (values +z+ *a*))
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defun xref/12 ()
+ (flet ((a ()
+ ;; Counts as calling xref/2
+ (xref/2)))
+ (declare (inline a))
+ (a)
+ ;; Doesn't count as calling xref/3, or referring to +z+ / *a*
+ (inline/1))))
+
+;; calling a function in a macro body
+(defmacro macro/1 ()
+ (when nil
+ (xref/12))
+ nil)
+
+;; expanding a macro
+(defun macro-use/1 ()
+ (macro/1))
+
+;; expanding a macro in an flet/labels
+(defun macro-use/2 ()
+ (flet ((inner-flet ()
+ (macro/1)))
+ (inner-flet)))
+
+;; expanding a macro in an toplevel flet/labels
+(flet ((outer-flet ()
+ (macro/1)))
+ (defun macro-use/3 ()
+ (outer-flet)))
+
+;; expanding a macro in an inlined flet/labels
+(defun macro-use/4 ()
+ (flet ((inner-flet ()
+ (macro/1)))
+ (declare (inline inner-flet))
+ (inner-flet)))
+
+(declaim (inline inline/2))
+(defun inline/2 ()
+ (macro/1))
+
+;; Inlining inline/3 doesn't count as macroexpanding macro/1
+(defun macro-use/5 ()
+ (inline/2))
+
+;;; Code in the macrolet definition bodies is currently not considered
+;;; at all for XREF. Maybe it should be, but it's slightly tricky to
+;;; implement.
+#+nil
+(progn
+ (defun macrolet/1 ()
+ (macrolet ((a ()
+ (inline/2)
+ 1))
+ (a)))
+ (defun macrolet/2 ()
+ (macrolet ((inner-m ()
+ (macro/1)))
+ (inner-m))))
+
+;;; Test references to / from compiler-macros
--- /dev/null
+(defpackage :sb-introspect-test/xref
+ (:use "SB-INTROSPECT" "CL"))
+
+(in-package :sb-introspect-test/xref)
+
+(load (compile-file (merge-pathnames "xref-test-data.lisp" *load-pathname*)))
+
+(labels ((natural< (a b)
+ (string< (princ-to-string a) (princ-to-string b))))
+ (let ((tests '(((sb-introspect::who-calls 'foo) ())
+ ((sb-introspect::who-calls 'bar) (xref/1 xref/3))
+ ((sb-introspect::who-calls 'xref/1) (xref/2))
+ ((sb-introspect::who-calls 'xref/2)
+ (xref/5 xref/6 xref/8 xref/8 xref/12
+ (sb-pcl::fast-method xref/10
+ (t t t t t t t t fixnum))
+ (sb-pcl::fast-method xref/11 (fixnum))))
+ ((sb-introspect::who-calls 'xref/3)
+ (inline/1 (sb-pcl::fast-method xref/11 (float))))
+ ((sb-introspect::who-calls 'xref/4) ())
+ ((sb-introspect::who-calls 'xref/5) ())
+ ((sb-introspect::who-calls 'xref/6) (xref/7))
+ ((sb-introspect::who-calls 'xref/7) ())
+ ((sb-introspect::who-calls 'xref/8) ())
+ ((sb-introspect::who-calls 'xref/10) ())
+ ((sb-introspect::who-calls 'xref/11) ())
+ ((sb-introspect::who-calls 'inline/1) (xref/12))
+ ((sb-introspect::who-calls 'xref/12) (macro/1))
+ ((sb-introspect::who-macroexpands 'macro/1)
+ (macro-use/1 macro-use/2 macro-use/3 macro-use/4 inline/2))
+ ((sb-introspect::who-binds '*a*) (xref/2))
+ ((sb-introspect::who-sets '*a*) (xref/2))
+ ((sb-introspect::who-references '*a*)
+ (xref/1 xref/2 xref/4 inline/1))
+ ((sb-introspect::who-references '+z+)
+ (inline/1)))))
+ (loop for x in tests
+ for form = (first x)
+ for wanted = (sort (second x) #'natural<)
+ for result = (sort (loop for name in (eval form)
+ collect (car name))
+ #'natural<)
+ do (assert (equalp wanted result)
+ nil
+ "form=~a~%wanted=~a~%result=~a~%" form wanted result))))
+
;; and a mechanism for controlling same at compile time
"MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS"
- ;; FIXME: This name doesn't match the DEFFOO - vs. -
- ;; DEFINE-FOO convention used in the ANSI spec, and so
- ;; was deprecated in sbcl-0.pre7, ca. 2001-12-12. After
- ;; a year or so it can go away completely.
- "DEF-SOURCE-CONTEXT"
-
;; extended declarations..
"FREEZE-TYPE" "INHIBIT-WARNINGS"
"MAYBE-INLINE"
"PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASSOID-TYPEP" "DSD-READ-ONLY"
"DSD-DEFAULT" "LAYOUT-INHERITS" "DD-LENGTH"
- "%CODE-ENTRY-POINTS" "%DENOMINATOR"
+ "%CODE-ENTRY-POINTS" "%DENOMINATOR" "%SIMPLE-FUN-XREFS"
"STANDARD-CLASSOID" "CLASSOID-OF"
"MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP"
(multiple-value-bind (new-body local-decs doc)
(parse-defmacro lambda-list whole body name 'defmacro
:environment environment)
- (let ((def `(lambda (,whole ,environment)
+ (let ((def `(#+sb-xc-host lambda
+ ;; Use a named-lambda rather than a lambda so that
+ ;; proper xref information can be stored. Use a
+ ;; list-based name, since otherwise the compiler
+ ;; will momentarily assume that it names a normal
+ ;; function, and report spurious warnings about
+ ;; redefinition a macro as a function, and then
+ ;; vice versa.
+ #-sb-xc-host #-sb-xc-host named-lambda (defmacro ,name)
+ (,whole ,environment)
,@local-decs
,new-body))
- ;; If we want to move over to list-style names
- ;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like
- ;; functionality] here might be a good place to start.
(debug-name (sb!c::debug-name 'macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(sb!c::%defmacro ',name #',def ',lambda-list
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 71)
+(def!constant +fasl-file-version+ 72)
;;; (description of versions before 0.9.0.1 deleted in 0.9.17)
;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is
;;; on 0.9.0.6 (MORE CASE CONSISTENCY).
;;; 69: (2006-08-17) changed validity of various initargs for methods
;;; 70: (2006-09-13) changes to *PSEUDO-ATOMIC* on x86 and x86-64
;;; 71: (2006-11-19) CLOS calling convention changes
+;;; 72: (2006-12-05) Added slot to the primitive function type
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
#+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
(error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
#-sb-xc-host
- (let ((type (pop-stack))
+ (let ((xrefs (pop-stack))
+ (type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(setf (%simple-fun-name fun) name)
(setf (%simple-fun-arglist fun) arglist)
(setf (%simple-fun-type fun) type)
+ (setf (%simple-fun-xrefs fun) xrefs)
;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
#+nil (when *load-print*
(load-fresh-line)
(cons (unless (eq (car fun) 'setf)
(valid-function-name-p fun))))))))
+(defun macro-function-name (name)
+ (when (and (cdr name)
+ (consp (cdr name)))
+ (destructuring-bind (fun &rest rest) (cdr name)
+ (when (null rest)
+ (typecase fun
+ ;; (DEFMACRO FOO)
+ (symbol (values t fun))
+ ;; (DEFMACRO (SETF FOO))
+ (cons (when (eq (car fun) 'setf)
+ (valid-function-name-p fun))))))))
+
+(define-function-name-syntax defmacro (name)
+ (macro-function-name name))
+
+(define-function-name-syntax macrolet (name)
+ (macro-function-name name))
+
#-sb-xc-host
(defun !function-names-cold-init ()
(setf *valid-fun-names-alist* '#.*valid-fun-names-alist*))
(dump-object name file)
(dump-object (sb!c::entry-info-arguments entry) file)
(dump-object (sb!c::entry-info-type entry) file)
+ (dump-object (sb!c::entry-info-xref entry) file)
(dump-fop 'fop-fun-entry file)
(dump-word (label-position (sb!c::entry-info-offset entry)) file)
(dump-pop file)))
(setf (entry-info-offset info) (gen-label))
(setf (entry-info-name info)
(leaf-debug-name internal-fun))
+ (setf (entry-info-xref info)
+ (pack-xref-data (functional-xref internal-fun)))
(when (policy bind (>= debug 1))
(let ((args (functional-arg-documentation internal-fun)))
(aver (not (eq args :unspecified)))
(write-wordindexed code slot value)))
(define-cold-fop (fop-fun-entry)
- (let* ((type (pop-stack))
+ (let* ((xrefs (pop-stack))
+ (type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(write-wordindexed fn sb!vm:simple-fun-name-slot name)
(write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
(write-wordindexed fn sb!vm:simple-fun-type-slot type)
+ (write-wordindexed fn sb!vm::simple-fun-xrefs-slot xrefs)
fn))
(define-cold-fop (fop-foreign-fixup)
:ref-trans %simple-fun-type
:set-known (unsafe)
:set-trans (setf %simple-fun-type))
+ (xrefs :init :null
+ :ref-trans %simple-fun-xrefs
+ :ref-known (flushable)
+ :set-trans (setf %simple-fun-xrefs)
+ :set-known ())
;; the SB!C::DEBUG-FUN object corresponding to this object, or NIL for none
#+nil ; FIXME: doesn't work (gotcha, lowly maintenoid!) See notes on bug 137.
(debug-fun :ref-known (flushable)
(setf (%simple-fun-name res) (entry-info-name entry-info))
(setf (%simple-fun-arglist res) (entry-info-arguments entry-info))
(setf (%simple-fun-type res) (entry-info-type entry-info))
+ (setf (%simple-fun-xrefs res) (entry-info-xref entry-info))
(note-fun entry-info res object))))
(lambda (,n-whole)
(destructuring-bind ,lambda-list ,n-whole ,@body)))))
-(defmacro def-source-context (&rest rest)
- (deprecation-warning 'def-source-context 'define-source-context)
- `(define-source-context ,@rest))
-
(define-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
`(defstruct ,(if (consp name-or-options)
(:macro
(ir1-convert start next result
(careful-expand-macro (info :function :macro-function fun)
- form)))
+ form))
+ (unless (policy *lexenv* (zerop store-xref-data))
+ (record-macroexpansion fun (ctran-block start) *current-path*)))
((nil :function)
(ir1-convert-srctran start next result
(find-free-fun fun "shouldn't happen! (no-cmacro)")
(let* ((*component-being-compiled* component))
+ ;; Record xref information before optimization. This way the
+ ;; stored xref data reflects the real source as closely as
+ ;; possible.
+ (record-component-xrefs component)
+
(ir1-phases component)
(when *loop-analyze*
(apply #'ir1-convert-lambdalike
definition
(list :source-name name))))
+ (debug-name (debug-name 'tl-xep name))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
- :debug-name (debug-name 'tl-xep name))))
+ :debug-name debug-name)))
(when name
(assert-global-function-definition-type name locall-fun))
(setf (functional-entry-fun fun) locall-fun
;; entire initial component just to clear the flags.
(flag nil)
;; some kind of info used by the back end
- (info nil))
+ (info nil)
+ ;; what macroexpansions happened "in" this block, used for xref
+ (macroexpands nil :type list))
(def!method print-object ((cblock cblock) stream)
(print-unreadable-object (cblock stream :type t :identity t)
(format stream "~W :START c~W"
;; sure that no closure is needed.
(allocator nil :type (or null combination))
;; various rare miscellaneous info that drives code generation & stuff
- (plist () :type list))
+ (plist () :type list)
+ ;; xref information for this functional (only used for functions with an
+ ;; XEP)
+ (xref () :type list))
(defprinter (functional :identity t)
%source-name
%debug-name
(define-optimization-quality insert-array-bounds-checks
(if (= safety 0) 0 3)
("no" "yes" "yes" "yes"))
+
+(define-optimization-quality store-xref-data
+ (if (= space 3)
+ 0
+ 3)
+ ("no" "yes" "yes" "yes"))
(arguments nil :type list)
;; a function type specifier representing the arguments and results
;; of this function
- (type 'function :type (or list (member function))))
+ (type 'function :type (or list (member function)))
+ ;; xref information for the XEP
+ (xref nil :type (or null simple-vector)))
;;; An IR2-PHYSENV is used to annotate non-LET LAMBDAs with their
;;; passing locations. It is stored in the PHYSENV-INFO.
--- /dev/null
+;;;; xref facility
+
+;;;; 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.
+
+(in-package "SB!C")
+
+(defvar *xref-kinds* '(:binds :calls :sets :references :macroexpands))
+
+(defun record-component-xrefs (component)
+ (declare (type component component))
+ (when (policy *lexenv* (zerop store-xref-data))
+ (return-from record-component-xrefs))
+ (do ((block (block-next (component-head component)) (block-next block)))
+ ((null (block-next block)))
+ (let* ((this-cont (block-start block))
+ (last (block-last block)))
+ (flet ((handle-node (functional)
+ ;; Record xref information for all nodes in the block.
+ ;; Note that this code can get executed several times
+ ;; for the same block, if the functional is referenced
+ ;; from multiple XEPs.
+ (loop for node = (ctran-next this-cont) then (ctran-next (node-next node))
+ until (eq node last)
+ do (record-node-xrefs node functional))
+ ;; Properly record the deferred macroexpansion information
+ ;; that's been stored in the block.
+ (dolist (xref-data (block-macroexpands block))
+ (record-xref :macroexpands
+ (car xref-data)
+ ;; We use the debug-name of the functional
+ ;; as an identifier. This works quite nicely,
+ ;; except for (fast/slow)-methods with non-symbol,
+ ;; non-number eql specializers, for which
+ ;; the debug-name doesn't map exactly
+ ;; to the fdefinition of the method.
+ functional
+ nil
+ (cdr xref-data)))))
+ (call-with-block-external-functionals block #'handle-node)))))
+
+(defun call-with-block-external-functionals (block fun)
+ (let* ((functional (block-home-lambda block))
+ (seen nil))
+ (labels ((local-function-name-p (name)
+ (and (consp name)
+ (member (car name)
+ '(flet labels lambda))))
+ (handle-functional (functional)
+ ;; If a functional looks like a global function (has a
+ ;; XEP, isn't a local function or a lambda) record xref
+ ;; information for it. Otherwise recurse on the
+ ;; home-lambdas of all references to the functional.
+ (when (eq (functional-kind functional) :external)
+ (let ((entry (functional-entry-fun functional)))
+ (when entry
+ (let ((name (functional-debug-name entry)))
+ (unless (local-function-name-p name)
+ (return-from handle-functional
+ (funcall fun entry)))))))
+ ;; Recurse only if we haven't already seen the
+ ;; functional.
+ (unless (member functional seen)
+ (push functional seen)
+ (dolist (ref (functional-refs functional))
+ (handle-functional (node-home-lambda ref))))))
+ (unless (or (eq :deleted (functional-kind functional))
+ ;; If the block came from an inlined global
+ ;; function, ignore it.
+ (and (functional-inlinep functional)
+ (symbolp (functional-debug-name functional))))
+ (handle-functional functional)))))
+
+(defun record-node-xrefs (node context)
+ (declare (type node node))
+ (etypecase node
+ ((or creturn cif entry combination mv-combination cast))
+ (ref
+ (let ((leaf (ref-leaf node)))
+ (typecase leaf
+ (global-var
+ (let* ((name (leaf-debug-name leaf)))
+ (case (global-var-kind leaf)
+ ;; Reading a special
+ (:special
+ (record-xref :references name context node nil))
+ ;; Calling a function
+ (:global-function
+ (record-xref :calls name context node nil)))))
+ ;; Inlined global function
+ (clambda
+ (when (functional-inlinep leaf)
+ (let ((name (leaf-debug-name leaf)))
+ ;; FIXME: we should store the original var into the
+ ;; functional when creating inlined-functionals, so that
+ ;; we could just check whether it was a global-var,
+ ;; rather then needing to guess based on the debug-name.
+ (when (or (symbolp name)
+ ;; Any non-SETF non-symbol names will
+ ;; currently be either non-functions or
+ ;; internals.
+ (and (consp name)
+ (equal (car name) 'setf)))
+ ;; TODO: a WHO-INLINES xref-kind could be useful
+ (record-xref :calls name context node nil)))))
+ ;; Reading a constant
+ (constant
+ (let* ((name (constant-%source-name leaf)))
+ (record-xref :references name context node nil))))))
+ ;; Setting a special variable
+ (cset
+ (let* ((var (set-var node)))
+ (when (and (global-var-p var)
+ (eq :special (global-var-kind var)))
+ (record-xref :sets
+ (leaf-debug-name var)
+ context
+ node
+ nil))))
+ ;; Binding a special variable
+ (bind
+ (let ((vars (lambda-vars (bind-lambda node))))
+ (dolist (var vars)
+ (when (lambda-var-specvar var)
+ (record-xref :binds
+ (lambda-var-%source-name var)
+ context
+ node
+ nil)))))))
+
+(defun internal-name-p (what)
+ ;; Don't store XREF information for internals. We define as internal
+ ;; anything named only by symbols from either implementation
+ ;; packages, COMMON-LISP or KEYWORD. The last one is useful for
+ ;; example when dealing with ctors.
+ (typecase what
+ (list
+ (every #'internal-name-p what))
+ (symbol
+ (member (symbol-package what)
+ (load-time-value (list* (find-package "COMMON-LISP")
+ (find-package "KEYWORD")
+ (remove-if-not
+ (lambda (package)
+ (= (mismatch "SB!"
+ (package-name package))
+ 3))
+ (list-all-packages))))))
+ (t t)))
+
+(defun record-xref (kind what context node path)
+ (unless (internal-name-p what)
+ (let ((path (reverse
+ (source-path-original-source
+ (or path
+ (node-source-path node))))))
+ (push (list what path)
+ (getf (functional-xref context) kind)))))
+
+(defun record-macroexpansion (what block path)
+ (unless (internal-name-p what)
+ (push (cons what path) (block-macroexpands block))))
+
+;;; Pack the xref table that was stored for a functional into a more
+;;; space-efficient form, and return that packed form.
+(defun pack-xref-data (xref-data)
+ (when xref-data
+ (let ((array (make-array (length *xref-kinds*))))
+ (loop for key in *xref-kinds*
+ for i from 0
+ for values = (remove-duplicates (getf xref-data key)
+ :test #'equal)
+ for flattened = (reduce #'append values :from-end t)
+ collect (setf (aref array i)
+ (when flattened
+ (make-array (length flattened)
+ :initial-contents flattened))))
+ array)))
scavenge(&function_ptr->name, 1);
scavenge(&function_ptr->arglist, 1);
scavenge(&function_ptr->type, 1);
+ scavenge(&function_ptr->xrefs, 1);
}
return n_words;
#ifndef _GC_INTERNAL_H_
#define _GC_INTERNAL_H_
+#include <genesis/simple-fun.h>
+
/* disabling gc assertions made no discernable difference to GC speed,
* last I tried it - dan 2003.12.21 */
#if 1
/* FIXME: Shouldn't this be defined in sbcl.h? */
-/* FIXME (1) this could probably be defined using something like
- * sizeof(lispobj)*floor(sizeof(struct simple_fun)/sizeof(lispobj))
- * - FUN_POINTER_LOWTAG
- * as I'm reasonably sure that simple_fun->code must always be the
- * last slot in the object
-
- * FIXME (2) it also appears in purify.c, and it has a different value
- * for SPARC users in that bit
- */
-
#if defined(LISP_FEATURE_SPARC)
#define FUN_RAW_ADDR_OFFSET 0
#else
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
+#define FUN_RAW_ADDR_OFFSET (offsetof(struct simple_fun, code) - FUN_POINTER_LOWTAG)
#endif
/* values for the *_alloc_* parameters */
#define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
#endif
-/* FIXME: Shouldn't this be defined in sbcl.h? See also notes in
- * cheneygc.c */
-
-#ifdef LISP_FEATURE_SPARC
-#define FUN_RAW_ADDR_OFFSET 0
-#else
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
-#endif
\f
static boolean
forwarding_pointer_p(lispobj obj)
;;; 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.0.17"
+"1.0.0.18"
projects / sbcl.git / commitdiff