From fef3f29b90260bc6045c8c8c0f93b4598d09d601 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Tue, 8 May 2001 12:32:34 +0000 Subject: [PATCH] From Tim Moore: Add more interesting annotations to disassemble output. --- compiler/disassem.lisp | 74 ++++++++++++++++++++++++++++++++--------- compiler/x86/insts.lisp | 17 ++++++++-- 2 files changed, 73 insertions(+), 18 deletions(-) diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp index a6f16bb12..50de7d921 100644 --- a/compiler/disassem.lisp +++ b/compiler/disassem.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.28 1999/08/13 16:03:52 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.29 2001/05/08 12:32:32 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -3489,17 +3489,45 @@ symbol object that we know about.") t) (values nil nil)))) +(defun get-code-constant-absolute (addr dstate) + (declare (type address addr)) + (declare (type disassem-state dstate)) + (let ((code (seg-code (dstate-segment dstate)))) + (if (null code) + (return-from get-code-constant-absolute (values nil nil))) + (let ((code-size (ash (kernel:get-header-data code) vm:word-shift))) + (system:without-gcing + (let ((code-addr (- (kernel:get-lisp-obj-address code) + vm:other-pointer-type))) + (if (or (< addr code-addr) (>= addr (+ code-addr code-size))) + (values nil nil) + (values (kernel:code-header-ref + code + (ash (- addr code-addr) (- vm:word-shift))) + t))))))) + + (defvar *assembler-routines-by-addr* nil) +(defvar *foreign-symbols-by-addr* nil) + +(defun invert-address-hash (htable &optional (addr-hash (make-hash-table))) + "Build an address-name hash-table from the name-address hash" + (maphash #'(lambda (name address) + (setf (gethash address addr-hash) name)) + htable) + addr-hash) + (defun find-assembler-routine (address) - "Returns the name of the primitive lisp assembler routine located at - ADDRESS, or NIL if there isn't one." + "Returns the name of the primitive lisp assembler routine or foreign + symbol located at ADDRESS, or NIL if there isn't one." (declare (type address address)) (when (null *assembler-routines-by-addr*) - (setf *assembler-routines-by-addr* (make-hash-table)) - (maphash #'(lambda (name address) - (setf (gethash address *assembler-routines-by-addr*) name)) - lisp::*assembler-routines*)) + (setf *assembler-routines-by-addr* + (invert-address-hash lisp::*assembler-routines*)) + (setf *assembler-routines-by-addr* + (invert-address-hash lisp::*foreign-symbols* + *assembler-routines-by-addr*))) (gethash address *assembler-routines-by-addr*)) ;;; ---------------------------------------------------------------- @@ -3583,6 +3611,20 @@ symbol object that we know about.") dstate)) const)) +(defun note-code-constant-absolute (addr dstate) + "Store a note about the lisp constant located at ADDR in the + current code-component, to be printed as an end-of-line comment after the + current instruction is disassembled." + (declare (type address addr) + (type disassem-state dstate)) + (multiple-value-bind (const valid) + (get-code-constant-absolute addr dstate) + (when valid + (note #'(lambda (stream) + (prin1-quoted-short const stream)) + dstate)) + (values const valid))) + (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate) "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL is a valid slot in a symbol, store a note describing which symbol and slot, @@ -3615,18 +3657,20 @@ symbol object that we know about.") t)) (defun maybe-note-assembler-routine (address note-address-p dstate) - "If ADDRESS is the address of a primitive assembler routine, store a note - describing which one, to be printed as an end-of-line comment after the - current instruction is disassembled. Returns non-NIL iff a note was - recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made." - (declare (type address address) - (type disassem-state dstate)) + "If ADDRESS is the address of a primitive assembler routine or + foreign symbol, store a note describing which one, to be printed as + an end-of-line comment after the current instruction is disassembled. + Returns non-NIL iff a note was recorded. If NOTE-ADDRESS-P is non-NIL, a + note of the address is also made." + (declare (type disassem-state dstate)) + (unless (typep address 'address) + (return-from maybe-note-assembler-routine nil)) (let ((name (find-assembler-routine address))) (unless (null name) (note #'(lambda (stream) (if NOTE-ADDRESS-P - (format stream "#x~8,'0x: ~s" address name) - (prin1 name stream))) + (format stream "#x~8,'0x: ~a" address name) + (princ name stream))) dstate)) name)) diff --git a/compiler/x86/insts.lisp b/compiler/x86/insts.lisp index 8a64cb981..cd5fd8259 100644 --- a/compiler/x86/insts.lisp +++ b/compiler/x86/insts.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/insts.lisp,v 1.20 2000/04/21 20:30:40 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/insts.lisp,v 1.21 2001/05/08 12:32:34 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -423,7 +423,15 @@ (unless (or firstp (minusp offset)) (write-char #\+ stream)) (if firstp - (disassem:princ16 offset stream) + (progn + (disassem:princ16 offset stream) + (or (minusp offset) + (nth-value 1 + (disassem::note-code-constant-absolute offset + dstate)) + (disassem:maybe-note-assembler-routine offset + nil + dstate))) (princ offset stream)))))) (write-char #\] stream)) @@ -1696,7 +1704,10 @@ (disassem:define-argument-type displacement :sign-extend t - :use-label #'offset-next) + :use-label #'offset-next + :printer #'(lambda (value stream dstate) + (disassem:maybe-note-assembler-routine value nil dstate) + (print-label value stream dstate))) (disassem:define-instruction-format (short-cond-jump 16) (op :field (byte 4 4)) -- GitLab