Ignore:
Timestamp:
01/11/17 21:04:41 (5 years ago)
Author:
Mark Evenson
Message:

make *disassembler-function* work

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/disassemble.lisp

    r14943 r14944  
    8181;; disassemble more things
    8282(defun disassemble-function (arg)
    83   (let ((function (cond ((java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") arg)
    84        (return-from disassemble-function "don't know how to disassemble CompiledClosure"))
    85       ((java::java-object-p arg)
    86        (cond ((java::jinstance-of-p arg "java.lang.Class")
    87         arg)
    88              ((java::jinstance-of-p arg "java.lang.reflect.Method")
    89         (java::jmethod-declaring-class arg))
    90              ;; use isInstance instead of jinstance-of-p
    91              ;; because the latter checked java-object-p
    92              ;; which fails since its a lisp object
    93              ((and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") arg)
    94              (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") arg)))
    95         (return-from disassemble-function
    96           (with-output-to-string (s)
    97             (format s "Not a compiled function: ~%")
    98             (pprint (java:jcall "getBody" arg) s))))
    99              ))
    100       ((functionp arg)
    101                          arg)
    102                         ((symbolp arg)
    103                          (or (macro-function arg) (symbol-function arg)))
    104       (t arg))))
    105     (when (typep function 'generic-function)
    106       (setf function (mop::funcallable-instance-function function)))
    107     (print function)
    108     (let ((bytes (and nil (and function (not (java::java-object-p function)) (system::function-class-bytes  function)))))
    109       ;; we've got bytes here then we've covered the case that the diassembler already handled
    110       ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
    111       (if bytes
    112     (system::disassemble-class-bytes bytes)
    113     (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
    114       (let ((classloader (java:jcall "getClassLoader" class)))
    115         (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
    116           (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
    117       (system::disassemble-class-bytes
    118        (java:jcall "getFunctionClassBytes" classloader class))
    119       (system::disassemble-class-bytes
    120        (java:jstatic "toByteArray" "com.google.common.io.ByteStreams"
    121          (java:jcall-raw
    122           "getResourceAsStream"
    123           (java:jcall-raw "getClassLoader" class)
    124           (class-resource-path class)))))))))))
     83  (flet ((disassemble-bytes (bytes) (funcall (or *disassembler-function* 'system::disassemble-class-bytes) bytes)))
     84    (let ((function (cond ((java:jcall "isInstance" (java:jclass "org.armedbear.lisp.CompiledClosure") arg)
     85         (return-from disassemble-function "don't know how to disassemble CompiledClosure"))
     86        ((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         ;; use isInstance instead of jinstance-of-p
     92         ;; because the latter checked java-object-p
     93         ;; which fails since its a lisp object
     94         ((and (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.Closure") arg)
     95               (not (java:jcall "isInstance"  (java:jclass "org.armedbear.lisp.CompiledClosure") arg)))
     96          (return-from disassemble-function
     97            (with-output-to-string (s)
     98              (format s "Not a compiled function: ~%")
     99              (pprint (java:jcall "getBody" arg) s))))
     100         ))
     101        ((functionp arg)
     102         arg)
     103        ((symbolp arg)
     104         (or (macro-function arg) (symbol-function arg)))
     105        (t arg))))
     106      (when (typep function 'generic-function)
     107  (setf function (mop::funcallable-instance-function function)))
     108      (print function)
     109      (let ((bytes (and nil (and function (not (java::java-object-p function)) (system::function-class-bytes  function)))))
     110  ;; we've got bytes here then we've covered the case that the diassembler already handled
     111  ;; If not then we've either got a primitive (in function) or we got passed a method object as arg.
     112  (if bytes
     113      (disassemble-bytes bytes)
     114      (let ((class (if (java:java-object-p function) function (java:jcall "getClass" function))))
     115        (let ((classloader (java:jcall "getClassLoader" class)))
     116    (if (or (java:jinstance-of-p classloader "org.armedbear.lisp.MemoryClassLoader")
     117      (java:jinstance-of-p classloader "org.armedbear.lisp.FaslClassLoader"))
     118        (disassemble-bytes
     119         (java:jcall "getFunctionClassBytes" classloader class))
     120        (disassemble-bytes
     121         (java:jstatic "toByteArray" "com.google.common.io.ByteStreams"
     122           (java:jcall-raw
     123            "getResourceAsStream"
     124            (java:jcall-raw "getClassLoader" class)
     125            (class-resource-path class))))))))))))
    125126
    126127(defun disassemble (arg)
    127   (write-string (disassemble-function arg) *standard-output*))
     128  (print-lines-with-prefix (disassemble-function arg)))
    128129
    129130(defun print-lines-with-prefix (string)
     
    137138
    138139(defun external-disassemble (object)
    139   (print-lines-with-prefix (disassemble-class-bytes object)))
     140  (disassemble-class-bytes object))
    140141
    141142(defun external-test ()
     
    151152         (flags (ignore-errors (java:jfield "org.objectweb.asm.ClassReader" "SKIP_DEBUG"))))
    152153    (java:jcall-raw "accept" reader tracer (or flags java:+false+))
    153     (print-lines-with-prefix (java:jcall "toString" writer))))
     154    (java:jcall "toString" writer)))
    154155
    155156(defun objectweb-test ()
Note: See TracChangeset for help on using the changeset viewer.