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 (sys: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 (sys: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 (sys: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 | (defmethod mop::ensure-class-using-class :after (class name |
---|
362 | &key direct-slots |
---|
363 | direct-default-initargs |
---|
364 | &allow-other-keys) |
---|
365 | (declare (ignore direct-slots direct-default-initargs)) |
---|
366 | (annotate-clos-slots (mop::class-direct-slots (find-class name)))) |
---|
367 | |
---|
368 | ;; Environments |
---|
369 | |
---|
370 | ;; Return a list of the variables and functions in an environment. The form of the list is |
---|
371 | ;; (kind name value) |
---|
372 | ;; where kind is either :lexical-variable or :lexical-function :special-variable |
---|
373 | |
---|
374 | (defun environment-parts (env) |
---|
375 | (append |
---|
376 | (loop for binding = (jss:get-java-field env "vars" t) then (jss:get-java-field binding "next" t) |
---|
377 | while binding |
---|
378 | for symbol = (jss:get-java-field binding "symbol" t) |
---|
379 | for value = (jss:get-java-field binding "value" t) |
---|
380 | for special = (jss:get-java-field binding "specialp" t) |
---|
381 | if (member symbol '(:catch)) |
---|
382 | collect `(,symbol ,value) into them |
---|
383 | else |
---|
384 | unless (find symbol them :key 'second) |
---|
385 | collect (list (if special |
---|
386 | :special-variable |
---|
387 | (if (jss:jtypep value 'lisp.SymbolMacro) |
---|
388 | :symbol-macro |
---|
389 | :lexical-variable)) |
---|
390 | |
---|
391 | symbol |
---|
392 | (if (jss:jtypep value 'lisp.SymbolMacro) |
---|
393 | (#"getExpansion" value) |
---|
394 | value)) |
---|
395 | into them |
---|
396 | finally (return them)) |
---|
397 | (loop for binding = (jss:get-java-field env "lastFunctionBinding" t) |
---|
398 | then (jss:get-java-field binding "next" t) |
---|
399 | while binding |
---|
400 | for name = (jss:get-java-field binding "name" t) |
---|
401 | for value = (jss:get-java-field binding "value" t) |
---|
402 | unless (find name them :key 'second) |
---|
403 | collect (list :lexical-function name value) into them |
---|
404 | finally (return them)) |
---|
405 | (loop for binding = (jss::get-java-field env "blocks" t) |
---|
406 | then (jss::get-java-field binding "next" t) |
---|
407 | while binding |
---|
408 | for name = (jss::get-java-field binding "symbol" t) |
---|
409 | for value = (jss::get-java-field binding "value" t) |
---|
410 | unless (find name them :key 'second) |
---|
411 | collect (list :block name value) into them |
---|
412 | finally (return them)))) |
---|
413 | |
---|
414 | ;; Locals |
---|
415 | |
---|
416 | ;; Locals are retrived from envStack, a stack of environments and |
---|
417 | ;; function call markers distinct from the call stack, one per |
---|
418 | ;; thread. Locals are only available for interpreted functions. The |
---|
419 | ;; envStack is distinct from the call stance because there are function |
---|
420 | ;; calls which create environments, for instance to special operators |
---|
421 | ;; like sf_let, that are not in the lisp call stack. |
---|
422 | |
---|
423 | ;; A function call marker in this context is an environment with a variable binding |
---|
424 | ;; whose symbol is nil. Implementing the markers this way means we don't have |
---|
425 | ;; to deal with different sorts of things on the envStack, which makes the |
---|
426 | ;; java side of things easier. |
---|
427 | |
---|
428 | ;; Environments are chained. So a binding of a new local, by e.g. let, will |
---|
429 | ;; have a new environment created which has the new binding and a pointer |
---|
430 | ;; to the environment with the previous binding. |
---|
431 | |
---|
432 | ;; Since all environments created are on the envStack, we have to figure |
---|
433 | ;; out which environment is the one that is the most current for a given |
---|
434 | ;; function being executed when we land in the debugger. |
---|
435 | |
---|
436 | ;; collapse-locals is responsible for filtering out the environments |
---|
437 | ;; that aren't the most current for each function being executed. It |
---|
438 | ;; returns a list whose head is the function being executed and whose |
---|
439 | ;; tail is a list of bindings from environment-parts. |
---|
440 | |
---|
441 | ;; have to get the stack contents using this instead of j2list as in |
---|
442 | ;; that case we get a concurrent modification exception as we iterate |
---|
443 | ;; through the iterator, when some other function call is made. |
---|
444 | |
---|
445 | ;; BEGIN use :abcl-introspect/system |
---|
446 | (in-package :abcl-introspect/system) |
---|
447 | |
---|
448 | (defun collapse-locals (thread) |
---|
449 | (flet ((stack-to-list (stack) |
---|
450 | (coerce (#"toArray" stack) 'list))) |
---|
451 | (loop for bindings in (mapcar 'sys::environment-parts |
---|
452 | (stack-to-list (jss:get-java-field thread "envStack" t))) |
---|
453 | with last-locals |
---|
454 | with last-function |
---|
455 | for binding = (car bindings) |
---|
456 | if (eq (second binding) nil) |
---|
457 | collect (prog1 |
---|
458 | (list last-function last-locals) |
---|
459 | (setq last-locals nil) |
---|
460 | (setq last-function (third binding))) |
---|
461 | else |
---|
462 | do (setq last-locals bindings)))) |
---|
463 | |
---|
464 | ;; Now that we have the pairings of function-executing and lexicals we need |
---|
465 | ;; to associate each such function with the stack frame for it being |
---|
466 | ;; called. To do that, for each function and locals we find and record the |
---|
467 | ;; first occurrence of the function in the backtrace. Functions may appear |
---|
468 | ;; more than once in the envStack because they have been called more than |
---|
469 | ;; once. In addition the envStack will have more functions than there are |
---|
470 | ;; frames. |
---|
471 | |
---|
472 | ;; In order for our envstack association to be an alignment with the stack, |
---|
473 | ;; the associations must be in ascending order. That is, if we start at |
---|
474 | ;; the top of the collapsed envstack, then the frame number each function |
---|
475 | ;; is associated with must be in ascending order. |
---|
476 | |
---|
477 | ;; So, first walk through the associations and remove any frame numbers |
---|
478 | ;; above that are greater than the index of this association. e.g. if we |
---|
479 | ;; have |
---|
480 | |
---|
481 | ;; (f1 frame#3 locals) |
---|
482 | ;; (f2 frame#2 locals) |
---|
483 | |
---|
484 | ;; then frame#3 must be a wrong pairing since it is out of order. So we |
---|
485 | ;; erase those to get |
---|
486 | |
---|
487 | ;; (f1 nil locals) |
---|
488 | ;; (f2 frame#2 locals) |
---|
489 | |
---|
490 | ;; Also, since there may be more than one call to a function we might have |
---|
491 | ;; something like |
---|
492 | |
---|
493 | ;; (f1 frame#2 locals) |
---|
494 | ;; (f2 frame#3 locals) |
---|
495 | ;; (f1 frame#2 locals) |
---|
496 | |
---|
497 | ;; Only the first one is right, so we erases subsequent ones, yielding |
---|
498 | |
---|
499 | ;; (f1 frame#2 locals) |
---|
500 | ;; (f2 frame#3 locals) |
---|
501 | ;; (f1 nil locals) |
---|
502 | |
---|
503 | ;; At this point we now have a some-to-one mapping of functions to frames |
---|
504 | ;; find-locals takes a backtrace and an index of a frame in that backtrace |
---|
505 | ;; and returns the locals for the frame. To get it we just search for the |
---|
506 | ;; first entry that has the required frame number. |
---|
507 | |
---|
508 | ;; find-locals still has debugging code in it which will be removed after |
---|
509 | ;; there has been sufficient testing. |
---|
510 | ;;; ME: presumably *debugging-locals-p* can go away now? |
---|
511 | (defvar *debugging-locals-p* nil |
---|
512 | "Whether SYS:FIND-LOCALS should be looking for local variables") |
---|
513 | |
---|
514 | (defun find-locals (index backtrace) |
---|
515 | "Return local variable bindings at INDEX in BACKTRACE |
---|
516 | |
---|
517 | Added by ABCL-INTROSPECT." |
---|
518 | (let ((thread (jss:get-java-field (nth index backtrace) "thread" t))) |
---|
519 | (and *debugging-locals-p* (print `(:collapse ,thread ,index))) |
---|
520 | (let ((collapsed (collapse-locals thread))) |
---|
521 | (and *debugging-locals-p* (map nil 'print collapsed)) |
---|
522 | (let ((alignment |
---|
523 | (loop for function-local-association in (reverse collapsed) |
---|
524 | with backtrace = (map 'list (if *debugging-locals-p* 'print 'identity) backtrace) |
---|
525 | for pos = (position (car function-local-association) backtrace |
---|
526 | :key (lambda(frame) |
---|
527 | (if (typep frame 'sys::lisp-stack-frame) |
---|
528 | (#"getOperator" frame) |
---|
529 | (jss:get-java-field frame "METHOD" t)))) |
---|
530 | collect (list (car function-local-association) |
---|
531 | pos |
---|
532 | (cdr function-local-association))))) |
---|
533 | (and *debugging-locals-p* (print :erase) (map nil 'print alignment)) |
---|
534 | ;; first erasure of out of order frames |
---|
535 | (loop for (nil pos) in alignment |
---|
536 | for i from 0 |
---|
537 | when pos do |
---|
538 | (loop for pair in (subseq alignment 0 i) |
---|
539 | for (nil pos2) = pair |
---|
540 | unless (null pos2) |
---|
541 | if (> pos2 pos) |
---|
542 | do (setf (second pair) nil))) |
---|
543 | (and *debugging-locals-p* (print :align) (map nil 'print alignment)) |
---|
544 | ;; second erasure of duplicate frame numbers |
---|
545 | (loop for (nil pos) in alignment |
---|
546 | for i from 0 |
---|
547 | do |
---|
548 | (loop for pair in (subseq alignment (1+ i)) |
---|
549 | for (nil pos2) = pair |
---|
550 | unless (null pos2) |
---|
551 | if (eql pos2 pos) |
---|
552 | do (setf (second pair) nil))) |
---|
553 | (and *debugging-locals-p* (map nil 'print alignment)) |
---|
554 | (if *debugging-locals-p* |
---|
555 | (print `(:find ,(cddr (find index alignment :key 'second :test 'eql))))) |
---|
556 | ;; finally, look up the locals for the given frame index |
---|
557 | (cddr (find index alignment :key 'second :test 'eql)))))) |
---|
558 | ;; END use :abcl-introspect/system |
---|
559 | (in-package :system) |
---|
560 | |
---|
561 | ;; needs to be the last thing. Some interaction with the fasl loader |
---|
562 | (pushnew 'fset-hook-annotate-internal-function sys::*fset-hooks*) |
---|
563 | |
---|
564 | (provide :abcl-introspect) |
---|
565 | |
---|