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 (defun function-arglist (function)
  48   "Describe the lambda list for the function designator FUNCTION.
  49 Works for special-operators, macros, simple functions and generic
  50 functions.  Signals error if not found"
  51   (cond ((valid-function-name-p function)
  52          (function-arglist
  53           (or (macro-function function) (fdefinition function))))
  54         ((typep function 'generic-function)
  55          (sb-pcl::generic-function-pretty-arglist function))
  56         (t (sb-impl::%simple-fun-arglist
  57             (sb-impl::%closure-fun function)))))
  58
  59 (defgeneric find-definition-source (thing)
  60   (:documentation "Find the source location that defines THING.
  61 Returns a DEFINITION-SOURCE object"))
  62
  63 ;;; This is an opaque object with accessors as per export list.
  64 ;;; Might not be a struct.
  65
  66 (defstruct definition-source
  67   pathname                              ; source file, not fasl
  68   form-path
  69   character-offset
  70   )
  71
  72 ;;; This is kludgey.  We expect these functions (the underlying functions,
  73 ;;; not the closures) to be in static space and so not move ever.
  74 ;;; FIXME It's also possibly wrong: not all structures use these vanilla
  75 ;;; accessors, e.g. when the :type option is used
  76 (defvar *struct-slotplace-reader*
  77   (sb-vm::%simple-fun-self #'definition-source-pathname))
  78 (defvar *struct-slotplace-writer*
  79   (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
  80 (defvar *struct-predicate*
  81   (sb-vm::%simple-fun-self #'definition-source-p))
  82
  83 ;; Internal-only, don't call this directly
  84 (defun find-function-definition-source (o)
  85   (let* ((debug-info
  86           (sb-kernel:%code-debug-info
  87            (sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
  88          (debug-source
  89           (car (sb-c::compiled-debug-info-source debug-info)))
  90          (debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
  91          (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
  92     ;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source
  93     ;; for a debug-info (one per file).  In SBCL the function that builds
  94     ;; debug-sources always produces singleton lists
  95     (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
  96     (make-definition-source
  97      :pathname
  98      (and (eql (sb-c::debug-source-from debug-source) :file)
  99           (parse-namestring (sb-c::debug-source-name debug-source)))
 100      ;; we don't have a real sexp path, annoyingly.  Fake one from the
 101      ;; top-level form number
 102      :character-offset
 103      (and tlf
 104           (elt (sb-c::debug-source-start-positions debug-source) tlf))
 105      :form-path (and tlf (list tlf)))))
 106
 107 (defmethod find-definition-source ((o function))
 108   (cond
 109     ((struct-accessor-p o)
 110      (find-definition-source (struct-accessor-structure-class o)))
 111     ((struct-predicate-p o)
 112      (find-definition-source (struct-predicate-structure-class o)))
 113     (t (find-function-definition-source o))))
 114
 115 (defmethod find-definition-source ((o method))
 116   (find-definition-source (or (sb-pcl::method-fast-function o)
 117                               (sb-pcl:method-function o))))
 118
 119 (defmethod find-definition-source (name)
 120   (and (valid-function-name-p name)
 121        (find-definition-source (or (macro-function name) (fdefinition name)))))
 122
 123 ;; these are internal functions, and probably incomplete
 124 (defun struct-accessor-p (function)
 125   (let ((self (sb-vm::%simple-fun-self function)))
 126     ;; FIXME there are other kinds of struct accessor.  Fill out this list
 127     (member self (list *struct-slotplace-reader*
 128                        *struct-slotplace-writer*))))
 129
 130 (defun struct-predicate-p (function)
 131   (let ((self (sb-vm::%simple-fun-self function)))
 132     ;; FIXME there may be other structure predicate functions
 133     (member self (list *struct-predicate*))))
 134
 135 ;; FIXME need one for constructor too, perhaps
 136
 137 (defun struct-accessor-structure-class (function)
 138   (let ((self (sb-vm::%simple-fun-self function)))
 139     (cond
 140       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 141        (find-class
 142         (sb-kernel::classoid-name
 143          (sb-kernel::layout-classoid
 144           (sb-kernel:%closure-index-ref function 1)))))
 145       )))
 146
 147 (defun struct-predicate-structure-class (function)
 148   (let ((self (sb-vm::%simple-fun-self function)))
 149     (cond
 150       ((member self (list *struct-predicate*))
 151        (find-class
 152         (sb-kernel::classoid-name
 153          (sb-kernel::layout-classoid
 154           (sb-kernel:%closure-index-ref function 0)))))
 155       )))
 156
 157 (defmethod find-definition-source ((o structure-class))
 158   ;; FIXME we don't get form-number from this, which is a shame
 159   (let ((constructor
 160          (sb-kernel::structure-classoid-constructor
 161           (sb-kernel:classoid-cell-classoid
 162            (sb-int:info :type :classoid (class-name o))))))
 163     (find-definition-source constructor)))
 164
 165 ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
 166
 167 ;;; This interface is trmendously experimental.
 168
 169 ;;; For the moment I'm taking the view that FDEFN is an internal
 170 ;;; object (one out of one CMUCL developer surveyed didn't know what
 171 ;;; they were for), so these routines deal in FUNCTIONs
 172
 173 ;;; Find callers and callees by looking at the constant pool of
 174 ;;; compiled code objects.  We assume every fdefn object in the
 175 ;;; constant pool corresponds to a call to that function.  A better
 176 ;;; strategy would be to use the disassembler to find actual
 177 ;;; call-sites.
 178
 179 (declaim (inline map-code-constants))
 180 (defun map-code-constants (code fn)
 181   "Call FN for each constant in CODE's constant pool."
 182   (check-type code sb-kernel:code-component)
 183   (loop for i from sb-vm:code-constants-offset below
 184         (sb-kernel:get-header-data code)
 185         do (funcall fn (sb-kernel:code-header-ref code i))))
 186
 187 (defun find-function-callees (function)
 188   "Return functions called by FUNCTION."
 189   (let ((callees '()))
 190     (map-code-constants
 191      (sb-kernel:fun-code-header function)
 192      (lambda (obj)
 193        (when (sb-kernel:fdefn-p obj)
 194          (push (sb-kernel:fdefn-fun obj)
 195                callees))))
 196     callees))
 197
 198 (declaim (inline map-allocated-code-components))
 199 (defun map-allocated-code-components (spaces fn)
 200   "Call FN for each allocated code component in one of SPACES.  FN
 201 receives the object and its size as arguments.  SPACES should be a
 202 list of the symbols :dynamic, :static, or :read-only."
 203   (dolist (space spaces)
 204     (sb-vm::map-allocated-objects
 205      (lambda (obj header size)
 206        (when (= sb-vm:code-header-widetag header)
 207          (funcall fn obj size)))
 208      space)))
 209
 210 (declaim (inline map-caller-code-components))
 211 (defun map-caller-code-components (function spaces fn)
 212   "Call FN for each code component with a fdefn for FUNCTION in its
 213 constant pool."
 214   (let ((function (coerce function 'function)))
 215     (map-allocated-code-components
 216      spaces
 217      (lambda (obj size)
 218        (declare (ignore size))
 219        (map-code-constants
 220         obj
 221         (lambda (constant)
 222           (when (and (sb-kernel:fdefn-p constant)
 223                      (eq (sb-kernel:fdefn-fun constant)
 224                          function))
 225             (funcall fn obj))))))))
 226
 227 (defun find-function-callers (function &optional (spaces '(:read-only :static
 228                                                            :dynamic)))
 229   "Return functions which call FUNCTION, by searching SPACES for code objects"
 230   (let ((referrers '()))
 231     (map-caller-code-components
 232      function
 233      spaces
 234      (lambda (code)
 235        (let ((entry (sb-kernel:%code-entry-points  code)))
 236          (cond ((not entry)
 237                 (push (princ-to-string code) referrers))
 238                (t
 239                 (loop for e = entry then (sb-kernel::%simple-fun-next e)
 240                       while e
 241                       do (pushnew e referrers)))))))
 242     referrers))
 243
 244 (provide 'sb-introspect)