source: tags/1.5.0/contrib/abcl-introspect/abcl-introspect.lisp

Last change on this file was 15061, checked in by Mark Evenson, 7 years ago

abcl-introspect: fix LOCAL-FUNCTION-P

(Alan Ruttenberg)

Minor improvement of any-function-name; bugfix for local-function-p.

From <https://github.com/armedbear/abcl/pull/51/commits/cc3765b9342fa8c737df80d650abc992c66b4ab6>.

Merges <https://github.com/armedbear/abcl/pull/51/>.

File size: 16.5 KB
Line 
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
169method-fast-functions with the function plist
170indicator :method-function or :method-fast-function, value the method
171object. 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
228named function or the values on the function-plist that functions
229above 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)
Note: See TracBrowser for help on using the repository browser.