Changeset 15013

Timestamp:

05/23/17 11:00:13 (6 years ago)

Author:

Mark Evenson

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:

• abcl.asd (modified) (1 diff)
• contrib/abcl-introspect/abcl-introspect-tests.asd (added)
• contrib/abcl-introspect/abcl-introspect.asd (modified) (1 diff)
• contrib/abcl-introspect/byte-code.lisp (added)
• contrib/abcl-introspect/objectweb.asd (added)
• contrib/abcl-introspect/objectweb.lisp (added)
• contrib/abcl-introspect/t (added)
• contrib/abcl-introspect/t/disassemble.lisp (added)
• src/org/armedbear/lisp/Symbol.java (modified) (1 diff)
• src/org/armedbear/lisp/disassemble.lisp (modified) (5 diffs)
• t/disassemble.lisp (added)

trunk/abcl/abcl.asd

@@ -74 +74 @@
                         :pathname "t/"
                         :components ((:test-file "resolve-multiple-maven-dependencies")
+                                     (:test-file "disassemble")
                                      (:test-file "pathname")))))
 

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

@@ -1 +1 @@
 ;;;; -*- Mode: LISP -*-
 (defsystem abcl-introspect
-  :author "Alan Ruttenberg"
+  :author ("Alan Ruttenberg" "Mark Evenson")
   :description "Introspection on compiled function to aid source location and other debugging functions."
   :long-description "<urn:abcl.org/release/1.5.0/contrib/abcl-introspect#>"
-  :version "1.0.1"
+  :version "2.0.0"
   :depends-on (jss)
   :components ((:file "abcl-introspect")
-         (:file "stacktrace")))
+         (:file "stacktrace"))
+  :in-order-to ((test-op (test-op abcl-introspect-tests))))
+

trunk/abcl/src/org/armedbear/lisp/Symbol.java

@@ -3085 +3085 @@
   public static final Symbol DIRECT_SUPERCLASSES =
     PACKAGE_SYS.addExternalSymbol("DIRECT-SUPERCLASSES");
+  public static final Symbol __DISASSEMBLERS__ =
+    PACKAGE_SYS.addExternalSymbol("*DISASSEMBLERS*");
+  public static final Symbol CHOOSE_DISASSEMBLER =
+    PACKAGE_SYS.addExternalSymbol("CHOOSE-DISASSEMBLER");
   public static final Symbol _DOCUMENTATION =
     PACKAGE_SYS.addExternalSymbol("%DOCUMENTATION");

trunk/abcl/src/org/armedbear/lisp/disassemble.lisp

@@ -30 +30 @@
 ;;; exception statement from your version.
 
