contrib/sb-introspect/sb-introspect.lisp

   1 ;;; This is here as a discussion point, not yet a supported interface.  If
   2 ;;; you would like to use the functions here, or you would like other
   3 ;;; functions to be here, join the debate on navel@metacircles.com.
   4 ;;; List info at http://lists.metacircles.com/cgi-bin/mailman/listinfo/navel
   5
   6 ;;; For the avoidance of doubt, the exported interface is the proposed
   7 ;;; supported interface.  Anything else is internal, though you're
   8 ;;; welcome to argue a case for exporting it.
   9
  10 ;;; If you steal the code from this file to cut and paste into your
  11 ;;; own project, there will be much wailing and gnashing of teeth.
  12 ;;; Your teeth.  If need be, we'll kick them for you.  This is a
  13 ;;; contrib, we're allowed to look in internals.  You're an
  14 ;;; application programmer, and are not.
  15
  16 ;;; TODO
  17 ;;; 1) structs don't have within-file location info.  problem for the
  18 ;;;   structure itself, accessors and the predicate
  19 ;;; 2) what should find-definition-source on a symbol return?  there may be
  20 ;;;   several definitions (class, function, etc)
  21 ;;; 3) error handling.  Signal random errors, or handle and resignal 'our'
  22 ;;;   error, or return NIL?
  23 ;;; 4) FIXMEs
  24 ;;; 5) would be nice to have some interface to the compiler that lets us
  25 ;;;   fake the filename and position, for use with C-M-x
  26
  27 (declaim (optimize (debug 1)))
  28
  29 (defpackage :sb-introspect
  30   (:use "CL")
  31   (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P"
  32            "FIND-DEFINITION-SOURCE"
  33            "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME"
  34            "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
  35            "DEFINITION-SOURCE-FORM-PATH"
  36            "DEFINITION-SOURCE-CHARACTER-OFFSET"
  37            "FIND-FUNCTION-CALLEES"
  38            "FIND-FUNCTION-CALLERS"
  39            ))
  40 (in-package :sb-introspect)
  41
  42
  43 (defun valid-function-name-p (name)
  44   "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
  45   (and (sb-int:valid-function-name-p name) t))
  46
  47 ;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST?
  48 (defun function-arglist (function)
  49   "Describe the lambda list for the function designator FUNCTION.
  50 Works for special-operators, macros, simple functions and generic
  51 functions.  Signals error if not found"
  52   (cond ((valid-function-name-p function)
  53          (function-arglist
  54           (or (macro-function function) (fdefinition function))))
  55         ((typep function 'generic-function)
  56          (sb-pcl::generic-function-pretty-arglist function))
  57         (t (sb-impl::%simple-fun-arglist
  58             (sb-impl::%closure-fun function)))))
  59
  60 (defgeneric find-definition-source (thing)
  61   (:documentation "Find the source location that defines THING.
  62 Returns a DEFINITION-SOURCE object"))
  63
  64 ;;; This is an opaque object with accessors as per export list.
  65 ;;; Might not be a struct.
  66
  67 (defstruct definition-source
  68   pathname                              ; source file, not fasl
  69   form-path
  70   character-offset
  71   )
  72
  73 ;;; This is kludgey.  We expect these functions (the underlying functions,
  74 ;;; not the closures) to be in static space and so not move ever.
  75 ;;; FIXME It's also possibly wrong: not all structures use these vanilla
  76 ;;; accessors, e.g. when the :type option is used
  77 (defvar *struct-slotplace-reader*
  78   (sb-vm::%simple-fun-self #'definition-source-pathname))
  79 (defvar *struct-slotplace-writer*
  80   (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
  81 (defvar *struct-predicate*
  82   (sb-vm::%simple-fun-self #'definition-source-p))
  83
  84 ;; Internal-only, don't call this directly
  85 (defun find-function-definition-source (o)
  86   (let* ((debug-info
  87           (sb-kernel:%code-debug-info
  88            (sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
  89          (debug-source
  90           (car (sb-c::compiled-debug-info-source debug-info)))
  91          (debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
  92          (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
  93     ;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source
  94     ;; for a debug-info (one per file).  In SBCL the function that builds
  95     ;; debug-sources always produces singleton lists
  96     (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
  97     (make-definition-source
  98      :pathname
  99      (and (eql (sb-c::debug-source-from debug-source) :file)
 100           (parse-namestring (sb-c::debug-source-name debug-source)))
 101      ;; we don't have a real sexp path, annoyingly.  Fake one from the
 102      ;; top-level form number
 103      :character-offset
 104      (and tlf
 105           (elt (sb-c::debug-source-start-positions debug-source) tlf))
 106      :form-path (and tlf (list tlf)))))
 107
 108 (defmethod find-definition-source ((o function))
 109   (cond
 110     ((struct-accessor-p o)
 111      (find-definition-source (struct-accessor-structure-class o)))
 112     ((struct-predicate-p o)
 113      (find-definition-source (struct-predicate-structure-class o)))
 114     (t (find-function-definition-source o))))
 115
 116 (defmethod find-definition-source ((o method))
 117   (find-definition-source (or (sb-pcl::method-fast-function o)
 118                               (sb-pcl:method-function o))))
 119
 120 (defmethod find-definition-source (name)
 121   (and (valid-function-name-p name)
 122        (find-definition-source (or (macro-function name) (fdefinition name)))))
 123
 124 ;; these are internal functions, and probably incomplete
 125 (defun struct-accessor-p (function)
 126   (let ((self (sb-vm::%simple-fun-self function)))
 127     ;; FIXME there are other kinds of struct accessor.  Fill out this list
 128     (member self (list *struct-slotplace-reader*
 129                        *struct-slotplace-writer*))))
 130
 131 (defun struct-predicate-p (function)
 132   (let ((self (sb-vm::%simple-fun-self function)))
 133     ;; FIXME there may be other structure predicate functions
 134     (member self (list *struct-predicate*))))
 135
 136 ;; FIXME need one for constructor too, perhaps
 137
 138 (defun struct-accessor-structure-class (function)
 139   (let ((self (sb-vm::%simple-fun-self function)))
 140     (cond
 141       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 142        (find-class
 143         (sb-kernel::classoid-name
 144          (sb-kernel::layout-classoid
 145           (sb-kernel:%closure-index-ref function 1)))))
 146       )))
 147
 148 (defun struct-predicate-structure-class (function)
 149   (let ((self (sb-vm::%simple-fun-self function)))
 150     (cond
 151       ((member self (list *struct-predicate*))
 152        (find-class
 153         (sb-kernel::classoid-name
 154          (sb-kernel::layout-classoid
 155           (sb-kernel:%closure-index-ref function 0)))))
 156       )))
 157
 158 (defmethod find-definition-source ((o structure-class))
 159   ;; FIXME we don't get form-number from this, which is a shame
 160   (let ((constructor
 161          (sb-kernel::structure-classoid-constructor
 162           (sb-kernel:classoid-cell-classoid
 163            (sb-int:info :type :classoid (class-name o))))))
 164     (find-definition-source constructor)))
 165
 166 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
 167
 168 ;;; This interface is trmendously experimental.
 169
 170 ;;; For the moment I'm taking the view that FDEFN is an internal
 171 ;;; object (one out of one CMUCL developer surveyed didn't know what
 172 ;;; they were for), so these routines deal in FUNCTIONs
 173
 174 ;;; Find callers and callees by looking at the constant pool of
 175 ;;; compiled code objects.  We assume every fdefn object in the
 176 ;;; constant pool corresponds to a call to that function.  A better
 177 ;;; strategy would be to use the disassembler to find actual
 178 ;;; call-sites.
 179
 180 (declaim (inline map-code-constants))
 181 (defun map-code-constants (code fn)
 182   "Call FN for each constant in CODE's constant pool."
 183   (check-type code sb-kernel:code-component)
 184   (loop for i from sb-vm:code-constants-offset below
 185         (sb-kernel:get-header-data code)
 186         do (funcall fn (sb-kernel:code-header-ref code i))))
 187
 188 (defun find-function-callees (function)
 189   "Return functions called by FUNCTION."
 190   (let ((callees '()))
 191     (map-code-constants
 192      (sb-kernel:fun-code-header function)
 193      (lambda (obj)
 194        (when (sb-kernel:fdefn-p obj)
 195          (push (sb-kernel:fdefn-fun obj)
 196                callees))))
 197     callees))
 198
 199 (declaim (inline map-allocated-code-components))
 200 (defun map-allocated-code-components (spaces fn)
 201   "Call FN for each allocated code component in one of SPACES.  FN
 202 receives the object and its size as arguments.  SPACES should be a
 203 list of the symbols :dynamic, :static, or :read-only."
 204   (dolist (space spaces)
 205     (sb-vm::map-allocated-objects
 206      (lambda (obj header size)
 207        (when (= sb-vm:code-header-widetag header)
 208          (funcall fn obj size)))
 209      space)))
 210
 211 (declaim (inline map-caller-code-components))
 212 (defun map-caller-code-components (function spaces fn)
 213   "Call FN for each code component with a fdefn for FUNCTION in its
 214 constant pool."
 215   (let ((function (coerce function 'function)))
 216     (map-allocated-code-components
 217      spaces
 218      (lambda (obj size)
 219        (declare (ignore size))
 220        (map-code-constants
 221         obj
 222         (lambda (constant)
 223           (when (and (sb-kernel:fdefn-p constant)
 224                      (eq (sb-kernel:fdefn-fun constant)
 225                          function))
 226             (funcall fn obj))))))))
 227
 228 (defun find-function-callers (function &optional (spaces '(:read-only :static
 229                                                            :dynamic)))
 230   "Return functions which call FUNCTION, by searching SPACES for code objects"
 231   (let ((referrers '()))
 232     (map-caller-code-components
 233      function
 234      spaces
 235      (lambda (code)
 236        (let ((entry (sb-kernel:%code-entry-points  code)))
 237          (cond ((not entry)
 238                 (push (princ-to-string code) referrers))
 239                (t
 240                 (loop for e = entry then (sb-kernel::%simple-fun-next e)
 241                       while e
 242                       do (pushnew e referrers)))))))
 243     referrers))
 244
 245 (provide 'sb-introspect)