X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=623b27a593af6c6ee31c56792a53c0216a9881ad;hb=2378406d6eda78090dfe05e372438495aeace5e0;hp=5f053c57ce7bb8e3e36ed36ba21b3e493dc97943;hpb=77a1e282295a11dff7714bdb7ebce0bd786f6334;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 5f053c5..623b27a 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1228,11 +1228,15 @@ )))) (sb!di:no-debug-blocks () nil))))) +(defvar *disassemble-annotate* t + "Annotate DISASSEMBLE output with source code.") + (defun add-debugging-hooks (segment debug-fun &optional sfcache) (when debug-fun (setf (seg-storage-info segment) (storage-info-for-debug-fun debug-fun)) - (add-source-tracking-hooks segment debug-fun sfcache) + (when *disassemble-annotate* + (add-source-tracking-hooks segment debug-fun sfcache)) (let ((kind (sb!di:debug-fun-kind debug-fun))) (flet ((add-new-hook (n) (push (make-offs-hook @@ -1424,13 +1428,15 @@ (type stream stream) (type disassem-state dstate)) (unless (null segments) + (format stream "~&; Size: ~a bytes" + (reduce #'+ segments :key #'seg-length)) (let ((first (car segments)) (last (car (last segments)))) (set-location-printing-range dstate - (seg-virtual-location first) - (- (+ (seg-virtual-location last) - (seg-length last)) - (seg-virtual-location first))) + (seg-virtual-location first) + (- (+ (seg-virtual-location last) + (seg-length last)) + (seg-virtual-location first))) (setf (dstate-output-state dstate) :beginning) (dolist (seg segments) (disassemble-segment seg stream dstate))))) @@ -1450,17 +1456,6 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -;;; FIXME: We probably don't need this any more now that there are -;;; no interpreted functions, only compiled ones. -(defun compile-function-lambda-expr (function) - (declare (type function function)) - (multiple-value-bind (lambda closurep name) - (function-lambda-expression function) - (declare (ignore name)) - (when closurep - (error "can't compile a lexical closure")) - (compile nil lambda))) - (defun valid-extended-function-designators-for-disassemble-p (thing) (cond ((legal-fun-name-p thing) (compiled-funs-or-lose (fdefinition thing) thing)) @@ -1485,7 +1480,7 @@ (error 'simple-type-error :datum thing :expected-type '(satisfies valid-extended-function-designators-for-disassemble-p) - :format-control "can't make a compiled function from ~S" + :format-control "Can't make a compiled function from ~S" :format-arguments (list name))))) (defun disassemble (object &key @@ -1690,10 +1685,10 @@ ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots ;;; in a symbol object that we know about (defparameter *grokked-symbol-slots* - (sort `((,sb!vm:symbol-value-slot . symbol-value) - (,sb!vm:symbol-plist-slot . symbol-plist) - (,sb!vm:symbol-name-slot . symbol-name) - (,sb!vm:symbol-package-slot . symbol-package)) + (sort (copy-list `((,sb!vm:symbol-value-slot . symbol-value) + (,sb!vm:symbol-plist-slot . symbol-plist) + (,sb!vm:symbol-name-slot . symbol-name) + (,sb!vm:symbol-package-slot . symbol-package))) #'< :key #'car)) @@ -1749,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) @@ -1882,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))