From a013ec10932b01cded996713579f211586250f7c Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Thu, 19 Dec 2013 20:15:57 -0800 Subject: [PATCH] Make all top-level disassembly functions accept base, case, and radix options just like for DISASSEM:DISASSEMBLE. * DISASSEMBLE-SEGMENTS actually implements the base, case and radix options. * DISASSEMBLE doesn't implement the options but calls DISASSEMBLE-SEGMENTS with the appropriate args. * DISASSEMBLE-FUNCTION, DISASSEMBLE-MEMORY, and DISASSEMBLE-CODE-COMPONENT accepts the new keyword args. * Update the docstrings to indicate the new keyword args. --- src/compiler/disassem.lisp | 89 ++++++++++++++++++++++++++------------ 1 file changed, 61 insertions(+), 28 deletions(-) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 762b77b22..cb04a003b 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -3232,12 +3232,17 @@ dstate stream))) -(defun disassemble-segments (segments stream dstate) +(defun disassemble-segments (segments stream dstate &key + (base 16) + (case :downcase) + (radix *print-radix*)) "Disassemble the machine code instructions in each memory segment in SEGMENTS in turn to STREAM." (declare (type list segments) (type stream stream) - (type disassem-state dstate)) + (type disassem-state dstate) + (type (integer 2 36) base) + (type (member :upcase :downcase :capitalize) case)) (unless (null segments) (let ((first (car segments)) (last (car (last segments)))) @@ -3257,15 +3262,21 @@ ;; Initialize these to a sane value, just in case. (setf vm::*note-addis-inst* nil) (setf vm::*pseudo-atomic-set* nil)) - (dolist (seg segments) - (disassemble-segment seg stream dstate))))) + (let ((*print-base* base) + (*print-case* case) + (*print-radix* radix)) + (dolist (seg segments) + (disassemble-segment seg stream dstate)))))) ;;; ---------------------------------------------------------------- ;;; top-level functions (defun disassemble-function (function &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 instructions for FUNCTION." (declare (type compiled-function function) (type stream stream) @@ -3275,7 +3286,8 @@ (segments (get-function-segments function))) (when use-labels (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) + (disassemble-segments segments stream dstate + :base base :case case :radix radix))) (defun compile-function-lambda-expr (function) (declare (type function function)) @@ -3328,33 +3340,49 @@ (declare (type (or function symbol cons) object) (type (or (member t) stream) stream) (type (member t nil) use-labels) - (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))) + (type c::backend backend)) + (let ((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 (disassemble-function (fun-self fun) :stream stream :use-labels use-labels - :backend backend))) + :backend backend + :base base + :case case + :radix radix))) (values)) (defun disassemble-memory (address length &key - (stream *standard-output*) - code-component - (use-labels t) - (backend c:*backend*)) - "Disassembles the given area of memory starting at ADDRESS and LENGTH long. - Note that if CODE-COMPONENT is NIL and this memory could move during a GC, - you'd better disable it around the call to this function." - (declare (type (or address system:system-area-pointer) address) + (stream *standard-output*) + code-component + (use-labels t) + (backend c:*backend*) + (base 16) + (case :downcase) + (radix *print-radix*)) + "Disassembles the given area of memory starting at ADDRESS and + LENGTH (octets) long. Note that if CODE-COMPONENT is NIL and this + memory could move during a GC, you'd better disable it around the + call to this function. ADDRESS can be either an integer or a + system-area-pointer. + + :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 address + system:system-area-pointer) address) (type length length) (type stream stream) (type (or null kernel:code-component) code-component) @@ -3379,12 +3407,16 @@ (list (make-memory-segment address length))))) (when use-labels (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) + (disassemble-segments segments stream dstate + :base base :case case :radix radix))) (defun disassemble-code-component (code-component &key - (stream *standard-output*) - (use-labels t) - (backend c:*native-backend*)) + (stream *standard-output*) + (use-labels t) + (backend c:*native-backend*) + (base 16) + (case :downcase) + (radix *print-radix*)) "Disassemble the machine code instructions associated with CODE-COMPONENT (this may include multiple entry points)." (declare (type (or null kernel:code-component compiled-function) @@ -3400,7 +3432,8 @@ (segments (get-code-segments code-component))) (when use-labels (label-segments segments dstate)) - (disassemble-segments segments stream dstate))) + (disassemble-segments segments stream dstate + :base base :case case :radix radix))) ;;; ---------------------------------------------------------------- ;;; Code for making useful segments from arbitrary lists of code-blocks -- GitLab