X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=86eafc689e4b3b5c316c6c2d7abaa0deee89c62b;hb=f25039178959a9b302b3399dd04a4d7ba492674d;hp=1914bdc055cced7a43ad0b664f83e2f9e48e2e03;hpb=eb53f2bf913aa34aee83b35eb2b709a2e0d40366;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1914bdc..86eafc6 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -422,8 +422,8 @@ (format stream "~A~Vt~W~%" '.align (dstate-argument-column dstate) alignment)) - (incf(dstate-next-offs dstate) - (- (align location alignment) location))) + (incf (dstate-next-offs dstate) + (- (align location alignment) location))) nil)) (defun rewind-current-segment (dstate segment) @@ -478,9 +478,10 @@ (defun pad-inst-column (stream n-bytes) (declare (type stream stream) (type text-width n-bytes)) - (dotimes (i (- *disassem-inst-column-width* (* 2 n-bytes))) - (write-char #\space stream)) - (write-char #\space stream)) + (when (> *disassem-inst-column-width* 0) + (dotimes (i (- *disassem-inst-column-width* (* 2 n-bytes))) + (write-char #\space stream)) + (write-char #\space stream))) (defun handle-bogus-instruction (stream dstate prefix-len) (let ((alignment (dstate-alignment dstate))) @@ -786,12 +787,13 @@ ;;; Print NUM instruction bytes to STREAM as hex values. (defun print-inst (num stream dstate &key (offset 0) (trailing-space t)) - (let ((sap (dstate-segment-sap dstate)) - (start-offs (+ offset (dstate-cur-offs dstate)))) - (dotimes (offs num) - (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))) - (when trailing-space - (pad-inst-column stream num)))) + (when (> *disassem-inst-column-width* 0) + (let ((sap (dstate-segment-sap dstate)) + (start-offs (+ offset (dstate-cur-offs dstate)))) + (dotimes (offs num) + (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))) + (when trailing-space + (pad-inst-column stream num))))) ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions. (defun print-bytes (num stream dstate) @@ -839,10 +841,13 @@ (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) (let ((alignment *disassem-inst-alignment-bytes*) (arg-column - (+ (or *disassem-opcode-column-width* 0) + (+ 2 *disassem-location-column-width* 1 - label-column-width))) + label-column-width + *disassem-inst-column-width* + (if (zerop *disassem-inst-column-width*) 0 1) + *disassem-opcode-column-width*))) (when (> alignment 1) (push #'alignment-hook fun-hooks)) @@ -980,110 +985,30 @@ (:copier nil)) (debug-source nil :type (or null sb!di:debug-source)) (toplevel-form-index -1 :type fixnum) - (toplevel-form nil :type list) - (form-number-mapping-table nil :type (or null (vector list))) (last-location-retrieved nil :type (or null sb!di:code-location)) (last-form-retrieved -1 :type fixnum)) -;;; OAOO note: this shares a lot of implementation with -;;; SB-DEBUG::GET-FILE-TOPLEVEL-FORM. Perhaps these should be merged -;;; somehow. -(defun get-toplevel-form (debug-source tlf-index) - (cond - ((sb!di:debug-source-namestring debug-source) - (let ((namestring (sb!di:debug-source-namestring debug-source))) - (cond ((not (probe-file namestring)) - (warn "The source file ~S no longer seems to exist." namestring) - nil) - (t - (let ((start-positions - (sb!di:debug-source-start-positions debug-source))) - (cond ((null start-positions) - (warn "There is no start positions map.") - nil) - (t - (let* ((local-tlf-index - (- tlf-index - (sb!di:debug-source-root-number - debug-source))) - (char-offset - (aref start-positions local-tlf-index))) - (with-open-file (f namestring) - (cond ((= (sb!di:debug-source-created debug-source) - (file-write-date namestring)) - (file-position f char-offset)) - (t - (warn "Source file ~S has been modified; ~@ - using form offset instead of ~ - file index." - namestring) - (let ((*read-suppress* t)) - (dotimes (i local-tlf-index) (read f))))) - (let ((*readtable* (copy-readtable))) - (set-dispatch-macro-character - #\# #\. - (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token)))) - (read f))))))))))) - ((sb!di:debug-source-form debug-source) - (sb!di:debug-source-form debug-source)) - (t (bug "Don't know how to use a DEBUG-SOURCE without ~ - a namestring or a form.")))) - -(defun cache-valid (loc cache) - (and cache - (and (eq (sb!di:code-location-debug-source loc) - (sfcache-debug-source cache)) - (eq (sb!di:code-location-toplevel-form-offset loc) - (sfcache-toplevel-form-index cache))))) - -(defun get-source-form (loc context &optional cache) - (let* ((cache-valid (cache-valid loc cache)) - (tlf-index (sb!di:code-location-toplevel-form-offset loc)) - (form-number (sb!di:code-location-form-number loc)) - (toplevel-form - (if cache-valid - (sfcache-toplevel-form cache) - (get-toplevel-form (sb!di:code-location-debug-source loc) - tlf-index))) - (mapping-table - (if cache-valid - (sfcache-form-number-mapping-table cache) - (sb!di:form-number-translations toplevel-form tlf-index)))) - (when (and (not cache-valid) cache) - (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc) - (sfcache-toplevel-form-index cache) tlf-index - (sfcache-toplevel-form cache) toplevel-form - (sfcache-form-number-mapping-table cache) mapping-table)) - (cond ((null toplevel-form) - nil) - ((>= form-number (length mapping-table)) - (warn "bogus form-number in form! The source file has probably ~@ - been changed too much to cope with.") - (when cache - ;; Disable future warnings. - (setf (sfcache-toplevel-form cache) nil)) - nil) - (t - (when cache - (setf (sfcache-last-location-retrieved cache) loc) - (setf (sfcache-last-form-retrieved cache) form-number)) - (sb!di:source-path-context toplevel-form - (aref mapping-table form-number) - context))))) - (defun get-different-source-form (loc context &optional cache) - (if (and (cache-valid loc cache) - (or (= (sb!di:code-location-form-number loc) - (sfcache-last-form-retrieved cache)) - (and (sfcache-last-location-retrieved cache) - (sb!di:code-location= - loc - (sfcache-last-location-retrieved cache))))) + (if (and cache + (eq (sb!di:code-location-debug-source loc) + (sfcache-debug-source cache)) + (eq (sb!di:code-location-toplevel-form-offset loc) + (sfcache-toplevel-form-index cache)) + (or (eql (sb!di:code-location-form-number loc) + (sfcache-last-form-retrieved cache)) + (awhen (sfcache-last-location-retrieved cache) + (sb!di:code-location= loc it)))) (values nil nil) - (values (get-source-form loc context cache) t))) + (let ((form (sb!debug::code-location-source-form loc context nil))) + (when cache + (setf (sfcache-debug-source cache) + (sb!di:code-location-debug-source loc)) + (setf (sfcache-toplevel-form-index cache) + (sb!di:code-location-toplevel-form-offset loc)) + (setf (sfcache-last-form-retrieved cache) + (sb!di:code-location-form-number loc)) + (setf (sfcache-last-location-retrieved cache) loc)) + (values form t)))) ;;;; stuff to use debugging info to augment the disassembly @@ -1303,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 @@ -1499,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))))) @@ -1525,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)) @@ -1560,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 @@ -1765,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))