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)
parent 0e561318
......@@ -73,6 +73,7 @@
:depends-on (package)
:pathname "t/"
:components ((:test-file "resolve-multiple-maven-dependencies")
(:test-file "disassemble")
(:test-file "pathname")))))
;;;
......
;;;; -*- Mode: LISP -*-
(defsystem abcl-introspect-tests
:author "Mark Evenson"
:long-description "<urn:abcl.org/release/1.5.0/contrib/abcl-introspect/test#>"
:version "2.0.0"
:defsystem-depends-on (prove-asdf)
:depends-on (abcl-asdf ;; our dependencies
prove)
:components ((:module tests
:pathname "t/"
:components ((:test-file "disassemble"))))
:perform (asdf:test-op (op c)
(uiop:symbol-call :prove-asdf 'run-test-system c)))
;;;; -*- 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))))
(in-package :abcl-introspect)
(defun choose-disassemble ()
(warn "Unimplemented choose dissambler."))
(defsystem objectweb
:homepage "http://asm.ow2.org"
:defsystem-depends-on (abcl-asdf)
:components
((:module maven
:components
((:mvn "org.ow2.asm/asm-all/5.2")))
(:module source
:depends-on (maven)
:pathname ""
:components
((:file "objectweb")))))
(in-package :cl-user)
(defpackage :abcl/build/jvm/tools/objectweb
(:use :cl)
(:export
#:disassemble-class-bytes))
(in-package :abcl/build/jvm/tools/objectweb)
(defun disassemble-class-bytes (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)))
(eval-when (:load-toplevel :execute)
(pushnew `(:objectweb . abcl/build/jvm/tools/objectweb::disassemble-class-bytes)
sys::*disassemblers*)
(format cl:*load-verbose* "~&; ~a ; Successfully added Objectweb disassembler.~%" *package*))
(in-package :cl-user)
(let ((disassembler (first (abcl-build:split-string
ext:*disassembler* #\Space))))
(prove:plan 1)
(prove:ok (abcl-build:introspect-path-for disassembler)
(format nil
"Testing invocation of ~a specified by EXT:*DISASSEMBLER*…" disassembler)))
;;; FIXME move dependency load into ASDF definitions
(asdf:load-system :objectweb)
(prove:plan 2)
(prove:is
(sys:choose-disassembler)
'ABCL/BUILD/JVM/TOOLS/OBJECTWEB::DISASSEMBLE-CLASS-BYTES)
(let ((output (make-string-output-stream)))
(let ((*standard-output* output))
(disassemble #'cons))
(let ((result (get-output-stream-string output)))
(prove:ok (and result
(stringp result)
(> (length result) 0))
"Invocation of Objectweb disassembler.")))
(prove:finalize)
......@@ -3084,6 +3084,10 @@ public class Symbol extends LispObject implements java.io.Serializable
PACKAGE_SYS.addExternalSymbol("DIRECT-DEFAULT-INITARGS");
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");
public static final Symbol _ENABLE_AUTOCOMPILE_ =
......
......@@ -29,29 +29,40 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
(in-package #:system)
(in-package :system)
(require :clos)
(require '#:clos)
(defvar *disassembler-function* nil
"The currently used function for CL:DISASSEMBLE.
(defvar *disassembler-function* NIL)
Available disassemblers are configured by pushing a strategy to SYSTEM:*DISASSEMBLERS*.
;; default is :external, jad, which is what the abcl java code calls
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)
(defmacro with-open ((name value) &body body)
......@@ -80,55 +91,57 @@
(class-resource-path class)))
(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+
(load-time-value
......@@ -143,6 +156,7 @@
(java::jcall "set" +propertylist+ function new))
;; 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"))
:key 'java:jfield-name :test 'equal)))
......@@ -171,7 +185,7 @@
(read-byte-array-from-stream (java:jcall "openStream" url))))
;; 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)
(print-lines-with-prefix (disassemble-function arg)))
......@@ -185,13 +199,3 @@
(write-string line)
(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)))
(in-package :cl-user)
(prove:plan 1)
(let ((output (make-string-output-stream)))
(let ((*standard-output* output))
(disassemble #'cons))
(let ((result (get-output-stream-string output)))
(prove:ok (and result
(stringp result)
(> (length result) 0))
(format nil
"Invocation of default EXT:*DISASSEMBLER* (~a)." ext:*disassembler*))))
(prove:finalize)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment