Changeset 14946

01/16/17 12:27:29 (10 months ago)

abcl-introspect: canonical merge from upstream (Alan Ruttenberg)

Changes in abcl-introspect after merging Mark's changes through
2017-01-13 c.f.

1 added
2 edited


  • trunk/abcl/contrib/abcl-introspect/abcl-introspect.asd

    r14945 r14946  
    77  :description "Introspection on compiled function to aid source location and other debugging functions."
    88  :depends-on (jss)
    9   :components ((:file "abcl-introspect")))
     9  :components ((:file "abcl-introspect")
     10         (:file "stacktrace")))
  • trunk/abcl/contrib/abcl-introspect/abcl-introspect.lisp

    r14945 r14946  
    6767    collect
    6868    (java::jcall "get" (load-time-value (java::jclass-field "org.armedbear.lisp.ClosureBinding" "value")) binding))))
    70 ;;; FIXME:  failing to load with abcl-1.5.0-dev-20170112
    7170(defun foreach-internal-field (fn-fn not-fn-fn &optional (fns :all) (definer nil))
    7271  "fn-n gets called with top, internal function, not-fn-fn gets called with top anything-but"
    73   (declare (optimize (debug 3)
    74                      #+nil
    75                      (speed 3)
    76                      (safety 3)))
     72  (declare (optimize (speed 3) (safety 0)))
    7773  (macrolet ((fields (c) `(java::jcall ,(java::jmethod "java.lang.Class" "getDeclaredFields") ,c))
    7874       (get (f i) `(java::jcall ,(java::jmethod "java.lang.reflect.Field" "get" "java.lang.Object") ,f ,i))
    140136   definer))
     138(defvar *function-class-names* (make-hash-table :test 'equalp :weakness :value)
     139  "Table mapping java class names of function classes to their function. Value is either symbol or (:in symbol) if an internal function")
     141(defun index-function-class-names (&optional (fns :all))
     142  "Create a table mapping class names to function, for cases where the class name appears in backtrace (although perhaps that's a bug?)"
     143  (if (eq fns :all)
     144      (dolist (p (list-all-packages))
     145  (do-symbols (s p)
     146    (when (and (eq (symbol-package s) p) (fboundp s)
     147         ;; system is touchy about #'autoload
     148         (not (eq (symbol-function s) #'autoload)))
     149      (unless (#"matches" (#"getName" (#"getClass" (symbol-function s))) ".*Closure$")
     150    (setf (gethash (#"getName" (#"getClass" (symbol-function s))) *function-class-names*) (symbol-function s))))))
     151      (dolist (s fns)
     152  (setf (gethash (#"getName" (#"getClass" (if (symbolp s) (symbol-function s) s))) *function-class-names*) s)))
     153  (foreach-internal-field
     154   (lambda(top internal)
     155     (let ((fn (if (symbolp top) (symbol-function top) top)))
     156     (unless (or (eq fn internal) (#"matches" (#"getName" (#"getClass" fn)) ".*Closure$"))
     157       (setf (gethash (#"getName" (#"getClass" internal)) *function-class-names*)
     158       internal))))
     159   nil
     160   fns
     161   nil))
     163(defun java-class-lisp-function (class-name)
     164  "Return either function-name or (:in function-name) or nil if class isn't that of lisp function"
     165  (gethash class-name *function-class-names* ))
    142167(defun annotate-clos-methods (&optional (which :all))
    143168  "Iterate over all clos methods, marking method-functions and
    202227above have used annotate local functions"
    203228  (maybe-jss-function function)
    204   (let ((plist (sys::function-plist function)))
    205     (cond ((setq it (getf plist :internal-to-function))
    206      `(:local-function ,@(if (java::jcall "getLambdaName" function)
    207            (list (java::jcall "getLambdaName" function))
    208            (if (getf plist :jss-function)
    209                (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
    210            )
    211            :in ,@(if (typep it 'mop::standard-method)
    212                (cons :method (method-spec-list it))
    213                (list it))))
    214     ((setq it (getf plist :method-function))
    215      (cons :method-function (sys::method-spec-list it)))     
    216     ((setq it (getf plist :method-fast-function))
    217      (cons :method-fast-function (sys::method-spec-list it)))
    218     ((setq it (getf plist :initfunction))
    219      (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
    220        (list :slot-initfunction (slot-value it 'name ) :for (if class (class-name class) '??))))
    221     (t (or (nth-value 2 (function-lambda-expression function))
    222      (and (not (compiled-function-p function))
    223           `(:anonymous-interpreted-function))
    224      (function-name-by-where-loaded-from function))))))
     229  (let ((interpreted (not (compiled-function-p function))))
     230    (let ((plist (sys::function-plist function)))
     231      (cond ((setq it (getf plist :internal-to-function))
     232       `(:local-function ,@(if (java::jcall "getLambdaName" function)
     233             (list (java::jcall "getLambdaName" function))
     234             (if (getf plist :jss-function)
     235           (list (concatenate 'string "#\"" (getf plist :jss-function) "\"")))
     236             )
     237             ,@(if interpreted '((interpreted)))
     238             :in ,@(if (typep it 'mop::standard-method)
     239           (cons :method (method-spec-list it))
     240           (list it))))
     241      ((setq it (getf plist :method-function))
     242       `(:method-function ,@(if interpreted '((interpreted))) ,@(sys::method-spec-list it)))     
     243      ((setq it (getf plist :method-fast-function))
     244       `(:method-fast-function ,@(if interpreted '("(interpreted)")) ,@(sys::method-spec-list it)))
     245      ((setq it (getf plist :initfunction))
     246       (let ((class (and (slot-boundp it 'allocation-class) (slot-value it 'allocation-class))))
     247         `(:slot-initfunction ,(slot-value it 'name ) ,@(if interpreted '((interpreted))) :for ,(if class (class-name class) '??))))
     248      (t (or (and (nth-value 2 (function-lambda-expression function))
     249      (if interpreted
     250          `(,(nth-value 2 (function-lambda-expression function)) ,'(interpreted))
     251      (nth-value 2 (function-lambda-expression function))))   
     252       (and (not (compiled-function-p function))
     253      `(:anonymous-interpreted-function))
     254       (function-name-by-where-loaded-from function)))))))
    226256(defun function-name-by-where-loaded-from (function)
    235265(defun maybe-jss-function (f)
    236   "Determing if function is something list #"foo" called as a
     266  "Determing if function is something list #\"foo\" called as a
    237267  function. If so add to function internal plist :jss-function and the
    238268  name of the java methods"
    290320  been added, add local function annotations to all functions. If not,
    291321  just add annotations to function specified in the arglist"
    292   (declare (ignore function))
    293322  (when *annotate-function-backlog?*
    294323    (setq *annotate-function-backlog?* nil)
    296325    (annotate-clos-methods)
    297326    (annotate-clos-slots)
     327    (index-function-class-names)
    298328    )
     329  (index-function-class-names (list function))
    299330  (annotate-internal-functions (list name)))
Note: See TracChangeset for help on using the changeset viewer.