Changeset 12192


Ignore:
Timestamp:
Jun 4, 2009, 4:28:34 PM (10 years ago)
Author:
gz
Message:

In caller-functions, don't ignore self, but do ignore the lfun-name and lfun-info slots of potential callers

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/edit-callers.lisp

    r10481 r12192  
    163163(defun caller-functions (function &aux cfun callers gccount retry)
    164164  "Returns a list of all functions (actual function objects, not names) that reference FUNCTION"
    165   (declare (optimize (speed 3)(safety 0)))
     165  (declare (optimize (speed 3)(safety 0)(debug 0)))
    166166  (when (setf-function-name-p function)
    167167    (let ((nm (cadr function)))
     
    171171                               nm)
    172172                          function))))
    173   (when (and (symbolp function) (fboundp function))
    174     (setq cfun (symbol-function function)))
     173  (when (valid-function-name-p function)
     174    (setq cfun (or (and (symbolp function) (macro-function function))
     175                   (fboundp function))))
    175176  (when (copying-gc-p) (setq gccount (full-gccount)))
    176177  (flet ((do-it (fun)
    177178           (when (and gccount (neq gccount (full-gccount)))
    178179             (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))))))
     180           (when (possible-caller-function-p fun)
     181             (let* ((lfv (function-to-function-vector fun))
     182                    (end (%i- (uvsize lfv) 1))
     183                    (bits (%svref lfv end)))
     184               ;; Don't count the function name slot as a reference.
     185               (unless (logbitp $lfbits-noname-bit bits)
     186                 (decf end))
     187               ;; Don't count lfun-info  either
     188               (when (logbitp $lfbits-info-bit bits)
     189                 (decf end))
     190               (loop for i from #+ppc-target 1 #+x86-target (%function-code-words fun) below end
     191                     as im = (%svref lfv i)
     192                     when (or (eq function im)
     193                              (and cfun (eq cfun im)))
     194                       do (return (pushnew (if (%method-function-p fun)
     195                                             (%method-function-method fun)
     196                                             fun)
     197                                           callers)))))))
    188198    (declare (dynamic-extent #'do-it))
    189199    (loop while (eq :lost (catch 'losing     
Note: See TracChangeset for help on using the changeset viewer.