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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))