From: Paul Khuong Date: Mon, 20 May 2013 19:02:45 +0000 (-0400) Subject: Annotate disassembly with unboxed constant values X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=044fd6468eace7c9bb1404d35b820cea413f64b3;p=sbcl.git Annotate disassembly with unboxed constant values * Only on x86-64, for qword-sized values. * Patch by Douglas Katzman. --- diff --git a/NEWS b/NEWS index 30e2320..593f801 100644 --- a/NEWS +++ b/NEWS @@ -28,6 +28,8 @@ changes relative to sbcl-1.1.7: gives less wrong answers (lp#1178038, reported by Ken Harris) * enhancement: print intermediate evaluation results for some ASSERTed expressions. (lp#789497) + * enhancement: x86-64 disassemblies are annotated with unboxed constant + values when there are references to (RIP-relative) unboxed constants. * bug fix: type derivation for LOG{AND,IOR,XOR} scales linearly instead of quadratically with the size of the input in the worst case. (lp#1096444) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 86eafc6..623b27a 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1744,22 +1744,35 @@ t) (values nil nil)))) -(defun get-code-constant-absolute (addr dstate) +(defstruct code-constant-raw value) +(def!method print-object ((self code-constant-raw) stream) + (format stream "#x~8,'0x" (code-constant-raw-value self))) + +(defun get-code-constant-absolute (addr dstate &optional width) (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 (sb!kernel:get-header-data code) sb!vm:word-shift))) - (sb!sys:without-gcing - (let ((code-addr (- (sb!kernel:get-lisp-obj-address code) - sb!vm:other-pointer-lowtag))) - (if (or (< addr code-addr) (>= addr (+ code-addr code-size))) - (values nil nil) - (values (sb!kernel:code-header-ref - code - (ash (- addr code-addr) (- sb!vm:word-shift))) - t))))))) + (sb!sys:without-gcing + (let* ((n-header-words (sb!kernel:get-header-data code)) + (n-code-words (sb!kernel:%code-code-size code)) + (header-addr (- (sb!kernel:get-lisp-obj-address code) + sb!vm:other-pointer-lowtag))) + (cond ((<= header-addr addr (+ header-addr (ash (1- n-header-words) + sb!vm:word-shift))) + (values (sb!sys:sap-ref-lispobj (sb!sys:int-sap addr) 0) t)) + ;; guess it's a non-descriptor constant from the instructions + ((and (eq width :qword) + (< n-header-words + ;; convert ADDR to header-relative Nth word + (ash (- addr header-addr) (- sb!vm:word-shift)) + (+ n-header-words n-code-words))) + (values (make-code-constant-raw + :value (sb!sys:sap-ref-64 (sb!sys:int-sap addr) 0)) + t)) + (t + (values nil nil))))))) (defvar *assembler-routines-by-addr* nil) @@ -1877,11 +1890,11 @@ ;;; 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. -(defun note-code-constant-absolute (addr dstate) +(defun note-code-constant-absolute (addr dstate &optional width) (declare (type address addr) (type disassem-state dstate)) (multiple-value-bind (const valid) - (get-code-constant-absolute addr dstate) + (get-code-constant-absolute addr dstate width) (when valid (note (lambda (stream) (prin1-quoted-short const stream)) diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 2b1f5f1..dd39f60 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/src/compiler/x86-64/insts.lisp @@ -156,7 +156,7 @@ (type sb!disassem:disassem-state dstate)) (if (typep value 'full-reg) (print-reg-with-width value width stream dstate) - (print-mem-access value (and sized-p width) stream dstate))) + (print-mem-access value width sized-p stream dstate))) ;;; Print a register or a memory reference. The width is determined by ;;; calling INST-OPERAND-SIZE. @@ -219,7 +219,7 @@ (type sb!disassem:disassem-state dstate)) (if (typep value 'xmmreg) (print-xmmreg value stream dstate) - (print-mem-access value nil stream dstate))) + (print-mem-access value nil nil stream dstate))) ;;; This prefilter is used solely for its side effects, namely to put ;;; the bits found in the REX prefix into the DSTATE for use by other diff --git a/src/compiler/x86-64/target-insts.lisp b/src/compiler/x86-64/target-insts.lisp index 916971a..8b84eba 100644 --- a/src/compiler/x86-64/target-insts.lisp +++ b/src/compiler/x86-64/target-insts.lisp @@ -22,12 +22,12 @@ ;;; symbol RIP or a full register, INDEX-REG a full register. If WIDTH ;;; is non-nil it should be one of the symbols :BYTE, :WORD, :DWORD or ;;; :QWORD and a corresponding size indicator is printed first. -(defun print-mem-access (value width stream dstate) +(defun print-mem-access (value width sized-p stream dstate) (declare (type list value) (type (member nil :byte :word :dword :qword) width) (type stream stream) (type sb!disassem:disassem-state dstate)) - (when width + (when (and sized-p width) (princ width stream) (princ '| PTR | stream)) (write-char #\[ stream) @@ -64,7 +64,7 @@ (when (plusp addr) (or (nth-value 1 (sb!disassem::note-code-constant-absolute - addr dstate)) + addr dstate width)) (sb!disassem:maybe-note-assembler-routine addr nil dstate)))))