source: trunk/abcl/contrib/abcl-introspect/abcl-introspect.lisp @ 14945

Last change on this file since 14945 was 14945, checked in by Mark Evenson, 5 years ago

abcl-introspect: mark version as failing to load.

But otherwise the SLIME integration branch as of
<https://gitlab.common-lisp.net/slime/slime/commit/ac18767ac4426058a8d54a42b6857f30c4fab208>
works with abcl-1.5.0-dev as of 2016-Jan-12.

File size: 13.7 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;;; FIXME:  failing to load with abcl-1.5.0-dev-20170112
71(defun foreach-internal-field (fn-fn not-fn-fn &optional (fns :all) (definer nil))
72  "fn-n gets called with top, internal function, not-fn-fn gets called with top anything-but"
73  (declare (optimize (debug 3)
74                     #+nil
75                     (speed 3)
76                     (safety 3)))
77  (macrolet ((fields (c) `(java::jcall ,(java::jmethod "java.lang.Class" "getDeclaredFields") ,c))
78       (get (f i) `(java::jcall ,(java::jmethod "java.lang.reflect.Field" "get" "java.lang.Object") ,f ,i))
79       (access (f b) `(java::jcall ,(java::jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean") ,f ,b))
80       (getclass (o) `(java::jcall ,(java::jmethod "java.lang.Object" "getClass") ,o)))
81    (labels ((function-internal-fields (f)
82         (if (symbolp f) 
83       (setq f (symbol-function f)))
84         (let ((fields (fields (getclass f))))
85     (loop for field across fields
86           do (access field t)
87           collect
88           (get field f))))
89       (check (f top seen)
90         (declare (optimize (speed 3) (safety 0)))
91         (dolist (el (function-internal-fields f))
92     (if (functionp el)
93         (let ((name? (third (multiple-value-list (function-lambda-expression el)))))
94           (if (or (consp name?) (and name? (fboundp name?) (eq el (symbol-function name?))) )
95         (progn
96           (when not-fn-fn (funcall not-fn-fn top name?))
97           (when (not (member el seen :test #'eq))
98             (push el seen)
99             (check el top seen)))
100         (when (not (member el seen :test #'eq))
101           (when fn-fn (funcall fn-fn top el))
102           (push el seen)
103           (check el top seen))))
104         (when not-fn-fn 
105           (funcall not-fn-fn top el)
106           )))))
107      (if (eq fns :all)
108    (progn
109      (dolist (p (list-all-packages))
110      (do-symbols (s p)
111        (when (fboundp s)
112    (check (symbol-function s) s nil))))
113      (each-non-symbol-compiled-function (lambda (definer f) (check f definer nil))))
114    (dolist (f fns) 
115      (check (if (not (symbolp f)) f  (symbol-function f)) (or definer f) nil))
116    ))))
117
118(defun callers (thing &aux them)
119  (foreach-internal-field
120   nil
121   (lambda(top el)
122     (when (equal el thing)
123       (pushnew top them)
124       )))
125  them)
126
127(defun annotate-internal-functions (&optional (fns :all) definer)
128  "Iterate over functions reachable from arg fns (all functions
129   if :all). When not a top-level function add
130   key: :internal-to-function value top-level thing in which the
131   function is defined. definers are the top-level functions, This
132   gets called after fset"
133  (foreach-internal-field
134   (lambda(top internal)
135     (unless (eq (if (symbolp top) (symbol-function top) top) internal)
136       (setf (getf (function-plist internal) :internal-to-function) (or definer top))
137       ))
138   nil
139   fns
140   definer))
141
142(defun annotate-clos-methods (&optional (which :all))
143  "Iterate over all clos methods, marking method-functions and
144method-fast-functions with the function plist
145indicator :method-function or :method-fast-function, value the method
146object. This gets called once."
147  (flet ((annotate (method)
148     (let ((method-function (mop::std-method-function method))
149     (fast-function  (mop::std-method-fast-function method)))
150       (when (and method-function (compiled-function-p method-function)) 
151         (setf (getf (function-plist method-function) :method-function) method)
152         (annotate-internal-functions (list method-function) method))
153       (when (and fast-function (compiled-function-p fast-function))
154         (setf (getf (function-plist fast-function) :method-fast-function) method)
155         (annotate-internal-functions (list fast-function) method)))))
156      (if (eq which :all)
157    (loop for q = (list (find-class t)) then q
158    for focus = (pop q)
159    while focus
160    do (setq q (append q (mop::class-direct-subclasses  focus)))
161       (loop for method in (mop::class-direct-methods focus)
162       do (annotate method)))
163
164    (dolist (f which)
165      (annotate f)
166      ))))
167
168(defun annotate-clos-slots (&optional (which :all))
169  "Iterate over all clos slots, marking compile-initarg functions as :initfunction value slot"
170  (flet ((annotate (slot)
171     (let ((initfunction (and (slot-boundp slot 'initfunction)
172            (slot-value slot 'initfunction))))
173       (when initfunction
174         (setf (getf (function-plist initfunction) :initfunction) slot)
175         (annotate-internal-functions (list initfunction) slot)))))
176    (if (eq which :all)
177  (loop for q = (list (find-class t)) then q
178        for focus = (pop q)
179        while focus
180        do (setq q (append q (mop::class-direct-subclasses  focus)))
181     (loop for slot in (mop::class-direct-slots focus)
182           do (annotate slot)))
183  (dolist (f which)
184    (annotate f)
185    ))))
186
187(defun method-spec-list (method)
188  "Given a method object, translate it into specification (name qualifiers specializers)"
189  `(,(mop::generic-function-name  (mop::method-generic-function method))
190    ,(mop::method-qualifiers method) 
191    ,(mapcar #'(lambda (c)
192     (if (typep c 'mop:eql-specializer)
193         `(eql ,(mop:eql-specializer-object c))
194         (class-name c)))
195       (mop:method-specializers method))))
196
197;; function names for printing, inspection and in the debugger
198
199(defun any-function-name (function &aux it)
200  "Compute function name based on the actual function name, if it is a
201named function or the values on the function-plist that functions
202above have used annotate local functions"
203  (maybe-jss-function function)
204  (let ((plist (sys::function-plist function)))
205    (cond ((setq it (getf plist :internal-to-function))
206     `(:local-function ,@(if (java::jcall "getLambdaName" function) 
207           (list (java::jcall "getLambdaName" function))
208           (if (getf plist :jss-function)
209               (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
210           )
211           :in ,@(if (typep it 'mop::standard-method)
212               (cons :method (method-spec-list it))
213               (list it))))
214    ((setq it (getf plist :method-function))
215     (cons :method-function (sys::method-spec-list it)))     
216    ((setq it (getf plist :method-fast-function))
217     (cons :method-fast-function (sys::method-spec-list it)))
218    ((setq it (getf plist :initfunction))
219     (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
220       (list :slot-initfunction (slot-value it 'name ) :for (if class (class-name class) '??))))
221    (t (or (nth-value 2 (function-lambda-expression function))
222     (and (not (compiled-function-p function))
223          `(:anonymous-interpreted-function))
224     (function-name-by-where-loaded-from function))))))
225
226(defun function-name-by-where-loaded-from (function)
227  "name of last resource - used the loaded-from field from the function to construct the name"
228  (let* ((class (java::jcall "getClass" function))
229   (loaded-from (sys::get-loaded-from function))
230   (name (java::jcall "replace" (java::jcall "getName" class) "org.armedbear.lisp." ""))
231   (where (and loaded-from (concatenate 'string (pathname-name loaded-from) "." (pathname-type loaded-from)))))
232    `(:anonymous-function ,name ,@(if (sys::arglist function)  (sys::arglist function)) 
233        ,@(if where (list (list :from where))))))
234 
235(defun maybe-jss-function (f)
236  "Determing if function is something list #"foo" called as a
237  function. If so add to function internal plist :jss-function and the
238  name of the java methods"
239  (and (find-package :jss)
240       (or (getf (sys::function-plist f) :jss-function)
241     (let ((internals (function-internal-fields f)))
242       (and (= (length internals) 2)
243      (eq (second internals) (intern "INVOKE-RESTARGS" :jss))
244      (stringp (first internals))
245      (setf (getf (sys::function-plist f) :jss-function) (first internals)))))))
246   
247(defun local-function-p (function)
248  "Helper function. Tests whether a function wasn't defined at top
249  level based on function-plist annotations"
250  (and (functionp function)
251       (let ((plist  (sys::function-plist function)))
252   (or (getf plist :internal-to-function)
253       (getf plist :method-function)
254       (getf plist :method-fast-function)
255       (getf plist :slot-initfunction)))))
256
257(defun local-function-owner (function)
258  "For local function, return the 'owner' typically the top-level function or clos method"
259  (local-function-p function))
260
261(defmethod print-object ((f function) stream)
262  "Print a function using any-function-name. Requires a patch to
263  system::output-ugly-object in order to prevent the function being
264  printed by a java primitive"
265  (print-unreadable-object (f stream :identity t)
266    (let ((name (any-function-name  f)))
267       (if (consp name)
268           (format stream "~{~a~^ ~}" name)
269           (princ name stream)))))
270
271(defun each-non-symbol-compiled-function (f)
272  (loop for q = (list (find-class t)) then q
273  for focus = (pop q)
274  while focus
275  do (setq q (append q (mop::class-direct-subclasses  focus)))
276     (loop for method in (mop::class-direct-methods focus)
277     do (when (compiled-function-p (mop::method-function method)) (funcall f method (mop::method-function method))))
278     (loop for slot in (mop::class-direct-slots focus)
279     for initfunction = (and (slot-boundp slot 'initfunction) (slot-value slot 'initfunction))
280     do (and initfunction (compiled-function-p initfunction) (funcall f slot initfunction)))))
281                               
282;; hooks into defining
283 
284(defvar *fset-hooks* nil "functions on this list get called with name and function *after* the symbol-function is set")
285
286(defvar *annotate-function-backlog?* t "true before this file has been loaded and function annotations are placed")
287
288(defun fset-hook-annotate-internal-function (name function)
289  "Called at the end of fset. If function annotations have not yet
290  been added, add local function annotations to all functions. If not,
291  just add annotations to function specified in the arglist"
292  (declare (ignore function))
293  (when *annotate-function-backlog?* 
294    (setq *annotate-function-backlog?* nil)
295    (annotate-internal-functions)
296    (annotate-clos-methods)
297    (annotate-clos-slots)
298    )
299  (annotate-internal-functions (list name)))
300
301;; Here we hook into clos in order to have method and slot functions
302;; annotated when they are defined.
303
304(defmethod mop::add-direct-method :after (class method)
305  (annotate-clos-methods (list method)))
306
307(defmethod mop::ensure-class-using-class :after (class name  &key direct-slots
308                                             direct-default-initargs 
309                                             &allow-other-keys)
310  (annotate-clos-slots (mop::class-direct-slots (find-class name))))
311
312;; needs to be the last thing. Some interaction with the fasl loader
313(pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*)
314
315;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316     
317(provide :abcl-introspect)
Note: See TracBrowser for help on using the repository browser.