1 | (in-package :system) |
---|
2 | |
---|
3 | ;; Author: Alan Ruttenberg December 2016 |
---|
4 | |
---|
5 | ;; This code is released under Creative Common CC0 declaration |
---|
6 | ;; (https://wiki.creativecommons.org/wiki/CC0) and as such is intended |
---|
7 | ;; to be in the public domain. |
---|
8 | |
---|
9 | |
---|
10 | ;; A compiled function is an instance of a class - This class has |
---|
11 | ;; multiple instances if it represents a closure, or a single instance if |
---|
12 | ;; it represents a non-closed-over function. |
---|
13 | |
---|
14 | ;; The ABCL compiler stores constants that are used in function execution |
---|
15 | ;; as private java fields. This includes symbols used to invoke function, |
---|
16 | ;; locally-defined functions (such as via labels or flet) and string and |
---|
17 | ;; other literal constants. |
---|
18 | |
---|
19 | ;; This file provides access to those internal values, and uses them in |
---|
20 | ;; at least two ways. First, to annotate locally defined functions with |
---|
21 | ;; the top-level function they are defined within, and second to search |
---|
22 | ;; for callers of a give function(*). This may yield some false |
---|
23 | ;; positives, such as when a symbol that names a function is also used |
---|
24 | ;; for some other purpose. It can also have false negatives, as when a |
---|
25 | ;; function is inlined. Still, it's pretty useful. The second use to to |
---|
26 | ;; find source locations for frames in the debugger. If the source |
---|
27 | ;; location for a local function is asked for the location of its 'owner' |
---|
28 | ;; is instead returns. |
---|
29 | |
---|
30 | ;; (*) Since java functions are strings, local fields also have these |
---|
31 | ;; strings. In the context of looking for callers of a function you can |
---|
32 | ;; also give a string that names a java method. Same caveat re: false |
---|
33 | ;; positives. |
---|
34 | |
---|
35 | ;; In order to record information about local functions, ABCL defines a |
---|
36 | ;; function-plist, which is for the most part unused, but is used here |
---|
37 | ;; with set of keys indicating where the local function was defined and |
---|
38 | ;; in what manner, i.e. as normal local function, as a method function, |
---|
39 | ;; or as an initarg function. There may be other places functions are |
---|
40 | ;; stashed away (defstructs come to mind) and this file should be added |
---|
41 | ;; to to take them into account as they are discovered. |
---|
42 | |
---|
43 | ;; This file does not depend on jss, but provides a bit of |
---|
44 | ;; jss-specific functionality if jss *is* loaded. |
---|
45 | |
---|
46 | (defun function-internal-fields (f) |
---|
47 | "return a list of values of fields declared in the class implementing the function" |
---|
48 | (if (symbolp f) |
---|
49 | (setq f (symbol-function f))) |
---|
50 | ;; think about other fields |
---|
51 | (let ((fields (java::jcall "getDeclaredFields" (java::jcall "getClass" f)))) |
---|
52 | (loop for field across fields |
---|
53 | do (java::jcall "setAccessible" field t) |
---|
54 | collect |
---|
55 | (java::jcall "get" field f)))) |
---|
56 | |
---|
57 | (defun function-internals (f) |
---|
58 | "internal fields + closed-over values" |
---|
59 | (append (function-internal-fields f) |
---|
60 | (and (java::jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f) |
---|
61 | (compiled-closure-context f)))) |
---|
62 | |
---|
63 | (defun compiled-closure-context (f) |
---|
64 | "For compiled closures, the values closed over" |
---|
65 | (let ((context (java::jcall "get" (load-time-value (java::jclass-field "org.armedbear.lisp.CompiledClosure" "ctx")) f))) |
---|
66 | (loop for binding across context |
---|
67 | collect |
---|
68 | (java::jcall "get" (load-time-value (java::jclass-field "org.armedbear.lisp.ClosureBinding" "value")) binding)))) |
---|
69 | |
---|
70 | (defun foreach-internal-field (fn-fn not-fn-fn &optional (fns :all) (definer nil)) |
---|
71 | "fn-n gets called with top, internal function, not-fn-fn gets called with top anything-but" |
---|
72 | (declare (optimize (speed 3) (safety 0))) |
---|
73 | (macrolet ((fields (c) `(java::jcall ,(java::jmethod "java.lang.Class" "getDeclaredFields") ,c)) |
---|
74 | (get (f i) `(java::jcall ,(java::jmethod "java.lang.reflect.Field" "get" "java.lang.Object") ,f ,i)) |
---|
75 | (access (f b) `(java::jcall ,(java::jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean") ,f ,b)) |
---|
76 | (getclass (o) `(java::jcall ,(java::jmethod "java.lang.Object" "getClass") ,o))) |
---|
77 | (labels ((function-internal-fields (f) |
---|
78 | (if (symbolp f) |
---|
79 | (setq f (symbol-function f))) |
---|
80 | (let ((fields (fields (getclass f)))) |
---|
81 | (loop for field across fields |
---|
82 | do (access field t) |
---|
83 | collect |
---|
84 | (get field f)))) |
---|
85 | (check (f top seen) |
---|
86 | (declare (optimize (speed 3) (safety 0))) |
---|
87 | (dolist (el (function-internal-fields f)) |
---|
88 | (if (functionp el) |
---|
89 | (let ((name? (third (multiple-value-list (function-lambda-expression el))))) |
---|
90 | (if (or (consp name?) (and name? (fboundp name?) (eq el (symbol-function name?))) ) |
---|
91 | (progn |
---|
92 | (when not-fn-fn (funcall not-fn-fn top name?)) |
---|
93 | (when (not (member el seen :test #'eq)) |
---|
94 | (push el seen) |
---|
95 | (check el top seen))) |
---|
96 | (when (not (member el seen :test #'eq)) |
---|
97 | (when fn-fn (funcall fn-fn top el)) |
---|
98 | (push el seen) |
---|
99 | (check el top seen)))) |
---|
100 | (when not-fn-fn |
---|
101 | (funcall not-fn-fn top el) |
---|
102 | ))))) |
---|
103 | (if (eq fns :all) |
---|
104 | (progn |
---|
105 | (dolist (p (list-all-packages)) |
---|
106 | (do-symbols (s p) |
---|
107 | (when (fboundp s) |
---|
108 | (check (symbol-function s) s nil)))) |
---|
109 | (each-non-symbol-compiled-function (lambda (definer f) (check f definer nil)))) |
---|
110 | (dolist (f fns) |
---|
111 | (check (if (not (symbolp f)) f (symbol-function f)) (or definer f) nil)) |
---|
112 | )))) |
---|
113 | |
---|
114 | (defun callers (thing &aux them) |
---|
115 | (foreach-internal-field |
---|
116 | nil |
---|
117 | (lambda(top el) |
---|
118 | (when (equal el thing) |
---|
119 | (pushnew top them) |
---|
120 | ))) |
---|
121 | them) |
---|
122 | |
---|
123 | (defun annotate-internal-functions (&optional (fns :all) definer) |
---|
124 | "Iterate over functions reachable from arg fns (all functions |
---|
125 | if :all). When not a top-level function add |
---|
126 | key: :internal-to-function value top-level thing in which the |
---|
127 | function is defined. definers are the top-level functions, This |
---|
128 | gets called after fset" |
---|
129 | (foreach-internal-field |
---|
130 | (lambda(top internal) |
---|
131 | (unless (eq (if (symbolp top) (symbol-function top) top) internal) |
---|
132 | (setf (getf (function-plist internal) :internal-to-function) (or definer top)) |
---|
133 | )) |
---|
134 | nil |
---|
135 | fns |
---|
136 | definer)) |
---|
137 | |
---|
138 | (defvar *function-class-names* (make-hash-table :test 'equalp :weakness :value) |
---|
139 | "Table mapping java class names of function classes to their function. Value is either symbol or (:in symbol) if an internal function") |
---|
140 | |
---|
141 | (defun index-function-class-names (&optional (fns :all)) |
---|
142 | "Create a table mapping class names to function, for cases where the class name appears in backtrace (although perhaps that's a bug?)" |
---|
143 | (if (eq fns :all) |
---|
144 | (dolist (p (list-all-packages)) |
---|
145 | (do-symbols (s p) |
---|
146 | (when (and (eq (symbol-package s) p) (fboundp s) |
---|
147 | ;; system is touchy about #'autoload |
---|
148 | (not (eq (symbol-function s) #'autoload))) |
---|
149 | (unless (#"matches" (#"getName" (#"getClass" (symbol-function s))) ".*Closure$") |
---|
150 | (setf (gethash (#"getName" (#"getClass" (symbol-function s))) *function-class-names*) (symbol-function s)))))) |
---|
151 | (dolist (s fns) |
---|
152 | (setf (gethash (#"getName" (#"getClass" (if (symbolp s) (symbol-function s) s))) *function-class-names*) s))) |
---|
153 | (foreach-internal-field |
---|
154 | (lambda(top internal) |
---|
155 | (let ((fn (if (symbolp top) (symbol-function top) top))) |
---|
156 | (unless (or (eq fn internal) (#"matches" (#"getName" (#"getClass" fn)) ".*Closure$")) |
---|
157 | (setf (gethash (#"getName" (#"getClass" internal)) *function-class-names*) |
---|
158 | internal)))) |
---|
159 | nil |
---|
160 | fns |
---|
161 | nil)) |
---|
162 | |
---|
163 | (defun java-class-lisp-function (class-name) |
---|
164 | "Return either function-name or (:in function-name) or nil if class isn't that of lisp function" |
---|
165 | (gethash class-name *function-class-names* )) |
---|
166 | |
---|
167 | (defun annotate-clos-methods (&optional (which :all)) |
---|
168 | "Iterate over all clos methods, marking method-functions and |
---|
169 | method-fast-functions with the function plist |
---|
170 | indicator :method-function or :method-fast-function, value the method |
---|
171 | object. This gets called once." |
---|
172 | (flet ((annotate (method) |
---|
173 | (let ((method-function (mop::std-method-function method)) |
---|
174 | (fast-function (mop::std-method-fast-function method))) |
---|
175 | (when (and method-function (compiled-function-p method-function)) |
---|
176 | (setf (getf (function-plist method-function) :method-function) method) |
---|
177 | (annotate-internal-functions (list method-function) method) |
---|
178 | (index-function-class-names (list method-function))) |
---|
179 | (when (and fast-function (compiled-function-p fast-function)) |
---|
180 | (setf (getf (function-plist fast-function) :method-fast-function) method) |
---|
181 | (annotate-internal-functions (list fast-function) method) |
---|
182 | (index-function-class-names (list method-function)))))) |
---|
183 | (if (eq which :all) |
---|
184 | (loop for q = (list (find-class t)) then q |
---|
185 | for focus = (pop q) |
---|
186 | while focus |
---|
187 | do (setq q (append q (mop::class-direct-subclasses focus))) |
---|
188 | (loop for method in (mop::class-direct-methods focus) |
---|
189 | do (annotate method))) |
---|
190 | |
---|
191 | (dolist (f which) |
---|
192 | (annotate f) |
---|
193 | )))) |
---|
194 | |
---|
195 | (defun annotate-clos-slots (&optional (which :all)) |
---|
196 | "Iterate over all clos slots, marking compile-initarg functions as :initfunction value slot" |
---|
197 | (flet ((annotate (slot) |
---|
198 | (let ((initfunction (and (slot-boundp slot 'initfunction) |
---|
199 | (slot-value slot 'initfunction)))) |
---|
200 | (when initfunction |
---|
201 | (setf (getf (function-plist initfunction) :initfunction) slot) |
---|
202 | (annotate-internal-functions (list initfunction) slot))))) |
---|
203 | (if (eq which :all) |
---|
204 | (loop for q = (list (find-class t)) then q |
---|
205 | for focus = (pop q) |
---|
206 | while focus |
---|
207 | do (setq q (append q (mop::class-direct-subclasses focus))) |
---|
208 | (loop for slot in (mop::class-direct-slots focus) |
---|
209 | do (annotate slot))) |
---|
210 | (dolist (f which) |
---|
211 | (annotate f) |
---|
212 | )))) |
---|
213 | |
---|
214 | (defun method-spec-list (method) |
---|
215 | "Given a method object, translate it into specification (name qualifiers specializers)" |
---|
216 | `(,(mop::generic-function-name (mop::method-generic-function method)) |
---|
217 | ,(mop::method-qualifiers method) |
---|
218 | ,(mapcar #'(lambda (c) |
---|
219 | (if (typep c 'mop:eql-specializer) |
---|
220 | `(eql ,(mop:eql-specializer-object c)) |
---|
221 | (class-name c))) |
---|
222 | (mop:method-specializers method)))) |
---|
223 | |
---|
224 | ;; function names for printing, inspection and in the debugger |
---|
225 | |
---|
226 | (defun any-function-name (function &aux it) |
---|
227 | "Compute function name based on the actual function name, if it is a |
---|
228 | named function or the values on the function-plist that functions |
---|
229 | above have used annotate local functions" |
---|
230 | (cond ((typep function 'generic-function) |
---|
231 | (mop::generic-function-name function)) |
---|
232 | ((typep function 'mop::method) |
---|
233 | (mop::generic-function-name (mop::method-generic-function function))) |
---|
234 | (t |
---|
235 | (maybe-jss-function function) |
---|
236 | (let ((interpreted (not (compiled-function-p function)))) |
---|
237 | (let ((plist (sys::function-plist function))) |
---|
238 | (cond ((setq it (getf plist :internal-to-function)) |
---|
239 | `(:local-function ,@(if (java::jcall "getLambdaName" function) |
---|
240 | (list (java::jcall "getLambdaName" function)) |
---|
241 | (if (getf plist :jss-function) |
---|
242 | (list (concatenate 'string "#\"" (getf plist :jss-function) "\""))) |
---|
243 | ) |
---|
244 | ,@(if interpreted '((interpreted))) |
---|
245 | :in ,@(if (typep it 'mop::standard-method) |
---|
246 | (cons :method (method-spec-list it)) |
---|
247 | (list it)))) |
---|
248 | ((setq it (getf plist :method-function)) |
---|
249 | `(:method-function ,@(if interpreted '((interpreted))) ,@(sys::method-spec-list it))) |
---|
250 | ((setq it (getf plist :method-fast-function)) |
---|
251 | `(:method-fast-function ,@(if interpreted '("(interpreted)")) ,@(sys::method-spec-list it))) |
---|
252 | ((setq it (getf plist :initfunction)) |
---|
253 | (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class)))) |
---|
254 | `(:slot-initfunction ,(slot-value it 'name ) ,@(if interpreted '((interpreted))) :for ,(if class (class-name class) '??)))) |
---|
255 | ((#"equals" function (symbol-function 'lambda)) |
---|
256 | '(:macro-function lambda)) |
---|
257 | ((equal (#"getName" (#"getClass" function)) "org.armedbear.lisp.MacroObject") |
---|
258 | `(:macro-object ,@(any-function-name #"{function}.expander"))) |
---|
259 | (t (or (and (nth-value 2 (function-lambda-expression function)) |
---|
260 | (if interpreted |
---|
261 | `(,(nth-value 2 (function-lambda-expression function)) ,'(interpreted)) |
---|
262 | (let ((name (nth-value 2 (function-lambda-expression function)))) |
---|
263 | (if (macro-function-p function) |
---|
264 | `(:macro ,name) |
---|
265 | name)))) |
---|
266 | (and (not (compiled-function-p function)) |
---|
267 | (let ((body (#"getBody" function))) |
---|
268 | (if (and (consp body) (consp (car body)) (eq (caar body) 'jss::invoke-restargs)) |
---|
269 | `(:interpreted-function ,(concatenate 'string "#\"" (cadar body) "\"")) |
---|
270 | `(:anonymous-interpreted-function)))) |
---|
271 | (function-name-by-where-loaded-from function))))))))) |
---|
272 | |
---|
273 | (defun function-name-by-where-loaded-from (function) |
---|
274 | "name of last resource - used the loaded-from field from the function to construct the name" |
---|
275 | (let* ((class (java::jcall "getClass" function)) |
---|
276 | (loaded-from (sys::get-loaded-from function)) |
---|
277 | (name (java::jcall "replace" (java::jcall "getName" class) "org.armedbear.lisp." "")) |
---|
278 | (where (and loaded-from (concatenate 'string (pathname-name loaded-from) "." (pathname-type loaded-from))))) |
---|
279 | `(:anonymous-function ,name ,@(if (sys::arglist function) (sys::arglist function)) |
---|
280 | ,@(if where (list (list :from where)))))) |
---|
281 | |
---|
282 | (defun maybe-jss-function (f) |
---|
283 | "Determing if function is something list #\"foo\" called as a |
---|
284 | function. If so add to function internal plist :jss-function and the |
---|
285 | name of the java methods" |
---|
286 | (and (find-package :jss) |
---|
287 | (compiled-function-p f) |
---|
288 | (or (getf (sys::function-plist f) :jss-function) |
---|
289 | (let ((internals (function-internal-fields f))) |
---|
290 | (and (= (length internals) 2) |
---|
291 | (eq (second internals) (intern "INVOKE-RESTARGS" :jss)) |
---|
292 | (stringp (first internals)) |
---|
293 | (setf (getf (sys::function-plist f) :jss-function) (first internals))))))) |
---|
294 | |
---|
295 | (defun local-function-p (function) |
---|
296 | "Helper function. Tests whether a function wasn't defined at top |
---|
297 | level based on function-plist annotations" |
---|
298 | (and (and (functionp function) (not (typep function 'generic-function))) |
---|
299 | (let ((plist (sys::function-plist function))) |
---|
300 | (or (getf plist :internal-to-function) |
---|
301 | (getf plist :method-function) |
---|
302 | (getf plist :method-fast-function) |
---|
303 | (getf plist :slot-initfunction))))) |
---|
304 | |
---|
305 | (defun local-function-owner (function) |
---|
306 | "For local function, return the 'owner' typically the top-level function or clos method" |
---|
307 | (local-function-p function)) |
---|
308 | |
---|
309 | (defvar *function-print-object-prefix* "function ") |
---|
310 | |
---|
311 | (defmethod print-object ((f function) stream) |
---|
312 | "Print a function using any-function-name. Requires a patch to |
---|
313 | system::output-ugly-object in order to prevent the function being |
---|
314 | printed by a java primitive" |
---|
315 | (if (or (typep f 'mop::generic-function) |
---|
316 | (typep f 'mop::method)) |
---|
317 | (call-next-method) |
---|
318 | (print-unreadable-object (f stream :identity t) |
---|
319 | (let ((name (any-function-name f))) |
---|
320 | (if (consp name) |
---|
321 | (format stream "~{~a~^ ~}" name) |
---|
322 | (format stream "~a~a" *function-print-object-prefix* name)))))) |
---|
323 | |
---|
324 | (defun each-non-symbol-compiled-function (f) |
---|
325 | (loop for q = (list (find-class t)) then q |
---|
326 | for focus = (pop q) |
---|
327 | while focus |
---|
328 | do (setq q (append q (mop::class-direct-subclasses focus))) |
---|
329 | (loop for method in (mop::class-direct-methods focus) |
---|
330 | do (when (compiled-function-p (mop::method-function method)) (funcall f method (mop::method-function method)))) |
---|
331 | (loop for slot in (mop::class-direct-slots focus) |
---|
332 | for initfunction = (and (slot-boundp slot 'initfunction) (slot-value slot 'initfunction)) |
---|
333 | do (and initfunction (compiled-function-p initfunction) (funcall f slot initfunction))))) |
---|
334 | |
---|
335 | ;; hooks into defining |
---|
336 | |
---|
337 | (defvar *fset-hooks* nil "functions on this list get called with name and function *after* the symbol-function is set") |
---|
338 | |
---|
339 | (defvar *annotate-function-backlog?* t "true before this file has been loaded and function annotations are placed") |
---|
340 | |
---|
341 | (defun fset-hook-annotate-internal-function (name function) |
---|
342 | "Called at the end of fset. If function annotations have not yet |
---|
343 | been added, add local function annotations to all functions. If not, |
---|
344 | just add annotations to function specified in the arglist" |
---|
345 | (when *annotate-function-backlog?* |
---|
346 | (setq *annotate-function-backlog?* nil) |
---|
347 | (annotate-internal-functions) |
---|
348 | (annotate-clos-methods) |
---|
349 | (annotate-clos-slots) |
---|
350 | (index-function-class-names) ;; still missing some cases e.g. generic functions and method functions |
---|
351 | ) |
---|
352 | (index-function-class-names (list function)) |
---|
353 | (annotate-internal-functions (list name))) |
---|
354 | |
---|
355 | ;; Here we hook into clos in order to have method and slot functions |
---|
356 | ;; annotated when they are defined. |
---|
357 | |
---|
358 | (defmethod mop::add-direct-method :after (class method) |
---|
359 | (annotate-clos-methods (list method)) |
---|
360 | ) |
---|
361 | |
---|
362 | (defmethod mop::ensure-class-using-class :after (class name &key direct-slots |
---|
363 | direct-default-initargs |
---|
364 | &allow-other-keys) |
---|
365 | (annotate-clos-slots (mop::class-direct-slots (find-class name)))) |
---|
366 | |
---|
367 | ;; needs to be the last thing. Some interaction with the fasl loader |
---|
368 | (pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*) |
---|
369 | |
---|
370 | (provide :abcl-introspect) |
---|