[PATCH 3/5] Add multiple disassembler selector.

From 1dbd917a36154ab22bf0ddf58b6d5b7ba50603b4 Mon Sep 17 00:00:00 2001
Which allows for different disassembler backends to be used, choosing
the "best" one available by default.
---
 src/org/armedbear/lisp/disassemble.lisp | 94 ++++++++++++++++++++++++++++-----
 1 file changed, 82 insertions(+), 12 deletions(-)
parent bf8c4b69
......@@ -33,6 +33,51 @@
(require '#:clos)
(defvar *disassembler-function* NIL)
(defvar *disassemblers*
`((:objectweb . objectweb-test)
(:external . external-test)))
(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.")))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-open ((name value) &body body)
`(let ((,name ,value))
(unwind-protect
(progn ,@body)
(java:jcall-raw "close" ,name)))))
(defun read-byte-array-from-stream (stream)
(let ((buffer (java:jnew-array (java:jclass "byte") 4096)))
(with-open (output (java:jnew "java.io.ByteArrayOutputStream"))
(loop
for length = (java:jcall "read" stream buffer)
until (eql length -1)
do (java:jcall-raw "write" output buffer 0 length))
(java:jcall-raw "flush" output)
(java:jcall-raw "toByteArray" output))))
(defun class-resource-path (class)
(format NIL "~A.class" (substitute #\/ #\. (java:jcall "getName" class))))
(defun class-bytes (class)
(with-open (stream (java:jcall-raw
"getResourceAsStream"
(java:jcall-raw "getClassLoader" class)
(class-resource-path class)))
(read-byte-array-from-stream stream)))
(defun disassemble (arg)
(require-type arg '(OR FUNCTION
SYMBOL
......@@ -47,15 +92,40 @@
(when (functionp function)
(unless (compiled-function-p function)
(setf function (compile nil function)))
(let ((class-bytes (function-class-bytes function)))
(when class-bytes
(with-input-from-string
(stream (disassemble-class-bytes class-bytes))
(loop
(let ((line (read-line stream nil)))
(unless line (return))
(write-string "; ")
(write-string line)
(terpri))))
(return-from disassemble)))
(%format t "; Disassembly is not available.~%"))))
(let ((class-bytes (or (function-class-bytes function)
(class-bytes (java:jcall-raw "getClass" function)))))
(if class-bytes
(let ((disassembler (or *disassembler-function*
(choose-disassembler))))
(and disassembler (funcall disassembler class-bytes)))
(%format t "; Disassembly is not available.~%"))))))
(defun print-lines-with-prefix (string)
(with-input-from-string (stream string)
(loop
(let ((line (read-line stream nil)))
(unless line (return))
(write-string "; ")
(write-string line)
(terpri)))))
(defun external-disassemble (object)
(print-lines-with-prefix (disassemble-class-bytes object)))
(defun external-test ()
(ignore-errors
(and (disassemble-class-bytes #'cons) #'external-disassemble)))
(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+))
(print-lines-with-prefix (java:jcall "toString" writer))))
(defun objectweb-test ()
(ignore-errors
(and (java:jclass "org.objectweb.asm.ClassReader") #'objectweb-disassemble)))
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