X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=0603947086d132d28fa77448390f333a6e0d46ed;hb=5f891793819e3cd714c443c9a0a7223b4fb13dd0;hp=805c1c65f228c8ea631c46730f5431ec974fbf99;hpb=ebee2761543b208483fe763b1d329d5d0014b892;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 805c1c6..0603947 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -280,7 +280,7 @@ (defun fun-self (fun) (declare (type compiled-function fun)) - (sb!kernel:%simple-fun-self fun)) + (sb!kernel:%simple-fun-self (sb!kernel:%fun-fun fun))) (defun fun-code (fun) (declare (type compiled-function fun)) @@ -288,17 +288,11 @@ (defun fun-next (fun) (declare (type compiled-function fun)) - (sb!kernel:%simple-fun-next fun)) + (sb!kernel:%simple-fun-next (sb!kernel:%fun-fun fun))) (defun fun-address (fun) (declare (type compiled-function fun)) - (ecase (sb!kernel:widetag-of fun) - (#.sb!vm:simple-fun-header-widetag - (- (sb!kernel:get-lisp-obj-address fun) sb!vm:fun-pointer-lowtag)) - (#.sb!vm:closure-header-widetag - (fun-address (sb!kernel:%closure-fun fun))) - (#.sb!vm:funcallable-instance-header-widetag - (fun-address (sb!kernel:funcallable-instance-fun fun))))) + (- (sb!kernel:get-lisp-obj-address (sb!kernel:%fun-fun fun)) sb!vm:fun-pointer-lowtag)) ;;; the offset of FUNCTION from the start of its code-component's ;;; instruction area @@ -428,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) @@ -477,20 +471,42 @@ (unless (= (dstate-next-offs dstate) cur-offs) (return prefix-p)))))) -(defun handle-bogus-instruction (stream dstate) +;;; Print enough spaces to fill the column used for instruction bytes, +;;; assuming that N-BYTES many instruction bytes have already been +;;; printed in it, then print an additional space as separator to the +;;; opcode column. +(defun pad-inst-column (stream n-bytes) + (declare (type stream stream) + (type text-width n-bytes)) + (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))) (unless (null stream) (multiple-value-bind (words bytes) (truncate alignment sb!vm:n-word-bytes) (when (> words 0) - (print-inst (* words sb!vm:n-word-bytes) stream dstate)) + (print-inst (* words sb!vm:n-word-bytes) stream dstate + :trailing-space nil)) (when (> bytes 0) - (print-inst bytes stream dstate))) - (print-bytes alignment stream dstate)) + (print-inst bytes stream dstate :trailing-space nil))) + (pad-inst-column stream (+ prefix-len alignment)) + (decf (dstate-cur-offs dstate) prefix-len) + (print-bytes (+ prefix-len alignment) stream dstate)) (incf (dstate-next-offs dstate) alignment))) ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE. +;;; Additionally, unless STREAM is NIL, several items are output to it: +;;; things printed from several hooks, for example labels, and instruction +;;; bytes before FUNCTION is called, notes and a newline afterwards. +;;; Instructions having an INST-PRINTER of NIL are treated as prefix +;;; instructions which makes them print on the same line as the following +;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL) +;;; before FUNCTION is called for the following instruction. (defun map-segment-instructions (function segment dstate &optional stream) (declare (type function function) (type segment segment) @@ -498,7 +514,9 @@ (type (or null stream) stream)) (let ((ispace (get-inst-space)) - (prefix-p nil)) ; just processed a prefix inst + (prefix-p nil) ; just processed a prefix inst + (prefix-len 0) ; sum of lengths of any prefix instruction(s) + (prefix-print-names nil)) ; reverse list of prefixes seen (rewind-current-segment dstate segment) @@ -506,6 +524,11 @@ (when (>= (dstate-cur-offs dstate) (seg-length (dstate-segment dstate))) ;; done! + (when (and stream (> prefix-len 0)) + (pad-inst-column stream prefix-len) + (decf (dstate-cur-offs dstate) prefix-len) + (print-bytes prefix-len stream dstate) + (incf (dstate-cur-offs dstate) prefix-len)) (return)) (setf (dstate-next-offs dstate) (dstate-cur-offs dstate)) @@ -519,52 +542,73 @@ (sb!sys:without-gcing (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) - (let ((chunk - (sap-ref-dchunk (dstate-segment-sap dstate) - (dstate-cur-offs dstate) - (dstate-byte-order dstate)))) - (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) - (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (setf prefix-p fun-prefix-p) + (let* ((chunk + (sap-ref-dchunk (dstate-segment-sap dstate) + (dstate-cur-offs dstate) + (dstate-byte-order dstate))) + (fun-prefix-p (call-fun-hooks chunk stream dstate))) + (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) + (setf prefix-p fun-prefix-p) (let ((inst (find-inst chunk ispace))) (cond ((null inst) - (handle-bogus-instruction stream dstate)) + (handle-bogus-instruction stream dstate prefix-len) + (setf prefix-p nil)) (t - (setf (dstate-inst-properties dstate) nil) (setf (dstate-next-offs dstate) (+ (dstate-cur-offs dstate) (inst-length inst))) - (let ((orig-next (dstate-next-offs dstate))) - (print-inst (inst-length inst) stream dstate :trailing-space nil) - (let ((prefilter (inst-prefilter inst)) - (control (inst-control inst))) - (when prefilter - (funcall prefilter chunk dstate)) - - ;; print any instruction bytes recognized by the prefilter which calls read-suffix - ;; and updates next-offs - (when stream - (let ((suffix-len (- (dstate-next-offs dstate) orig-next))) - (when (plusp suffix-len) - (print-inst suffix-len stream dstate :offset (inst-length inst) :trailing-space nil)) - (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len)))) - (write-char #\space stream))) - (write-char #\space stream)) - - (funcall function chunk inst) - - (setf prefix-p (null (inst-printer inst))) - - (when control - (funcall control chunk inst stream dstate)) - )))))))))) + (let ((orig-next (dstate-next-offs dstate)) + (prefilter (inst-prefilter inst)) + (control (inst-control inst))) + (print-inst (inst-length inst) stream dstate + :trailing-space nil) + (when prefilter + (funcall prefilter chunk dstate)) + + (setf prefix-p (null (inst-printer inst))) + + (when stream + ;; Print any instruction bytes recognized by + ;; the prefilter which calls read-suffix and + ;; updates next-offs. + (let ((suffix-len (- (dstate-next-offs dstate) + orig-next))) + (when (plusp suffix-len) + (print-inst suffix-len stream dstate + :offset (inst-length inst) + :trailing-space nil)) + ;; Keep track of the number of bytes + ;; printed so far. + (incf prefix-len (+ (inst-length inst) + suffix-len))) + (if prefix-p + (let ((name (inst-print-name inst))) + (when name + (push name prefix-print-names))) + (progn + ;; PREFIX-LEN includes the length of the + ;; current (non-prefix) instruction here. + (pad-inst-column stream prefix-len) + (dolist (name (reverse prefix-print-names)) + (princ name stream) + (write-char #\space stream))))) + + (funcall function chunk inst) + + (when control + (funcall control chunk inst stream dstate)))))))))) (setf (dstate-cur-offs dstate) (dstate-next-offs dstate)) - (unless (null stream) + (when stream (unless prefix-p + (setf prefix-len 0 + prefix-print-names nil) (print-notes-and-newline stream dstate)) - (setf (dstate-output-state dstate) nil))))) + (setf (dstate-output-state dstate) nil)) + (unless prefix-p + (setf (dstate-inst-properties dstate) nil))))) + ;;; Make an initial non-printing disassembly pass through DSTATE, ;;; noting any addresses that are referenced by instructions in this @@ -743,14 +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 - (dotimes (i (- *disassem-inst-column-width* (* 2 num))) - (write-char #\space stream)) - (write-char #\space stream)))) + (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) @@ -796,20 +839,20 @@ ;;; Make a disassembler-state object. (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) - (let ((sap - (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) - (alignment *disassem-inst-alignment-bytes*) + (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)) - (%make-dstate :segment-sap sap - :fun-hooks fun-hooks + (%make-dstate :fun-hooks fun-hooks :argument-column arg-column :alignment alignment :byte-order sb!c:*backend-byte-order*))) @@ -828,8 +871,8 @@ ;;; A SAP-MAKER is a no-argument function that returns a SAP. +;; FIXME: Are the objects we are taking saps for always pinned? #!-sb-fluid (declaim (inline sap-maker)) - (defun sap-maker (function input offset) (declare (optimize (speed 3)) (type (function (t) sb!sys:system-area-pointer) function) @@ -942,106 +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)) -(defun get-toplevel-form (debug-source tlf-index) - (let ((name (sb!di:debug-source-name debug-source))) - (ecase (sb!di:debug-source-from debug-source) - (:file - (cond ((not (probe-file name)) - (warn "The source file ~S no longer seems to exist." name) - 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 name) - (cond ((= (sb!di:debug-source-created debug-source) - (file-write-date name)) - (file-position f char-offset)) - (t - (warn "Source file ~S has been modified; ~@ - using form offset instead of ~ - file index." - name) - (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)) - )))))))) - (:lisp - (aref name tlf-index))))) - -(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 @@ -1261,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 @@ -1394,23 +1365,6 @@ (make-code-segment code start-offset length) (nreverse segments)))) -;;; Return two values: the amount by which the last instruction in the -;;; segment goes past the end of the segment, and the offset of the -;;; end of the segment from the beginning of that instruction. If all -;;; instructions fit perfectly, return 0 and 0. -(defun segment-overflow (segment dstate) - (declare (type segment segment) - (type disassem-state dstate)) - (let ((seglen (seg-length segment)) - (last-start 0)) - (map-segment-instructions (lambda (chunk inst) - (declare (ignore chunk inst)) - (setf last-start (dstate-cur-offs dstate))) - segment - dstate) - (values (- (dstate-cur-offs dstate) seglen) - (- seglen last-start)))) - ;;; Compute labels for all the memory segments in SEGLIST and adds ;;; them to DSTATE. It's important to call this function with all the ;;; segments you're interested in, so that it can find references from @@ -1457,13 +1411,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))))) @@ -1483,23 +1439,16 @@ (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-designator-for-disassemble-p (thing) +(defun valid-extended-function-designators-for-disassemble-p (thing) (cond ((legal-fun-name-p thing) - (compiled-fun-or-lose (fdefinition thing) thing)) + (compiled-funs-or-lose (fdefinition thing) thing)) #!+sb-eval ((sb!eval:interpreted-function-p thing) (compile nil thing)) + ((typep thing 'sb!pcl::%method-function) + ;; in a %METHOD-FUNCTION, the user code is in the fast function, so + ;; we to disassemble both. + (list thing (sb!pcl::%method-function-fast-function thing))) ((functionp thing) thing) ((and (listp thing) @@ -1507,14 +1456,14 @@ (compile nil thing)) (t nil))) -(defun compiled-fun-or-lose (thing &optional (name thing)) - (let ((fun (valid-extended-function-designator-for-disassemble-p thing))) - (if fun - fun +(defun compiled-funs-or-lose (thing &optional (name thing)) + (let ((funs (valid-extended-function-designators-for-disassemble-p thing))) + (if funs + funs (error 'simple-type-error :datum thing - :expected-type '(satisfies valid-extended-function-designator-for-disassemble-p) - :format-control "can't make a compiled function from ~S" + :expected-type '(satisfies valid-extended-function-designators-for-disassemble-p) + :format-control "Can't make a compiled function from ~S" :format-arguments (list name))))) (defun disassemble (object &key @@ -1528,11 +1477,16 @@ (declare (type (or function symbol cons) object) (type (or (member t) stream) stream) (type (member t nil) use-labels)) - (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") - (disassemble-fun (compiled-fun-or-lose object) - :stream stream - :use-labels use-labels) - nil)) + (flet ((disassemble1 (fun) + (format stream "~&; disassembly for ~S" (sb!kernel:%fun-name fun)) + (disassemble-fun fun + :stream stream + :use-labels use-labels))) + (let ((funs (compiled-funs-or-lose object))) + (if (listp funs) + (dolist (fun funs) (disassemble1 fun)) + (disassemble1 funs)))) + nil) ;;; Disassembles the given area of memory starting at ADDRESS and ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory @@ -1589,123 +1543,21 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -;;; code for making useful segments from arbitrary lists of code-blocks - -;;; the maximum size of an instruction. Note that this includes -;;; pseudo-instructions like error traps with their associated -;;; operands, so it should be big enough to include them, i.e. it's -;;; not just 4 on a risc machine! -(defconstant max-instruction-size 16) - -(defun add-block-segments (seg-code-block - seglist - location - connecting-vec - dstate) - (declare (type list seglist) - (type integer location) - (type (or null (vector (unsigned-byte 8))) connecting-vec) - (type disassem-state dstate)) - (flet ((addit (seg overflow) - (let ((length (+ (seg-length seg) overflow))) - (when (> length 0) - (setf (seg-length seg) length) - (incf location length) - (push seg seglist))))) - (let ((connecting-overflow 0) - (amount (length seg-code-block))) - (when connecting-vec - ;; Tack on some of the new block to the old overflow vector. - (let* ((beginning-of-block-amount - (if seg-code-block (min max-instruction-size amount) 0)) - (connecting-vec - (if seg-code-block - (concatenate - '(vector (unsigned-byte 8)) - connecting-vec - (subseq seg-code-block 0 beginning-of-block-amount)) - connecting-vec))) - (when (and (< (length connecting-vec) max-instruction-size) - (not (null seg-code-block))) - (return-from add-block-segments - ;; We want connecting vectors to be large enough to hold - ;; any instruction, and since the current seg-code-block - ;; wasn't large enough to do this (and is now entirely - ;; on the end of the overflow-vector), just save it for - ;; next time. - (values seglist location connecting-vec))) - (when (> (length connecting-vec) 0) - (let ((seg - (make-vector-segment connecting-vec - 0 - (- (length connecting-vec) - beginning-of-block-amount) - :virtual-location location))) - (setf connecting-overflow (segment-overflow seg dstate)) - (addit seg connecting-overflow))))) - (cond ((null seg-code-block) - ;; nothing more to add - (values seglist location nil)) - ((< (- amount connecting-overflow) max-instruction-size) - ;; We can't create a segment with the minimum size - ;; required for an instruction, so just keep on accumulating - ;; in the overflow vector for the time-being. - (values seglist - location - (subseq seg-code-block connecting-overflow amount))) - (t - ;; Put as much as we can into a new segment, and the rest - ;; into the overflow-vector. - (let* ((initial-length - (- amount connecting-overflow max-instruction-size)) - (seg - (make-vector-segment seg-code-block - connecting-overflow - initial-length - :virtual-location location)) - (overflow - (segment-overflow seg dstate))) - (addit seg overflow) - (values seglist - location - (subseq seg-code-block - (+ connecting-overflow (seg-length seg)) - amount)))))))) - ;;;; code to disassemble assembler segments -(defun assem-segment-to-disassem-segments (assem-segment dstate) - (declare (type sb!assem:segment assem-segment) - (type disassem-state dstate)) - (let ((location 0) - (disassem-segments nil) - (connecting-vec nil)) - (sb!assem:on-segment-contents-vectorly - assem-segment - (lambda (seg-code-block) - (multiple-value-setq (disassem-segments location connecting-vec) - (add-block-segments seg-code-block - disassem-segments - location - connecting-vec - dstate)))) - (when connecting-vec - (setf disassem-segments - (add-block-segments nil - disassem-segments - location - connecting-vec - dstate))) - (sort disassem-segments #'< :key #'seg-virtual-location))) +(defun assem-segment-to-disassem-segment (assem-segment) + (declare (type sb!assem:segment assem-segment)) + (let ((contents (sb!assem:segment-contents-as-vector assem-segment))) + (make-vector-segment contents 0 (length contents) :virtual-location 0))) ;;; Disassemble the machine code instructions associated with ;;; ASSEM-SEGMENT (of type assem:segment). (defun disassemble-assem-segment (assem-segment stream) (declare (type sb!assem:segment assem-segment) (type stream stream)) - (let* ((dstate (make-dstate)) - (disassem-segments - (assem-segment-to-disassem-segments assem-segment dstate))) + (let ((dstate (make-dstate)) + (disassem-segments + (list (assem-segment-to-disassem-segment assem-segment)))) (label-segments disassem-segments dstate) (disassemble-segments disassem-segments stream dstate))) @@ -1714,10 +1566,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)) @@ -1773,22 +1625,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) @@ -1808,9 +1673,20 @@ (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* (invert-address-hash sb!fasl:*assembler-routines*)) + #!-sb-dynamic-core (setf *assembler-routines-by-addr* (invert-address-hash sb!sys:*static-foreign-symbols* - *assembler-routines-by-addr*))) + *assembler-routines-by-addr*)) + (loop for static in sb!vm:*static-funs* + for address = (+ sb!vm::nil-value + (sb!vm::static-fun-offset static)) + do + (setf (gethash address *assembler-routines-by-addr*) + static)) + ;; Not really a routine, but it uses the similar logic for annotations + #!+sb-safepoint + (setf (gethash sb!vm::gc-safepoint-page-addr *assembler-routines-by-addr*) + "safepoint")) (gethash address *assembler-routines-by-addr*)) ;;;; some handy function for machine-dependent code to use... @@ -1906,11 +1782,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)) @@ -2018,7 +1894,7 @@ (car (svref sb!c:*backend-internal-errors* errnum))) (defun get-sc-name (sc-offs) - (sb!c::location-print-name + (sb!c:location-print-name ;; FIXME: This seems like an awful lot of computation just to get a name. ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons ;; up a new object?