(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)
(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)))
;;; 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)
(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))
(: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))))
\f
;;;; stuff to use debugging info to augment the disassembly
))))
(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
(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)))))
(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))
(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
;;; 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))
projects / sbcl.git / blobdiff