-(in-package #:system)
-
-(require '#:clos)
-
-(defvar *disassembler-function* NIL)
-
-;; default is :external, jad, which is what the abcl java code calls
+(in-package :system)
+(require :clos)
+
+(defvar *disassembler-function* nil
+  "The currently used function for CL:DISASSEMBLE.  
+
+Available disassemblers are configured by pushing a strategy to SYSTEM:*DISASSEMBLERS*.  
+
+SYSTEM:CHOOSE-DISASSEMBLER selects a current strategy from this list .")
 
 (defvar *disassemblers*
-  `((:objectweb . objectweb-disassemble)
-    (:external . disassemble-class-bytes)))
+  `((:jad . disassemble-class-bytes))
+  "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.
+
+The system is :jad using the venerable-but-still-works JAD. 
+")
 
 (defun choose-disassembler (&optional name)
-  (setf *disassembler-function*
-        (if name
-            (or (funcall (cdr (assoc name *disassemblers*)))
-                (error "Can't find suitable disassembler."))
-            (loop
-              for (NIL . test) in *disassemblers*
-              for result = (funcall test)
-              when result
-                do (return result)
-              finally (warn "Can't find suitable disassembler.")))))
+  "Hook to choose invoked behavior of CL:DISASSEMBLE by using one of the methods registered in SYSTEM:*DISASSEMBLERS*. 
+
+Optionally, prefer the strategy named NAME if one exists."
+    (setf *disassembler-function*
+          (if name
+              (let ((disassembler (cdr (assoc name *disassemblers*))))
+                (if (and disassembler
+                         (fboundp disassembler))
+                    disassembler
+                    (error "Disassembler ~a doesn't appear to work." name)))
+              (loop
+                 :for (nil . disassembler) in *disassemblers*
+                 :when (and disassembler
+                            (fboundp disassembler))
+                 :do (return disassembler)
+                 finally (warn "Can't find suitable disassembler.")))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -81 +92 @@
     (read-byte-array-from-stream stream)))
 
-;; alanr: disassemble more things
+(defun disassemble-bytes (bytes)
+  "Disassemble jvm code BYTES returning a string."
+  (funcall (or *disassembler-function* (choose-disassembler))
+           bytes))
+
 (defun disassemble-function (arg)
-  (flet ((disassemble-bytes (bytes) (funcall (or *disassembler-function* 'disassemble-class-bytes) bytes)))
-    (let ((function (cond ((java::java-object-p arg) 
-         (cond ((java::jinstance-of-p arg "java.lang.Class")
-          arg)
-         ((java::jinstance-of-p arg "java.lang.reflect.Method")
-          (java::jmethod-declaring-class arg))
-         ))
-        ((functionp arg)
-         arg)
-        ((symbolp arg)
-         (or (macro-function arg) (symbol-function arg)))
-        (t arg))))
-
-      (when (typep function 'generic-function)
-  (setf function (mop::funcallable-instance-function function)))
-      ;; use isInstance instead of jinstance-of-p
-      ;; because the latter checked java-object-p
-      ;; which fails since its a lisp object
-      (when (and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") function)
-     (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") function)))
-  (return-from disassemble-function 
-    (with-output-to-string (s)
-      (format s "Not a compiled function: ~%")
-      (pprint (java:jcall "getBody" function) s))))
-      (let ((bytes (or (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.Function") function)
-          (ignore-errors (getf (function-plist function))) 'class-bytes)
-           (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") function)
-          (equalp (java::jcall "getName" (java::jobject-class 
-                  (java:jcall "getClassLoader" (java::jcall "getClass" function))))
-            "org.armedbear.lisp.FaslClassLoader")
-          (fasl-compiled-closure-class-bytes function)))))
-  ;; we've got bytes here then we've covered the case that the disassembler already handled
-  ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
-  (if bytes
-      (disassemble-bytes bytes)
-      (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
-        (let ((classloader (java:jcall "getClassLoader" class)))
-    (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
-      (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
-        (disassemble-bytes 
-         (java:jcall "getFunctionClassBytes" classloader class))
-        (disassemble-bytes
-         (read-byte-array-from-stream
-          (java:jcall-raw
-           "getResourceAsStream"
-           (java:jcall-raw "getClassLoader" class)
-           (class-resource-path class))))))))))))
+  (let ((function (cond ((java::java-object-p arg) 
+                         (cond ((java::jinstance-of-p arg "java.lang.Class")
+                                arg)
+                               ((java::jinstance-of-p arg "java.lang.reflect.Method")
+                                (java::jmethod-declaring-class arg))
+                               ))
+                        ((functionp arg)
+                         arg)
+                        ((symbolp arg)
+                         (or (macro-function arg) (symbol-function arg)))
+                        (t arg))))
+    (when (typep function 'generic-function)
+      (setf function (mop::funcallable-instance-function function)))
+    ;; use isInstance instead of jinstance-of-p
+    ;; because the latter checked java-object-p
+    ;; which fails since its a lisp object
+    (when (and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") function)
+               (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") function)))
+      (return-from disassemble-function 
+        (with-output-to-string (s)
+          (format s "Not a compiled function: ~%")
+          (pprint (java:jcall "getBody" function) s))))
+    (let ((bytes (or (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.Function") function)
+                          (ignore-errors (getf (function-plist function))) 'class-bytes)
+                     (and (java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") function)
+                          (equalp (java::jcall "getName" (java::jobject-class 
+                                                          (java:jcall "getClassLoader" (java::jcall "getClass" function))))
+                                  "org.armedbear.lisp.FaslClassLoader")
+                          (fasl-compiled-closure-class-bytes function)))))
+      ;; we've got bytes here then we've covered the case that the disassembler already handled
+      ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
+      (if bytes
+          (disassemble-bytes bytes)
+          (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
+            (let ((classloader (java:jcall "getClassLoader" class)))
+              (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
+                      (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
+                  (disassemble-bytes 
+                   (java:jcall "getFunctionClassBytes" classloader class))
+                  (disassemble-bytes
+                   (read-byte-array-from-stream
+                    (java:jcall-raw
+                     "getResourceAsStream"
+                     (java:jcall-raw "getClassLoader" class)
+                     (class-resource-path class)))))))))))
 
 (defparameter +propertyList+ 
@@ -144 +157 @@
 
 ;; PITA. make loadedFrom public
+;;; TODO Java9 work out a sensible story to preserve existing values if required
 (defun get-loaded-from (function)
   (let* ((jfield (find "loadedFrom" (java:jcall "getDeclaredFields" (java:jclass "org.armedbear.lisp.Function")) 
@@ -172 +186 @@
 
 ;; closure bindings
-;; (get-java-field (elt (#"get" (elt (#"getFields" (#"getClass" #'foo)) 0) #'foo) 0) "value") 
+;; (get-java-field (elt (#"get" (elt (#"getFields" (#"getClass" #'foo)) 0) #'foo) 0) "value")
 
 (defun disassemble (arg)
@@ -186 +200 @@
         (terpri)))))
 
-(defun objectweb-disassemble (object)
-  (let* ((reader (java:jnew "org.objectweb.asm.ClassReader" object))
-         (writer (java:jnew "java.io.StringWriter"))
-         (printer (java:jnew "java.io.PrintWriter" writer))
-         (tracer (java:jnew "org.objectweb.asm.util.TraceClassVisitor" java:+null+ printer))
-         ;; this is to support both the 1.X and subsequent releases
-         (flags (ignore-errors (java:jfield "org.objectweb.asm.ClassReader" "SKIP_DEBUG"))))
-    (java:jcall-raw "accept" reader tracer (or flags java:+false+))
-    (java:jcall "toString" writer)))
-