Changeset 14946


Ignore:
Timestamp:
01/16/17 12:27:29 (10 months ago)
Author:
mevenson
Message:

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

Changes in abcl-introspect after merging Mark's changes through
2017-01-13 c.f.
<https://github.com/alanruttenberg/abcl/commits/abcl-introspect-2017-01-13>.

Location:
trunk/abcl/contrib/abcl-introspect
Files:
1 added
2 edited

Legend:

Unmodified
Added
Removed
  • 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))))
    69 
    70 ;;; FIXME:  failing to load with abcl-1.5.0-dev-20170112
     69   
    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))
    141137
     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")
     140
     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))
     162
     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* ))
     166
    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)))))))
    225255
    226256(defun function-name-by-where-loaded-from (function)
     
    234264 
    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)))
    300331
Note: See TracChangeset for help on using the changeset viewer.