Changeset 15013


Ignore:
Timestamp:
05/23/17 11:00:13 (3 months ago)
Author:
mevenson
Message:

Restore the ability SYSTEM:CHOOSE-ASSEMBLER to use Objectweb

The Objectweb disassembler has been moved into the ABCL-INTROSPECT
contrib where it can be rationally installed via ABCL-ASDF
encapsulation of Maven artifacts.

To enable the Objectweb disassembler use

(require :abcl-contrib)
(require :objectweb)

Location:
trunk/abcl
Files:
7 added
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/abcl.asd

    r15009 r15013  
    7474                        :pathname "t/"
    7575                        :components ((:test-file "resolve-multiple-maven-dependencies")
     76                                     (:test-file "disassemble")
    7677                                     (:test-file "pathname")))))
    7778
  • trunk/abcl/contrib/abcl-introspect/abcl-introspect.asd

    r15008 r15013  
    11;;;; -*- Mode: LISP -*-
    22(defsystem abcl-introspect
    3   :author "Alan Ruttenberg"
     3  :author ("Alan Ruttenberg" "Mark Evenson")
    44  :description "Introspection on compiled function to aid source location and other debugging functions."
    55  :long-description "<urn:abcl.org/release/1.5.0/contrib/abcl-introspect#>"
    6   :version "1.0.1"
     6  :version "2.0.0"
    77  :depends-on (jss)
    88  :components ((:file "abcl-introspect")
    9          (:file "stacktrace")))
     9         (:file "stacktrace"))
     10  :in-order-to ((test-op (test-op abcl-introspect-tests))))
     11
  • trunk/abcl/src/org/armedbear/lisp/Symbol.java

    r14916 r15013  
    30853085  public static final Symbol DIRECT_SUPERCLASSES =
    30863086    PACKAGE_SYS.addExternalSymbol("DIRECT-SUPERCLASSES");
     3087  public static final Symbol __DISASSEMBLERS__ =
     3088    PACKAGE_SYS.addExternalSymbol("*DISASSEMBLERS*");
     3089  public static final Symbol CHOOSE_DISASSEMBLER =
     3090    PACKAGE_SYS.addExternalSymbol("CHOOSE-DISASSEMBLER");
    30873091  public static final Symbol _DOCUMENTATION =
    30883092    PACKAGE_SYS.addExternalSymbol("%DOCUMENTATION");
  • trunk/abcl/src/org/armedbear/lisp/disassemble.lisp

    r14960 r15013  
    3030;;; exception statement from your version.
    3131
    32 (in-package #:system)
    33 
    34 (require '#:clos)
    35 
    36 (defvar *disassembler-function* NIL)
    37 
    38 ;; default is :external, jad, which is what the abcl java code calls
     32(in-package :system)
     33(require :clos)
     34
     35(defvar *disassembler-function* nil
     36  "The currently used function for CL:DISASSEMBLE. 
     37
     38Available disassemblers are configured by pushing a strategy to SYSTEM:*DISASSEMBLERS*. 
     39
     40SYSTEM:CHOOSE-DISASSEMBLER selects a current strategy from this list .")
    3941
    4042(defvar *disassemblers*
    41   `((:objectweb . objectweb-disassemble)
    42     (:external . disassemble-class-bytes)))
     43  `((:jad . disassemble-class-bytes))
     44  "Methods of invoking CL:DISASSEMBLE consisting of a pushable list of (name function), where function takes a object to disassemble, returns the results as a string.
     45
     46The system is :jad using the venerable-but-still-works JAD.
     47")
    4348
    4449(defun choose-disassembler (&optional name)
    45   (setf *disassembler-function*
    46         (if name
    47             (or (funcall (cdr (assoc name *disassemblers*)))
    48                 (error "Can't find suitable disassembler."))
    49             (loop
    50               for (NIL . test) in *disassemblers*
    51               for result = (funcall test)
    52               when result
    53                 do (return result)
    54               finally (warn "Can't find suitable disassembler.")))))
     50  "Hook to choose invoked behavior of CL:DISASSEMBLE by using one of the methods registered in SYSTEM:*DISASSEMBLERS*.
     51
     52Optionally, prefer the strategy named NAME if one exists."
     53    (setf *disassembler-function*
     54          (if name
     55              (let ((disassembler (cdr (assoc name *disassemblers*))))
     56                (if (and disassembler
     57                         (fboundp disassembler))
     58                    disassembler
     59                    (error "Disassembler ~a doesn't appear to work." name)))
     60              (loop
     61                 :for (nil . disassembler) in *disassemblers*
     62                 :when (and disassembler
     63                            (fboundp disassembler))
     64                 :do (return disassembler)
     65                 finally (warn "Can't find suitable disassembler.")))))
    5566
    5667(eval-when (:compile-toplevel :load-toplevel :execute)
     
    8192    (read-byte-array-from-stream stream)))
    8293
    83 ;; alanr: disassemble more things
     94(defun disassemble-bytes (bytes)
     95  "Disassemble jvm code BYTES returning a string."
     96  (funcall (or *disassembler-function* (choose-disassembler))
     97           bytes))
     98
    8499(defun disassemble-function (arg)
    85   (flet ((disassemble-bytes (bytes) (funcall (or *disassembler-function* 'disassemble-class-bytes) bytes)))
    86     (let ((function (cond ((java::java-object-p arg)
    87          (cond ((java::jinstance-of-p arg "java.lang.Class")
    88           arg)
    89          ((java::jinstance-of-p arg "java.lang.reflect.Method")
    90           (java::jmethod-declaring-class arg))
    91          ))
    92         ((functionp arg)
    93          arg)
    94         ((symbolp arg)
    95          (or (macro-function arg) (symbol-function arg)))
    96         (t arg))))
    97 
    98       (when (typep function 'generic-function)
    99   (setf function (mop::funcallable-instance-function function)))
    100       ;; use isInstance instead of jinstance-of-p
    101       ;; because the latter checked java-object-p
    102       ;; which fails since its a lisp object
    103       (when (and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") function)
    104      (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") function)))
    105   (return-from disassemble-function
    106     (with-output-to-string (s)
    107       (format s "Not a compiled function: ~%")
    108       (pprint (java:jcall "getBody" function) s))))
    109       (let ((bytes (or (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.Function") function)
    110           (ignore-errors (getf (function-plist function))) 'class-bytes)
    111            (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") function)
    112           (equalp (java::jcall "getName" (java::jobject-class
    113                   (java:jcall "getClassLoader" (java::jcall "getClass" function))))
    114             "org.armedbear.lisp.FaslClassLoader")
    115           (fasl-compiled-closure-class-bytes function)))))
    116   ;; we've got bytes here then we've covered the case that the disassembler already handled
    117   ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
    118   (if bytes
    119       (disassemble-bytes bytes)
    120       (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
    121         (let ((classloader (java:jcall "getClassLoader" class)))
    122     (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
    123       (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
    124         (disassemble-bytes
    125          (java:jcall "getFunctionClassBytes" classloader class))
    126         (disassemble-bytes
    127          (read-byte-array-from-stream
    128           (java:jcall-raw
    129            "getResourceAsStream"
    130            (java:jcall-raw "getClassLoader" class)
    131            (class-resource-path class))))))))))))
     100  (let ((function (cond ((java::java-object-p arg)
     101                         (cond ((java::jinstance-of-p arg "java.lang.Class")
     102                                arg)
     103                               ((java::jinstance-of-p arg "java.lang.reflect.Method")
     104                                (java::jmethod-declaring-class arg))
     105                               ))
     106                        ((functionp arg)
     107                         arg)
     108                        ((symbolp arg)
     109                         (or (macro-function arg) (symbol-function arg)))
     110                        (t arg))))
     111    (when (typep function 'generic-function)
     112      (setf function (mop::funcallable-instance-function function)))
     113    ;; use isInstance instead of jinstance-of-p
     114    ;; because the latter checked java-object-p
     115    ;; which fails since its a lisp object
     116    (when (and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") function)
     117               (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") function)))
     118      (return-from disassemble-function
     119        (with-output-to-string (s)
     120          (format s "Not a compiled function: ~%")
     121          (pprint (java:jcall "getBody" function) s))))
     122    (let ((bytes (or (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.Function") function)
     123                          (ignore-errors (getf (function-plist function))) 'class-bytes)
     124                     (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") function)
     125                          (equalp (java::jcall "getName" (java::jobject-class
     126                                                          (java:jcall "getClassLoader" (java::jcall "getClass" function))))
     127                                  "org.armedbear.lisp.FaslClassLoader")
     128                          (fasl-compiled-closure-class-bytes function)))))
     129      ;; we've got bytes here then we've covered the case that the disassembler already handled
     130      ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
     131      (if bytes
     132          (disassemble-bytes bytes)
     133          (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
     134            (let ((classloader (java:jcall "getClassLoader" class)))
     135              (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
     136                      (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
     137                  (disassemble-bytes
     138                   (java:jcall "getFunctionClassBytes" classloader class))
     139                  (disassemble-bytes
     140                   (read-byte-array-from-stream
     141                    (java:jcall-raw
     142                     "getResourceAsStream"
     143                     (java:jcall-raw "getClassLoader" class)
     144                     (class-resource-path class)))))))))))
    132145
    133146(defparameter +propertyList+
     
    144157
    145158;; PITA. make loadedFrom public
     159;;; TODO Java9 work out a sensible story to preserve existing values if required
    146160(defun get-loaded-from (function)
    147161  (let* ((jfield (find "loadedFrom" (java:jcall "getDeclaredFields" (java:jclass "org.armedbear.lisp.Function"))
     
    172186
    173187;; closure bindings
    174 ;; (get-java-field (elt (#"get" (elt (#"getFields" (#"getClass" #'foo)) 0) #'foo) 0) "value") 
     188;; (get-java-field (elt (#"get" (elt (#"getFields" (#"getClass" #'foo)) 0) #'foo) 0) "value")
    175189
    176190(defun disassemble (arg)
     
    186200        (terpri)))))
    187201
    188 (defun objectweb-disassemble (object)
    189   (let* ((reader (java:jnew "org.objectweb.asm.ClassReader" object))
    190          (writer (java:jnew "java.io.StringWriter"))
    191          (printer (java:jnew "java.io.PrintWriter" writer))
    192          (tracer (java:jnew "org.objectweb.asm.util.TraceClassVisitor" java:+null+ printer))
    193          ;; this is to support both the 1.X and subsequent releases
    194          (flags (ignore-errors (java:jfield "org.objectweb.asm.ClassReader" "SKIP_DEBUG"))))
    195     (java:jcall-raw "accept" reader tracer (or flags java:+false+))
    196     (java:jcall "toString" writer)))
    197 
Note: See TracChangeset for help on using the changeset viewer.