Menu
▾
▴
[Sbcl-commits] master: Annotate disassembly with unboxed constant values
|
From: Paul K. <pk...@us...> - 2013-05-21 03:10:00
|
The branch "master" has been updated in SBCL:
via 044fd6468eace7c9bb1404d35b820cea413f64b3 (commit)
from ff68efbd3af2a0b718f4b185f558feb9d86b6cf2 (commit)
- Log -----------------------------------------------------------------
commit 044fd6468eace7c9bb1404d35b820cea413f64b3
Author: Paul Khuong <pv...@pv...>
Date: Mon May 20 15:02:45 2013 -0400
Annotate disassembly with unboxed constant values
* Only on x86-64, for qword-sized values.
* Patch by Douglas Katzman.
---
NEWS | 2 +
src/compiler/target-disassem.lisp | 39 ++++++++++++++++++++++-----------
src/compiler/x86-64/insts.lisp | 4 +-
src/compiler/x86-64/target-insts.lisp | 6 ++--
4 files changed, 33 insertions(+), 18 deletions(-)
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)))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|