(in-package "SB!DISASSEM")
-(file-comment
- "$Header$")
-
;;;; FIXME: A lot of stupid package prefixes would go away if DISASSEM
;;;; would use the SB!DI package. And some more would go away if it would
;;;; use SB!SYS (in order to get to the SAP-FOO operators).
(when (null plen)
(setf plen location-column-width)
- (set-location-printing-range dstate
- (seg-virtual-location (dstate-segment dstate))
- (seg-length (dstate-segment dstate))))
+ (let ((seg (dstate-segment dstate)))
+ (set-location-printing-range dstate
+ (seg-virtual-location seg)
+ (seg-length seg))))
(when (eq (dstate-output-state dstate) :beginning)
(setf plen location-column-width))
(fresh-line stream)
+ (setf location-column-width (+ 2 location-column-width))
+ (princ "; " stream)
+
;; print the location
;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
;; usually avoids any consing]
(with-print-restrictions
(dolist (note (dstate-notes dstate))
(format stream "~Vt; " *disassem-note-column*)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
(etypecase note
(string
(write-string note stream))
(function
- (funcall note stream)))
+ (funcall note stream))))
(terpri stream))
(fresh-line stream)
(setf (dstate-notes dstate) nil)))
(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 "; ")
(let ((fun (compiled-function-or-lose object)))
(if (typep fun 'sb!kernel:byte-function)
(sb!c:disassem-byte-fun fun)
(disassemble-function (fun-self fun)
:stream stream
:use-labels use-labels)))
- (values))
+ (values)))
(defun disassemble-memory (address
length
\f
;;; routines to find things in the Lisp environment
-(defconstant groked-symbol-slots
+;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-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))
#'<
- :key #'car)
- #!+sb-doc
- "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
-symbol object that we know about.")
+ :key #'car))
+;;; Given ADDRESS, try and figure out if which slot of which symbol is
+;;; being referred to. Of course we can just give up, so it's not a
+;;; big deal... Return two values, the symbol and the name of the
+;;; access function of the slot.
(defun grok-symbol-slot-ref (address)
- #!+sb-doc
- "Given ADDRESS, try and figure out if which slot of which symbol is being
- refered to. Of course we can just give up, so it's not a big deal...
- Returns two values, the symbol and the name of the access function of the
- slot."
(declare (type address address))
(if (not (aligned-p address sb!vm:word-bytes))
(values nil nil)
- (do ((slots-tail groked-symbol-slots (cdr slots-tail)))
+ (do ((slots-tail *grokked-symbol-slots* (cdr slots-tail)))
((null slots-tail)
(values nil nil))
(let* ((field (car slots-tail))
(defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil))
+;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
+;;; which symbol is being referred to. Of course we can just give up,
+;;; so it's not a big deal... Return two values, the symbol and the
+;;; access function.
(defun grok-nil-indexed-symbol-slot-ref (byte-offset)
- #!+sb-doc
- "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
- symbol is being refered to. Of course we can just give up, so it's not a big
- deal... Returns two values, the symbol and the access function."
(declare (type offset byte-offset))
(grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset)))
+;;; Return the Lisp object located BYTE-OFFSET from NIL.
(defun get-nil-indexed-object (byte-offset)
- #!+sb-doc
- "Returns the lisp object located BYTE-OFFSET from NIL."
(declare (type offset byte-offset))
(sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset)))
+;;; Return two values; the Lisp object located at BYTE-OFFSET in the
+;;; constant area of the code-object in the current segment and T, or
+;;; NIL and NIL if there is no code-object in the current segment.
(defun get-code-constant (byte-offset dstate)
#!+sb-doc
- "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
- area of the code-object in the current segment and T, or NIL and NIL if
- there is no code-object in the current segment."
(declare (type offset byte-offset)
(type disassem-state dstate))
(let ((code (seg-code (dstate-segment dstate))))
(defvar *assembler-routines-by-addr* nil)
+;;; Return the name of the primitive Lisp assembler routine located at
+;;; ADDRESS, or NIL if there isn't one.
(defun find-assembler-routine (address)
- #!+sb-doc
- "Returns the name of the primitive lisp assembler routine located at
- ADDRESS, or NIL if there isn't one."
(declare (type address address))
(when (null *assembler-routines-by-addr*)
(setf *assembler-routines-by-addr* (make-hash-table))
projects / sbcl.git / blobdiff