Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[4af254]: contrib / sb-introspect / sb-introspect.lisp Maximize Restore History

Download this file

sb-introspect.lisp    245 lines (212 with data), 9.2 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
;;; This is here as a discussion point, not yet a supported interface. If
;;; you would like to use the functions here, or you would like other
;;; functions to be here, join the debate on navel@metacircles.com.
;;; List info at http://lists.metacircles.com/cgi-bin/mailman/listinfo/navel
;;; For the avoidance of doubt, the exported interface is the proposed
;;; supported interface. Anything else is internal, though you're
;;; welcome to argue a case for exporting it.
;;; If you steal the code from this file to cut and paste into your
;;; own project, there will be much wailing and gnashing of teeth.
;;; Your teeth. If need be, we'll kick them for you. This is a
;;; contrib, we're allowed to look in internals. You're an
;;; application programmer, and are not.
;;; TODO
;;; 1) structs don't have within-file location info. problem for the
;;; structure itself, accessors and the predicate
;;; 2) what should find-definition-source on a symbol return? there may be
;;; several definitions (class, function, etc)
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
;;; error, or return NIL?
;;; 4) FIXMEs
;;; 5) would be nice to have some interface to the compiler that lets us
;;; fake the filename and position, for use with C-M-x
(declaim (optimize (debug 1)))
(defpackage :sb-introspect
(:use "CL")
(:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P"
"FIND-DEFINITION-SOURCE"
"DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME"
"DEFINITION-NOT-FOUND" "DEFINITION-NAME"
"DEFINITION-SOURCE-FORM-PATH"
"DEFINITION-SOURCE-CHARACTER-OFFSET"
"FIND-FUNCTION-CALLEES"
"FIND-FUNCTION-CALLERS"
))
(in-package :sb-introspect)
(defun valid-function-name-p (name)
"True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
(and (sb-int:valid-function-name-p name) t))
(defun function-arglist (function)
"Describe the lambda list for the function designator FUNCTION.
Works for special-operators, macros, simple functions and generic
functions. Signals error if not found"
(cond ((valid-function-name-p function)
(function-arglist
(or (macro-function function) (fdefinition function))))
((typep function 'generic-function)
(sb-pcl::generic-function-pretty-arglist function))
(t (sb-impl::%simple-fun-arglist
(sb-impl::%closure-fun function)))))
(defgeneric find-definition-source (thing)
(:documentation "Find the source location that defines THING.
Returns a DEFINITION-SOURCE object"))
;;; This is an opaque object with accessors as per export list.
;;; Might not be a struct.
(defstruct definition-source
pathname ; source file, not fasl
form-path
character-offset
)
;;; This is kludgey. We expect these functions (the underlying functions,
;;; not the closures) to be in static space and so not move ever.
;;; FIXME It's also possibly wrong: not all structures use these vanilla
;;; accessors, e.g. when the :type option is used
(defvar *struct-slotplace-reader*
(sb-vm::%simple-fun-self #'definition-source-pathname))
(defvar *struct-slotplace-writer*
(sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
(defvar *struct-predicate*
(sb-vm::%simple-fun-self #'definition-source-p))
;; Internal-only, don't call this directly
(defun find-function-definition-source (o)
(let* ((debug-info
(sb-kernel:%code-debug-info
(sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
(debug-source
(car (sb-c::compiled-debug-info-source debug-info)))
(debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
(tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source
;; for a debug-info (one per file). In SBCL the function that builds
;; debug-sources always produces singleton lists
(sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
(make-definition-source
:pathname
(and (eql (sb-c::debug-source-from debug-source) :file)
(parse-namestring (sb-c::debug-source-name debug-source)))
;; we don't have a real sexp path, annoyingly. Fake one from the
;; top-level form number
:character-offset
(and tlf
(elt (sb-c::debug-source-start-positions debug-source) tlf))
:form-path (and tlf (list tlf)))))
(defmethod find-definition-source ((o function))
(cond
((struct-accessor-p o)
(find-definition-source (struct-accessor-structure-class o)))
((struct-predicate-p o)
(find-definition-source (struct-predicate-structure-class o)))
(t (find-function-definition-source o))))
(defmethod find-definition-source ((o method))
(find-definition-source (or (sb-pcl::method-fast-function o)
(sb-pcl:method-function o))))
(defmethod find-definition-source (name)
(and (valid-function-name-p name)
(find-definition-source (or (macro-function name) (fdefinition name)))))
;; these are internal functions, and probably incomplete
(defun struct-accessor-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
;; FIXME there are other kinds of struct accessor. Fill out this list
(member self (list *struct-slotplace-reader*
*struct-slotplace-writer*))))
(defun struct-predicate-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
;; FIXME there may be other structure predicate functions
(member self (list *struct-predicate*))))
;; FIXME need one for constructor too, perhaps
(defun struct-accessor-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
(find-class
(sb-kernel::classoid-name
(sb-kernel::layout-classoid
(sb-kernel:%closure-index-ref function 1)))))
)))
(defun struct-predicate-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
((member self (list *struct-predicate*))
(find-class
(sb-kernel::classoid-name
(sb-kernel::layout-classoid
(sb-kernel:%closure-index-ref function 0)))))
)))
(defmethod find-definition-source ((o structure-class))
;; FIXME we don't get form-number from this, which is a shame
(let ((constructor
(sb-kernel::structure-classoid-constructor
(sb-kernel:classoid-cell-classoid
(sb-int:info :type :classoid (class-name o))))))
(find-definition-source constructor)))
;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
;;; This interface is trmendously experimental.
;;; For the moment I'm taking the view that FDEFN is an internal
;;; object (one out of one CMUCL developer surveyed didn't know what
;;; they were for), so these routines deal in FUNCTIONs
;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects. We assume every fdefn object in the
;;; constant pool corresponds to a call to that function. A better
;;; strategy would be to use the disassembler to find actual
;;; call-sites.
(declaim (inline map-code-constants))
(defun map-code-constants (code fn)
"Call FN for each constant in CODE's constant pool."
(check-type code sb-kernel:code-component)
(loop for i from sb-vm:code-constants-offset below
(sb-kernel:get-header-data code)
do (funcall fn (sb-kernel:code-header-ref code i))))
(defun find-function-callees (function)
"Return functions called by FUNCTION."
(let ((callees '()))
(map-code-constants
(sb-kernel:fun-code-header function)
(lambda (obj)
(when (sb-kernel:fdefn-p obj)
(push (sb-kernel:fdefn-fun obj)
callees))))
callees))
(declaim (inline map-allocated-code-components))
(defun map-allocated-code-components (spaces fn)
"Call FN for each allocated code component in one of SPACES. FN
receives the object and its size as arguments. SPACES should be a
list of the symbols :dynamic, :static, or :read-only."
(dolist (space spaces)
(sb-vm::map-allocated-objects
(lambda (obj header size)
(when (= sb-vm:code-header-widetag header)
(funcall fn obj size)))
space)))
(declaim (inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
"Call FN for each code component with a fdefn for FUNCTION in its
constant pool."
(let ((function (coerce function 'function)))
(map-allocated-code-components
spaces
(lambda (obj size)
(declare (ignore size))
(map-code-constants
obj
(lambda (constant)
(when (and (sb-kernel:fdefn-p constant)
(eq (sb-kernel:fdefn-fun constant)
function))
(funcall fn obj))))))))
(defun find-function-callers (function &optional (spaces '(:read-only :static
:dynamic)))
"Return functions which call FUNCTION, by searching SPACES for code objects"
(let ((referrers '()))
(map-caller-code-components
function
spaces
(lambda (code)
(let ((entry (sb-kernel:%code-entry-points code)))
(cond ((not entry)
(push (princ-to-string code) referrers))
(t
(loop for e = entry then (sb-kernel::%simple-fun-next e)
while e
do (pushnew e referrers)))))))
referrers))
(provide 'sb-introspect)