source: trunk/source/lib/edit-callers.lisp @ 11126

Last change on this file since 11126 was 11126, checked in by gz, 11 years ago

From working-0711: new fn CALLER-FUNCTIONS, like CALLERS but returns the actual function objects rather than names

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.7 KB
Line 
1; -*- Mode:Lisp; Package:CCL; -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17; edit-callers.lisp
18
19(in-package "CCL")
20
21(defun global-function-p (random &optional name)
22  (let* ((thing random)
23         (name (or name (ignore-errors (function-name thing)))))
24    (and name
25         (or (not (or (symbolp name)(and (consp name)(eq (car name) 'setf)))) ; maybe its (setf baz)
26             (let ((fn  (fboundp name)))
27               (and fn
28                    (progn
29                ; maybe this is enough for both cases?
30                      (or (eq thing fn)
31                          (and (symbolp name)(eq thing (macro-function name))))))))
32         name)))
33
34(defvar *function-parent-table* nil)
35(defvar *function-parent-pool* (%cons-pool))
36
37(defun copying-gc-p () ; if nz copying gc is on
38  nil)
39
40(defun lfun-closure-p (lfun)
41  (logbitp $lfbits-trampoline-bit (lfun-bits lfun)))
42
43; make a macro ?
44(defun puthash-parent (im fun)
45  (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply))
46    (if (global-function-p fun)
47      (setf (gethash im *function-parent-table*) fun)
48      (let ((ht (gethash im *function-parent-table*)))
49        (if (not ht)
50          (setf (gethash im *function-parent-table*) fun)
51          (unless (eq ht fun)
52            (if (consp ht)
53              (when (not (memq fun ht))(nconc ht (list fun)))
54              (if (not (global-function-p ht))
55                (setf (gethash im *function-parent-table*) (list ht fun))))))))))       
56
57
58(defun callers (function &aux cfun callers gccount retry)
59  ;(declare (special cfun function callers))
60  (declare (optimize (speed 3)(safety 0)))
61
62  (let ((*function-parent-table* nil))
63    (if (setf-function-name-p function)
64      (let ((nm (cadr function)))
65        (setq function  (or (%setf-method nm)
66                            (and (symbolp nm)
67                                 (setq nm (setf-function-name nm))
68                                 (fboundp nm)
69                                 nm)
70                            function))))
71    (if (and (symbolp function) (fboundp function))
72      (setq cfun (symbol-function function)))
73    (when (copying-gc-p) (setq gccount (full-gccount)))
74    (flet ((do-it (fun)
75             (when (and gccount (neq gccount (full-gccount)))
76               (throw 'losing :lost))
77             (when (possible-caller-function-p fun)
78               (let* ((nm (ignore-errors (lfun-name fun)))
79                      (globalp (if nm (global-function-p fun nm))))
80                 (flet ((do-imm (im)
81                          (when (and (or (eq function im)
82                                         (and cfun (eq cfun im)))
83                                     (neq im nm))                             
84                            (push fun callers)) 
85                          (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply))
86                            (if globalp
87                              (setf (gethash im *function-parent-table*) fun)
88                              (let ((ht (gethash im *function-parent-table*)))
89                                (if (not ht)
90                                  (setf (gethash im *function-parent-table*) fun)
91                                  (unless (eq ht fun)
92                                    (if (consp ht)
93                                      (when (not (memq fun ht))(nconc ht (list fun)))
94                                      (if (not (global-function-p ht))
95                                        (setf (gethash im *function-parent-table*) 
96                                              (list ht fun)))))))))))
97                   (declare (dynamic-extent #'do-imm))                               
98                   (%map-lfimms fun #'do-imm ))))))
99      (declare (dynamic-extent #'do-it))
100      (unwind-protect
101           (progn
102             (let* ((pool *function-parent-pool*)
103                    (tbl (pool.data pool)))
104               (setf (pool.data pool) nil
105                     *function-parent-table*
106                     (if tbl
107                       (clrhash tbl)
108                       (make-hash-table :size 700 :test 'eq :weak :value))))
109             (loop
110               (cond ((eq :lost (catch 'losing     
111                                  (%map-lfuns #'do-it)))
112                      (when retry (error "Callers is losing"))
113                      (setq callers nil)
114                      (setq retry t))
115                     (t (return))))
116             (delete-if #'(lambda (thing)
117                            (or (functionp thing)
118                                (and (typep thing 'method)
119                                     (let ((gf (fboundp (method-name thing))))
120                                       (not (and (typep gf 'standard-generic-function)
121                                                 (memq thing (%gf-methods gf))))))))
122                        (delete-duplicates (mapcar 'top-level-caller callers))))
123        (setf (pool.data *function-parent-pool*) *function-parent-table*
124              *function-parent-table* nil)))))
125
126
127(defun top-level-caller (function &optional the-list)
128  (or (global-function-p function)
129      (pascal-function-p function)
130      (let ((name (function-name function)))
131        (and name (function-encapsulated-p name) name))
132      (let ((caller function) next)
133        (loop
134          (setq next (gethash caller *function-parent-table*))
135          (if  next
136            (cond ((consp next)
137                   (when (null the-list)(push function the-list))
138                   (return
139                    (dolist (c next)
140                      (when (not (memq c the-list))
141                        (let ((res (top-level-caller c the-list)))
142                          (when (and res (not (functionp res)))
143                            (return res)))))))
144                  (t (let ((res (global-function-p next)))
145                       (when res (return res)))
146                     (when (null the-list)(push function the-list))
147                     (when (memq next the-list) (return))
148                     (push next the-list)
149                     (setq caller next)))
150            (return caller))))
151      function))
152
153(defun possible-caller-function-p (fun)
154  (let ((bits (lfun-bits fun)))
155    (declare (fixnum bits))
156    (not (or (and (logbitp $lfbits-cm-bit bits)
157                  (not (logbitp $lfbits-method-bit bits))) ; combined method
158             (and (logbitp $lfbits-trampoline-bit bits)
159                  (lfun-closure-p fun)
160                  (not (global-function-p fun))))))) ; closure (interp or compiled)
161
162 
163(defun caller-functions (function &aux cfun callers gccount retry)
164  "Returns a list of all functions (actual function objects, not names) that reference FUNCTION"
165  (declare (optimize (speed 3)(safety 0)))
166  (when (setf-function-name-p function)
167    (let ((nm (cadr function)))
168      (setq function  (or (%setf-method nm)
169                          (and (setq nm (setf-function-name nm))
170                               (fboundp nm)
171                               nm)
172                          function))))
173  (when (and (symbolp function) (fboundp function))
174    (setq cfun (symbol-function function)))
175  (when (copying-gc-p) (setq gccount (full-gccount)))
176  (flet ((do-it (fun)
177           (when (and gccount (neq gccount (full-gccount)))
178             (throw 'losing :lost))
179           (when (and (neq fun cfun)
180                      (possible-caller-function-p fun))
181             (lfunloop for im in fun
182               when (or (eq function im)
183                        (and cfun (eq cfun im)))
184               do (return (pushnew (if (%method-function-p fun)
185                                     (%method-function-method fun)
186                                     fun)
187                                   callers))))))
188    (declare (dynamic-extent #'do-it))
189    (loop while (eq :lost (catch 'losing     
190                            (%map-lfuns #'do-it)))
191          do (when retry (cerror "Try again" "Callers is losing"))
192          do (setq callers nil)
193          do (setq retry t))
194    callers))
195
196; in 3.x the function in pascal-functions calls the actual function
197(defun pascal-function-p (function)
198  (if (find function %pascal-functions%
199            :test #'eq
200            :key #'(lambda (elt)
201                     (if (consp elt)
202                       (let ((one (cdr elt)))
203                         (when (and (eq (function-name one)(function-name function))
204                                    (block blob
205                                      (%map-lfimms one #'(lambda (imm)
206                                                           (when (eq imm function)
207                                                             (return-from blob function))))))
208                           function))
209                       (if elt (aref elt 2)))))
210    (function-name function)))
211
212
213;;; Calls function f with args (imm) on each immediate in lfv.
214
215(defun %map-lfimms (function-object f)
216  (let* ((lfv (function-to-function-vector function-object))
217         (n (- (uvsize lfv) 2)))
218    (declare (fixnum n))
219    #+ppc-target
220    (dotimes (i n)
221      (funcall f (%svref lfv (%i+ 1 i))))
222    #+x86-target
223    (do* ((i (1- (the fixnum (%function-code-words function-object))) (1+ i)))
224         ((= i n))
225      (declare (fixnum i))
226      (funcall f (%svref lfv (%i+ 1 i))))
227    ))
228         
229   
230
231
232(provide :edit-callers)
Note: See TracBrowser for help on using the repository browser.