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

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