Changeset 14942


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

disassemble more things

File:
1 edited

Legend:

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

    r14859 r14942  
    7979    (read-byte-array-from-stream stream)))
    8080
    81 (defun disassemble (arg)
    82   (require-type arg '(OR FUNCTION
    83                       SYMBOL
    84                       (CONS (EQL SETF) (CONS SYMBOL NULL))
    85                       (CONS (EQL LAMBDA) LIST)))
    86   (let ((function (cond ((functionp arg)
     81;; disassemble more things
     82(defun disassemble-function (arg)
     83  (let ((function (cond ((#"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 (#"isInstance"  (java:jclass "org.armedbear.lisp.Closure") arg)
     94             (not (#"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 (#"getBody" arg) s))))
     99             ))
     100      ((functionp arg)
    87101                         arg)
    88102                        ((symbolp arg)
    89                          (or (macro-function arg) (symbol-function arg))))))
     103                         (or (macro-function arg) (symbol-function arg)))
     104      (t arg))))
    90105    (when (typep function 'generic-function)
    91106      (setf function (mop::funcallable-instance-function function)))
    92     (when (functionp function)
    93       (unless (compiled-function-p function)
    94         (setf function (compile nil function)))
    95       (let ((class-bytes (or (function-class-bytes function)
    96                              (class-bytes (java:jcall-raw "getClass" function)))))
    97         (if class-bytes
    98             (let ((disassembler (or *disassembler-function*
    99                                     (choose-disassembler))))
    100               (and disassembler (funcall disassembler class-bytes)))
    101             (%format t "; Disassembly is not available.~%"))))))
     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 (#"getClass" function))))
     114      (let ((classloader (#"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       (#"getFunctionClassBytes" classloader class))
     119      (let ((path (jss::path-to-class (#"getName" class))))
     120        (let ((split (cl-user::split-at-char (#"replaceFirst" path "jar:file:" "") #\!)))
     121          (let ((jar (jss::new 'jarfile (car split))))
     122      (system::disassemble-class-bytes
     123       (#"toByteArray" 'ByteStreams
     124           (#"getInputStream" jar
     125                  (#"getJarEntry" jar (subseq (second split) 1)))))))))))))))
     126(defun disassemble (arg)
     127  (write-string (disassemble-function arg) *standard-output*))
    102128
    103129(defun print-lines-with-prefix (string)
Note: See TracChangeset for help on using the changeset viewer.