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

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

abcl-introspect: a new ABCL-CONTRIB for accessing ABCL compiler information

The ABCL compiler stores constants that are used in function execution
as private java fields. This includes symbols used to invoke function,
locally-defined functions (such as via labels or flet) and string and
other literal constants.

This file provides access to those internal values, and uses them in
at least two ways. First, to annotate locally defined functions with
the top-level function they are defined within, and second to search
for callers of a give function(*). This may yield some false
positives, such as when a symbol that names a function is also used
for some other purpose. It can also have false negatives, as when a
function is inlined. Still, it's pretty useful. The second use to to
find source locations for frames in the debugger. If the source
location for a local function is asked for the location of its 'owner'
is instead returns.

(*) Since java functions are strings, local fields also have these
strings. In the context of looking for callers of a function you can
also give a string that names a java method. Same caveat re: false
positives.

In order to record information about local functions, ABCL defines a
function-plist, which is for the most part unused, but is used here
with set of keys indicating where the local function was defined and
in what manner, i.e. as normal local function, as a method function,
or as an initarg function. There may be other places functions are
stashed away (defstructs come to mind) and this file should be added
to to take them into account as they are discovered.

This file does not depend on jss, but provides a bit of
jss-specific functionality if jss *is* loaded.

File size: 15.0 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(defun annotate-clos-methods (&optional (which :all))
139  "Iterate over all clos methods, marking method-functions and
140method-fast-functions with the function plist
141indicator :method-function or :method-fast-function, value the method
142object. This gets called once."
143  (flet ((annotate (method)
144     (let ((method-function (mop::std-method-function method))
145     (fast-function  (mop::std-method-fast-function method)))
146       (when (and method-function (compiled-function-p method-function)) 
147         (setf (getf (function-plist method-function) :method-function) method)
148         (annotate-internal-functions (list method-function) method))
149       (when (and fast-function (compiled-function-p fast-function))
150         (setf (getf (function-plist fast-function) :method-fast-function) method)
151         (annotate-internal-functions (list fast-function) method)))))
152      (if (eq which :all)
153    (loop for q = (list (find-class t)) then q
154    for focus = (pop q)
155    while focus
156    do (setq q (append q (mop::class-direct-subclasses  focus)))
157       (loop for method in (mop::class-direct-methods focus)
158       do (annotate method)))
159
160    (dolist (f which)
161      (annotate f)
162      ))))
163
164(defun annotate-clos-slots (&optional (which :all))
165  "Iterate over all clos slots, marking compile-initarg functions as :initfunction value slot"
166  (flet ((annotate (slot)
167     (let ((initfunction (and (slot-boundp slot 'initfunction)
168            (slot-value slot 'initfunction))))
169       (when initfunction
170         (setf (getf (function-plist initfunction) :initfunction) slot)
171         (annotate-internal-functions (list initfunction) slot)))))
172    (if (eq which :all)
173  (loop for q = (list (find-class t)) then q
174        for focus = (pop q)
175        while focus
176        do (setq q (append q (mop::class-direct-subclasses  focus)))
177     (loop for slot in (mop::class-direct-slots focus)
178           do (annotate slot)))
179  (dolist (f which)
180    (annotate f)
181    ))))
182
183(defun method-spec-list (method)
184  "Given a method object, translate it into specification (name qualifiers specializers)"
185  `(,(mop::generic-function-name  (mop::method-generic-function method))
186    ,(mop::method-qualifiers method) 
187    ,(mapcar #'(lambda (c)
188     (if (typep c 'mop:eql-specializer)
189         `(eql ,(mop:eql-specializer-object c))
190         (class-name c)))
191       (mop:method-specializers method))))
192
193;; function names for printing, inspection and in the debugger
194
195(defun any-function-name (function &aux it)
196  "Compute function name based on the actual function name, if it is a
197named function or the values on the function-plist that functions
198above have used annotate local functions"
199  (maybe-jss-function function)
200  (let ((plist (sys::function-plist function)))
201    (cond ((setq it (getf plist :internal-to-function))
202     `(:local-function ,@(if (java::jcall "getLambdaName" function) 
203           (list (java::jcall "getLambdaName" function))
204           (if (getf plist :jss-function)
205               (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
206           )
207           :in ,@(if (typep it 'mop::standard-method)
208               (cons :method (method-spec-list it))
209               (list it))))
210    ((setq it (getf plist :method-function))
211     (cons :method-function (sys::method-spec-list it)))     
212    ((setq it (getf plist :method-fast-function))
213     (cons :method-fast-function (sys::method-spec-list it)))
214    ((setq it (getf plist :initfunction))
215     (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
216       (list :slot-initfunction (slot-value it 'name ) :for (if class (class-name class) '??))))
217    (t (or (nth-value 2 (function-lambda-expression function))
218     (and (not (compiled-function-p function))
219          `(:anonymous-interpreted-function))
220     (function-name-by-where-loaded-from function))))))
221
222(defun function-name-by-where-loaded-from (function)
223  "name of last resource - used the loaded-from field from the function to construct the name"
224  (let* ((class (java::jcall "getClass" function))
225   (loaded-from (sys::get-loaded-from function))
226   (name (java::jcall "replace" (java::jcall "getName" class) "org.armedbear.lisp." ""))
227   (where (and loaded-from (concatenate 'string (pathname-name loaded-from) "." (pathname-type loaded-from)))))
228    `(:anonymous-function ,name ,@(if (sys::arglist function)  (sys::arglist function)) 
229        ,@(if where (list (list :from where))))))
230 
231(defun maybe-jss-function (f)
232  "Determing if function is something list #"foo" called as a
233  function. If so add to function internal plist :jss-function and the
234  name of the java methods"
235  (and (find-package :jss)
236       (or (getf (sys::function-plist f) :jss-function)
237     (let ((internals (function-internal-fields f)))
238       (and (= (length internals) 2)
239      (eq (second internals) (intern "INVOKE-RESTARGS" :jss))
240      (stringp (first internals))
241      (setf (getf (sys::function-plist f) :jss-function) (first internals)))))))
242   
243(defun local-function-p (function)
244  "Helper function. Tests whether a function wasn't defined at top
245  level based on function-plist annotations"
246  (and (functionp function)
247       (let ((plist  (sys::function-plist function)))
248   (or (getf plist :internal-to-function)
249       (getf plist :method-function)
250       (getf plist :method-fast-function)
251       (getf plist :slot-initfunction)))))
252
253(defun local-function-owner (function)
254  "For local function, return the 'owner' typically the top-level function or clos method"
255  (local-function-p function))
256
257(defmethod print-object ((f function) stream)
258  "Print a function using any-function-name. Requires a patch to
259  system::output-ugly-object in order to prevent the function being
260  printed by a java primitive"
261  (print-unreadable-object (f stream :identity t)
262    (let ((name (any-function-name  f)))
263       (if (consp name)
264           (format stream "~{~a~^ ~}" name)
265           (princ name stream)))))
266
267(defun each-non-symbol-compiled-function (f)
268  (loop for q = (list (find-class t)) then q
269  for focus = (pop q)
270  while focus
271  do (setq q (append q (mop::class-direct-subclasses  focus)))
272     (loop for method in (mop::class-direct-methods focus)
273     do (when (compiled-function-p (mop::method-function method)) (funcall f method (mop::method-function method))))
274     (loop for slot in (mop::class-direct-slots focus)
275     for initfunction = (and (slot-boundp slot 'initfunction) (slot-value slot 'initfunction))
276     do (and initfunction (compiled-function-p initfunction) (funcall f slot initfunction)))))
277                               
278;; hooks into defining
279 
280(defvar *fset-hooks* nil "functions on this list get called with name and function *after* the symbol-function is set")
281
282(defvar *annotate-function-backlog?* t "true before this file has been loaded and function annotations are placed")
283
284(defun fset-hook-annotate-internal-function (name function)
285  "Called at the end of fset. If function annotations have not yet
286  been added, add local function annotations to all functions. If not,
287  just add annotations to function specified in the arglist"
288  (declare (ignore function))
289  (when *annotate-function-backlog?* 
290    (setq *annotate-function-backlog?* nil)
291    (annotate-internal-functions)
292    (annotate-clos-methods)
293    (annotate-clos-slots)
294    )
295  (annotate-internal-functions (list name)))
296
297;; Here we hook into clos in order to have method and slot functions
298;; annotated when they are defined.
299
300(defmethod mop::add-direct-method :after (class method)
301  (annotate-clos-methods (list method)))
302
303(defmethod mop::ensure-class-using-class :after (class name  &key direct-slots
304                                             direct-default-initargs 
305                                             &allow-other-keys)
306  (annotate-clos-slots (mop::class-direct-slots (find-class name))))
307
308;; needs to be the last thing. Some interaction with the fasl loader
309(pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*)
310
311;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
312     
313(defun get-pid ()
314  "Get the process identifier of this lisp process. Used to be in
315  slime but generally useful, so now back in abcl proper."
316  (handler-case
317      (let* ((runtime
318              (java::jstatic "getRuntime" "java.lang.Runtime"))
319             (command
320              (java::jnew-array-from-array
321               "java.lang.String" #("sh" "-c" "echo $PPID")))
322             (runtime-exec-jmethod
323              ;; Complicated because java.lang.Runtime.exec() is
324              ;; overloaded on a non-primitive type (array of
325              ;; java.lang.String), so we have to use the actual
326              ;; parameter instance to get java.lang.Class
327              (java::jmethod "java.lang.Runtime" "exec"
328                            (java::jcall
329                             (java::jmethod "java.lang.Object" "getClass")
330                             command)))
331             (process
332              (java::jcall runtime-exec-jmethod runtime command))
333             (output
334              (java::jcall (java::jmethod "java.lang.Process" "getInputStream")
335                          process)))
336         (java::jcall (java::jmethod "java.lang.Process" "waitFor")
337                     process)
338   (loop :with b :do
339      (setq b
340      (java::jcall (java::jmethod "java.io.InputStream" "read")
341            output))
342      :until (member b '(-1 #x0a))  ; Either EOF or LF
343      :collecting (code-char b) :into result
344      :finally (return
345           (parse-integer (coerce result 'string)))))
346    (t () 0)))
347
348(provide :abcl-introspect)
Note: See TracBrowser for help on using the repository browser.