(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)
(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)
(let ((ispace (get-inst-space))
(prefix-p nil) ; just processed a prefix inst
- (prefix-len 0)) ; length of any prefix instruction(s)
+ (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)
(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))
(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))
-
- (setf prefix-p (null (inst-printer inst)))
-
- ;; 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))
- (unless prefix-p
- (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len prefix-len))))
- (write-char #\space stream))
- (write-char #\space stream))
-
- (setf prefix-len (+ (inst-length inst) suffix-len))))
-
- (funcall function chunk 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)
+ (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)))))
+
\f
;;; Make an initial non-printing disassembly pass through DSTATE,
;;; noting any addresses that are referenced by instructions in this
;;; 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)
;;; Make a disassembler-state object.
(defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
- (let ((sap
- ;; FIXME: What is this for? This cannot be safe!
- (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*)))
(: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))))
\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
(make-code-segment code start-offset length)
(nreverse segments))))
\f
-;;; 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
(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-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)
(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
(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
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
\f
-;;; 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))))))))
-\f
;;;; 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)))
\f
;;; 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))
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)
(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*))
\f
;;;; some handy function for machine-dependent code to use...
;;; 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))
(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?
projects / sbcl.git / blobdiff