From ddfb0372fb591209c4aba8ea46f94e469e0686ca Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Fri, 23 Aug 2013 19:38:38 -0700 Subject: [PATCH] Make CL:DISASSEMBLE conforming. Also update some of the implementation details of DISASSEM:DISASSEMBLE. code/exports.lisp:: * Update packages so CL:DISASSEMBLE is not DISASSEM:DISASSEMBLE. code/misc.lisp:: * Define CL:DISASSEMBLE. compiler/fndb.lisp:: * Update defknow for disassemble. compiler/disassem.lisp:: * Print of source codes uses standard I/O syntax instead of inheriting from the environment. * Add new keyword arguments to DISASSEM:DISASSEMBLE for the base, case, and radix. These default to 16, :downcase, and *print-radix*, respectively. This means disassembly now prints out all numbers in base 16 and is in lowercase. * When printing a note for an assembler routine, we don't need to print the (hex) address if *print-base* is 16. compiler/x86/insts.lisp:: * Fix some issues when in print-mem-access. * Sometimes the absolute value of the value was printed instead of the value (displaying the wrong value). * Print out the value as an unsigned in some cases instead of signed value. * Fix print-label to print addresses as unsigned integers. This fixes the issue where things like call #x-4xxxxxxx were printed. i18n/locale/cmucl.pot:: * Update because of new or changed docstrings. --- src/code/exports.lisp | 3 +-- src/code/misc.lisp | 7 +++++++ src/compiler/disassem.lisp | 39 +++++++++++++++++++++++++++++-------- src/compiler/fndb.lisp | 4 +--- src/compiler/x86/insts.lisp | 23 +++++++++++----------- src/i18n/locale/cmucl.pot | 23 +++++++++++++++++++++- 6 files changed, 74 insertions(+), 25 deletions(-) diff --git a/src/code/exports.lisp b/src/code/exports.lisp index b2bdeabd6..9322c5d12 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1198,9 +1198,8 @@ )) (defpackage "CONDITIONS") -(intern "DISASSEMBLE" "LISP") (defpackage "DISASSEM" - (:import-from "LISP" "DISASSEMBLE") + (:shadow "DISASSEMBLE") (:export "*NOTE-COLUMN*" "*OPCODE-COLUMN-WIDTH*" "ADD-COMMENT-HOOK" "ADD-HOOK" "ADD-NOTE-HOOK" "ARG-VALUE" "CREATE-DSTATE" "DISASSEM-STATE" "DISASSEMBLE" "DISASSEMBLE-CODE-COMPONENT" diff --git a/src/code/misc.lisp b/src/code/misc.lisp index 788a912fc..907ce1c91 100644 --- a/src/code/misc.lisp +++ b/src/code/misc.lisp @@ -259,3 +259,10 @@ loaded, ed can be used to edit a file" (declare (ignorable x)) (values)) + +(defun disassemble (object) + "Disassemble the machine code associated with OBJECT, which can be a + function, a lambda expression, or a symbol with a function definition. If + it is not already compiled, the compiler is called to produce something to + disassemble." + (disassem:disassemble object)) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index a23659249..1316aa2a6 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -2964,7 +2964,7 @@ (when stream (unless at-block-begin (terpri stream)) - (let ((*print-base* 10)) + (with-standard-io-syntax (pprint-logical-block (stream nil :per-line-prefix ";;; ") (format stream "[~D] " (di:code-location-form-number loc)) @@ -3304,17 +3304,36 @@ :format-arguments (list name))))) (defun disassemble (object &key (stream *standard-output*) - (use-labels t) - (backend c:*native-backend*)) + (use-labels t) + (backend c:*native-backend*) + (base 16) + (case :downcase) + (radix *print-radix*)) "Disassemble the machine code associated with OBJECT, which can be a function, a lambda expression, or a symbol with a function definition. If it is not already compiled, the compiler is called to produce something to - disassemble." + disassemble. + + :Stream stream + The dissassembly is written to this stream. + :Use-labels + Labels are generated instead of using instruction addresses. + :Base + :Case + :Radix + The disassembler uses the specified base, case, and radix when + printing the disassembled code. The default values are 16, + :downcase, and *print-radix*, respectively." (declare (type (or function symbol cons) object) (type (or (member t) stream) stream) (type (member t nil) use-labels) - (type c::backend backend)) - (let ((fun (compiled-function-or-lose object))) + (type c::backend backend) + (type (integer 2 36) base) + (type (member :upcase :downcase :capitalize) case)) + (let ((*print-base* base) + (*print-case* case) + (*print-radix* radix) + (fun (compiled-function-or-lose object))) (if (typep fun 'kernel:byte-function) (c:disassem-byte-fun fun) ;; we can't detect closures, so be careful @@ -3748,8 +3767,12 @@ symbol object that we know about.") (find-assembler-routine address)))) (unless (null name) (note #'(lambda (stream) - (if NOTE-ADDRESS-P - (format stream "#x~8,'0x: ~a" address name) + (if note-address-p + ;; No need to print out the address in hex if the + ;; print-base is already 16. + (if (= *print-base* 16) + (format stream " ~A" name) + (format stream "#x~8,'0x: ~a" address name)) (princ name stream))) dstate)) name)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 052b4c1a2..b8645dfb2 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1156,9 +1156,7 @@ (:xref t)) (values (or pathname null) boolean boolean)) -(defknown disassemble ((or callable cons) - &key (:stream stream) (:backend backend) - (:use-labels t)) +(defknown disassemble ((or callable cons)) (values)) (defknown documentation (t symbol) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 048b9ec4d..c0f10342d 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -433,11 +433,7 @@ (write-char #\* stream) (princ scale stream)) (when (and disp (not (zerop disp))) - (when (and (or base index)) - (write-char (if (minusp disp) #\- #\+) stream)) - (let ((unsigned-offset (if (minusp disp) - (+ #x100000000 disp) - disp))) + (let ((unsigned-offset (ldb (byte vm:word-bits 0) disp))) (or (nth-value 1 (disassem::note-code-constant-absolute unsigned-offset dstate)) @@ -448,8 +444,12 @@ (when (typep offs 'disassem::offset) (or (disassem::maybe-note-nil-indexed-symbol-slot-ref offs dstate) - (disassem::maybe-note-static-function offs dstate)))))) - (princ (abs disp) stream))) + (disassem::maybe-note-static-function offs dstate))))) + (cond ((or base index) + (write-char (if (minusp disp) #\- #\+) stream) + (princ (abs disp) stream)) + (t + (princ unsigned-offset stream)))))) (write-char #\] stream)) (defun print-imm-data (value stream dstate) @@ -457,9 +457,7 @@ (princ value stream) (when (typep offset 'disassem::offset) (or (disassem::maybe-note-nil-indexed-object offset dstate) - (let ((unsigned-offset (if (and (numberp value) (minusp value)) - (+ value #x100000000) - value))) + (let ((unsigned-offset (ldb (byte vm:word-bits 0) value))) (disassem::maybe-note-assembler-routine unsigned-offset stream dstate)) (nth-value 1 (disassem::note-code-constant-absolute offset @@ -493,7 +491,10 @@ (defun print-label (value stream dstate) (declare (ignore dstate)) - (disassem:princ16 value stream)) + (princ (if (and (numberp value) (minusp value)) + (ldb (byte vm:word-bits 0) value) + value) + stream)) ;;; Returns either an integer, meaning a register, or a list of ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index ff7b7cf2d..397fa4ebd 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -5607,6 +5607,16 @@ msgid "" " loaded, ed can be used to edit a file" msgstr "" +#: src/code/misc.lisp +msgid "" +"Disassemble the machine code associated with OBJECT, which can be a\n" +" function, a lambda expression, or a symbol with a function definition. " +"If\n" +" it is not already compiled, the compiler is called to produce something " +"to\n" +" disassemble." +msgstr "" + #: src/code/extensions.lisp msgid "" "This function can be used as the default value for keyword arguments that\n" @@ -17133,7 +17143,18 @@ msgid "" "If\n" " it is not already compiled, the compiler is called to produce something " "to\n" -" disassemble." +" disassemble.\n" +"\n" +" :Stream stream\n" +" The dissassembly is written to this stream.\n" +" :Use-labels\n" +" Labels are generated instead of using instruction addresses.\n" +" :Base\n" +" :Case\n" +" :Radix\n" +" The disassembler uses the specified base, case, and radix when\n" +" printing the disassembled code. The default values are 16,\n" +" :downcase, and *print-radix*, respectively." msgstr "" #: src/compiler/disassem.lisp -- GitLab