source: branches/qres/ccl/lib/edit-callers.lisp @ 14259

Last change on this file since 14259 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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