\f
;;;; combining instructions where one specializes another
+;;; Return non-NIL if the instruction SPECIAL is a more specific
+;;; version of GENERAL (i.e., the same instruction, but with more
+;;; constraints).
(defun inst-specializes-p (special general)
- #!+sb-doc
- "Returns non-NIL if the instruction SPECIAL is a more specific version of
- GENERAL (i.e., the same instruction, but with more constraints)."
(declare (type instruction special general))
(let ((smask (inst-mask special))
(gmask (inst-mask general)))
(dchunk-strict-superset-p smask gmask))))
;;; a bit arbitrary, but should work ok...
+;;;
+;;; Return an integer corresponding to the specificity of the
+;;; instruction INST.
(defun specializer-rank (inst)
- #!+sb-doc
- "Returns an integer corresponding to the specificity of the instruction INST."
(declare (type instruction inst))
(* (dchunk-count-bits (inst-mask inst)) 4))
+;;; Order the list of instructions INSTS with more specific (more
+;;; constant bits, or same-as argument constains) ones first. Returns
+;;; the ordered list.
(defun order-specializers (insts)
- #!+sb-doc
- "Order the list of instructions INSTS with more specific (more constant
- bits, or same-as argument constains) ones first. Returns the ordered list."
(declare (type list insts))
- (sort insts
- #'(lambda (i1 i2)
- (> (specializer-rank i1) (specializer-rank i2)))))
+ (sort insts #'> :key #'specializer-rank))
(defun specialization-error (insts)
- (error "Instructions either aren't related or conflict in some way:~% ~S"
+ (error "~@<internal disassembler error: ~2I~_Instructions either aren't related or conflict in some way: ~4I~_~S~:>"
insts))
+;;; Given a list of instructions INSTS, Sees if one of these instructions is a
+;;; more general form of all the others, in which case they are put into its
+;;; specializers list, and it is returned. Otherwise an error is signaled.
(defun try-specializing (insts)
- #!+sb-doc
- "Given a list of instructions INSTS, Sees if one of these instructions is a
- more general form of all the others, in which case they are put into its
- specializers list, and it is returned. Otherwise an error is signaled."
(declare (type list insts))
(let ((masters (copy-list insts)))
(dolist (possible-master insts)
#!-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization))
+;;; Return non-NIL if all constant-bits in INST match CHUNK.
(defun inst-matches-p (inst chunk)
- #!+sb-doc
- "Returns non-NIL if all constant-bits in INST match CHUNK."
(declare (type instruction inst)
(type dchunk chunk))
(dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
+;;; Given an instruction object, INST, and a bit-pattern, CHUNK, pick
+;;; the most specific instruction on INST's specializer list whose
+;;; constraints are met by CHUNK. If none do, then return INST.
(defun choose-inst-specialization (inst chunk)
- #!+sb-doc
- "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
- most specific instruction on INST's specializer list whose constraints are
- met by CHUNK. If none do, then INST is returned."
(declare (type instruction inst)
(type dchunk chunk))
(or (dolist (spec (inst-specializers inst) nil)
\f
;;;; searching for an instruction in instruction space
+;;; Return the instruction object within INST-SPACE corresponding to the
+;;; bit-pattern CHUNK, or NIL if there isn't one.
(defun find-inst (chunk inst-space)
- #!+sb-doc
- "Returns the instruction object within INST-SPACE corresponding to the
- bit-pattern CHUNK, or NIL if there isn't one."
(declare (type dchunk chunk)
(type (or null inst-space instruction) inst-space))
(etypecase inst-space
\f
;;;; building the instruction space
+;;; Returns an instruction-space object corresponding to the list of
+;;; instructions INSTS. If the optional parameter INITIAL-MASK is
+;;; supplied, only bits it has set are used.
(defun build-inst-space (insts &optional (initial-mask dchunk-one))
- #!+sb-doc
- "Returns an instruction-space object corresponding to the list of
- instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only
- bits it has set are used."
;; This is done by finding any set of bits that's common to
;; all instructions, building an instruction-space node that selects on those
;; bits, and recursively handle sets of instructions with a common value for
(try-specializing insts)
(make-inst-space
:valid-mask vmask
- :choices (mapcar #'(lambda (bucket)
- (make-inst-space-choice
- :subspace (build-inst-space
- (cdr bucket)
- submask)
- :common-id (car bucket)))
+ :choices (mapcar (lambda (bucket)
+ (make-inst-space-choice
+ :subspace (build-inst-space
+ (cdr bucket)
+ submask)
+ :common-id (car bucket)))
buckets))))))))))
\f
;;;; an inst-space printer for debugging purposes
dchunk-bits
(bytes-to-bits (inst-length inst))))
+;;; Print a nicely-formatted version of INST-SPACE.
(defun print-inst-space (inst-space &optional (indent 0))
- #!+sb-doc
- "Prints a nicely formatted version of INST-SPACE."
(etypecase inst-space
(null)
(instruction
indent
(ispace-valid-mask inst-space))
(map nil
- #'(lambda (choice)
- (format t "~Vt~8,'0X ==>~%"
- (+ 2 indent)
- (ischoice-common-id choice))
- (print-inst-space (ischoice-subspace choice)
- (+ 4 indent)))
+ (lambda (choice)
+ (format t "~Vt~8,'0X ==>~%"
+ (+ 2 indent)
+ (ischoice-common-id choice))
+ (print-inst-space (ischoice-subspace choice)
+ (+ 4 indent)))
(ispace-choices inst-space)))))
\f
;;;; (The actual disassembly part follows.)
#!-sb-fluid (declaim (inline words-to-bytes bytes-to-words))
(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; Convert a word-offset NUM to a byte-offset.
(defun words-to-bytes (num)
- "Converts a word-offset NUM to a byte-offset."
(declare (type offset num))
(ash num sb!vm:word-shift))
) ; EVAL-WHEN
+;;; Convert a byte-offset NUM to a word-offset.
(defun bytes-to-words (num)
- #!+sb-doc
- "Converts a byte-offset NUM to a word-offset."
(declare (type offset num))
(ash num (- sb!vm:word-shift)))
(defconstant lra-size (words-to-bytes 1))
\f
-(defstruct offs-hook
+(defstruct (offs-hook (:copier nil))
(offset 0 :type offset)
(function (required-argument) :type function)
(before-address nil :type (member t nil)))
(defstruct (segment (:conc-name seg-)
- (:constructor %make-segment))
+ (:constructor %make-segment)
+ (:copier nil))
(sap-maker (required-argument)
:type (function () sb!sys:system-area-pointer))
(length 0 :type length)
;;; information so that we can allow garbage collect during disassembly and
;;; not get tripped up by a code block being moved...
(defstruct (disassem-state (:conc-name dstate-)
- (:constructor %make-dstate))
- (cur-offs 0 :type offset) ; offset of current pos in segment
- (next-offs 0 :type offset) ; offset of next position
-
+ (:constructor %make-dstate)
+ (:copier nil))
+ ;; offset of current pos in segment
+ (cur-offs 0 :type offset)
+ ;; offset of next position
+ (next-offs 0 :type offset)
+ ;; a sap pointing to our segment
(segment-sap (required-argument) :type sb!sys:system-area-pointer)
- ; a sap pointing to our segment
- (segment nil :type (or null segment)) ; the current segment
-
- (alignment sb!vm:word-bytes :type alignment) ; what to align to in most cases
+ ;; the current segment
+ (segment nil :type (or null segment))
+ ;; what to align to in most cases
+ (alignment sb!vm:n-word-bytes :type alignment)
(byte-order :little-endian
:type (member :big-endian :little-endian))
-
- (properties nil :type list) ; for user code to hang stuff off of
+ ;; for user code to hang stuff off of
+ (properties nil :type list)
(filtered-values (make-array max-filtered-value-index)
:type filtered-value-vector)
-
- (addr-print-len nil :type ; used for prettifying printing
- (or null (integer 0 20)))
+ ;; used for prettifying printing
+ (addr-print-len nil :type (or null (integer 0 20)))
(argument-column 0 :type column)
- (output-state :beginning ; to make output look nicer
+ ;; to make output look nicer
+ (output-state :beginning
:type (member :beginning
:block-boundary
nil))
- (labels nil :type list) ; alist of (address . label-number)
- (label-hash (make-hash-table) ; same thing in a different form
- :type hash-table)
+ ;; alist of (address . label-number)
+ (labels nil :type list)
+ ;; same as LABELS slot data, but in a different form
+ (label-hash (make-hash-table) :type hash-table)
+ ;; list of function
+ (fun-hooks nil :type list)
- (fun-hooks nil :type list) ; list of function
+ ;; alist of (address . label-number), popped as it's used
+ (cur-labels nil :type list) ;
+ ;; list of offs-hook, popped as it's used
+ (cur-offs-hooks nil :type list)
- ;; these next two are popped as they are used
- (cur-labels nil :type list) ; alist of (address . label-number)
- (cur-offs-hooks nil :type list) ; list of offs-hook
+ ;; for the current location
+ (notes nil :type list)
- (notes nil :type list) ; for the current location
-
- (current-valid-locations nil ; currently active source variables
- :type (or null (vector bit))))
+ ;; currently active source variables
+ (current-valid-locations nil :type (or null (vector bit))))
(def!method print-object ((dstate disassem-state) stream)
(print-unreadable-object (dstate stream :type t)
(format stream
(dstate-cur-offs dstate)
(dstate-segment dstate))))
+;;; Return the absolute address of the current instruction in DSTATE.
(defun dstate-cur-addr (dstate)
- #!+sb-doc
- "Returns the absolute address of the current instruction in DSTATE."
(the address (+ (seg-virtual-location (dstate-segment dstate))
(dstate-cur-offs dstate))))
+;;; Return the absolute address of the next instruction in DSTATE.
(defun dstate-next-addr (dstate)
- #!+sb-doc
- "Returns the absolute address of the next instruction in DSTATE."
(the address (+ (seg-virtual-location (dstate-segment dstate))
(dstate-next-offs dstate))))
\f
(defun fun-self (fun)
(declare (type compiled-function fun))
- (sb!kernel:%function-self fun))
+ (sb!kernel:%simple-fun-self fun))
(defun fun-code (fun)
(declare (type compiled-function fun))
- (sb!kernel:function-code-header (fun-self fun)))
+ (sb!kernel:fun-code-header (fun-self fun)))
(defun fun-next (fun)
(declare (type compiled-function fun))
- (sb!kernel:%function-next fun))
+ (sb!kernel:%simple-fun-next fun))
(defun fun-address (function)
(declare (type compiled-function function))
- (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type))
+ (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-lowtag))
+;;; the offset of FUNCTION from the start of its code-component's
+;;; instruction area
(defun fun-insts-offset (function)
- #!+sb-doc
- "Offset of FUNCTION from the start of its code-component's instruction area."
(declare (type compiled-function function))
(- (fun-address function)
(sb!sys:sap-int (sb!kernel:code-instructions (fun-code function)))))
+;;; the offset of FUNCTION from the start of its code-component
(defun fun-offset (function)
- #!+sb-doc
- "Offset of FUNCTION from the start of its code-component."
(declare (type compiled-function function))
(words-to-bytes (sb!kernel:get-closure-length function)))
\f
;;;; operations on code-components (which hold the instructions for
;;;; one or more functions)
+;;; Return the length of the instruction area in CODE-COMPONENT.
(defun code-inst-area-length (code-component)
- #!+sb-doc
- "Returns the length of the instruction area in CODE-COMPONENT."
(declare (type sb!kernel:code-component code-component))
(sb!kernel:code-header-ref code-component
sb!vm:code-trace-table-offset-slot))
+;;; Return the address of the instruction area in CODE-COMPONENT.
(defun code-inst-area-address (code-component)
- #!+sb-doc
- "Returns the address of the instruction area in CODE-COMPONENT."
(declare (type sb!kernel:code-component code-component))
(sb!sys:sap-int (sb!kernel:code-instructions code-component)))
+;;; Return the first function in CODE-COMPONENT.
(defun code-first-function (code-component)
- #!+sb-doc
- "Returns the first function in CODE-COMPONENT."
(declare (type sb!kernel:code-component code-component))
(sb!kernel:code-header-ref code-component
sb!vm:code-trace-table-offset-slot))
(type disassem-state dstate))
(when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
(dstate-cur-offs dstate))
- (* 2 sb!vm:word-bytes))
+ (* 2 sb!vm:n-word-bytes))
;; Check type.
(= (sb!sys:sap-ref-8 (dstate-segment-sap dstate)
(if (eq (dstate-byte-order dstate)
(dstate-cur-offs dstate)
(+ (dstate-cur-offs dstate)
(1- lra-size))))
- sb!vm:return-pc-header-type))
+ sb!vm:return-pc-header-widetag))
(unless (null stream)
(princ '.lra stream))
(incf (dstate-next-offs dstate) lra-size))
nil)
+;;; Print the function-header (entry-point) pseudo-instruction at the
+;;; current location in DSTATE to STREAM.
(defun fun-header-hook (stream dstate)
- #!+sb-doc
- "Print the function-header (entry-point) pseudo-instruction at the current
- location in DSTATE to STREAM."
(declare (type (or null stream) stream)
(type disassem-state dstate))
(unless (null stream)
(segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
(name
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-name-slot)))
+ (+ woffs
+ sb!vm:simple-fun-name-slot)))
(args
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-arglist-slot)))
+ (+ woffs
+ sb!vm:simple-fun-arglist-slot)))
(type
(sb!kernel:code-header-ref code
- (+ woffs sb!vm:function-type-slot))))
+ (+ woffs
+ sb!vm:simple-fun-type-slot))))
(format stream ".~A ~S~:A" 'entry name args)
- (note #'(lambda (stream)
- (format stream "~:S" type)) ; use format to print NIL as ()
+ (note (lambda (stream)
+ (format stream "~:S" type)) ; use format to print NIL as ()
dstate)))
(incf (dstate-next-offs dstate)
- (words-to-bytes sb!vm:function-code-offset)))
+ (words-to-bytes sb!vm:simple-fun-code-offset)))
\f
(defun alignment-hook (chunk stream dstate)
(declare (type dchunk chunk)
(setf (dstate-segment dstate) segment)
(setf (dstate-cur-offs-hooks dstate)
(stable-sort (nreverse (copy-list (seg-hooks segment)))
- #'(lambda (oh1 oh2)
- (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
- (and (= (offs-hook-offset oh1)
- (offs-hook-offset oh2))
- (offs-hook-before-address oh1)
- (not (offs-hook-before-address oh2)))))))
+ (lambda (oh1 oh2)
+ (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
+ (and (= (offs-hook-offset oh1)
+ (offs-hook-offset oh2))
+ (offs-hook-before-address oh1)
+ (not (offs-hook-before-address oh2)))))))
(setf (dstate-cur-offs dstate) 0)
(setf (dstate-cur-labels dstate) (dstate-labels dstate)))
(let ((alignment (dstate-alignment dstate)))
(unless (null stream)
(multiple-value-bind (words bytes)
- (truncate alignment sb!vm:word-bytes)
+ (truncate alignment sb!vm:n-word-bytes)
(when (> words 0)
(print-words words stream dstate))
(when (> bytes 0)
(print-bytes bytes 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.
(defun map-segment-instructions (function segment dstate &optional stream)
- #!+sb-doc
- "Iterate through the instructions in SEGMENT, calling FUNCTION
- for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
(declare (type function function)
(type segment segment)
(type disassem-state dstate)
(print-notes-and-newline stream dstate))
(setf (dstate-output-state dstate) nil)))))
\f
+;;; Make an initial non-printing disassembly pass through DSTATE,
+;;; noting any addresses that are referenced by instructions in this
+;;; segment.
(defun add-segment-labels (segment dstate)
- #!+sb-doc
- "Make an initial non-printing disassembly pass through DSTATE, noting any
- addresses that are referenced by instructions in this segment."
;; add labels at the beginning with a label-number of nil; we'll notice
;; later and fill them in (and sort them)
(declare (type disassem-state dstate))
(let ((labels (dstate-labels dstate)))
(map-segment-instructions
- #'(lambda (chunk inst)
- (declare (type dchunk chunk) (type instruction inst))
- (let ((labeller (inst-labeller inst)))
- (when labeller
- (setf labels (funcall labeller chunk labels dstate)))))
+ (lambda (chunk inst)
+ (declare (type dchunk chunk) (type instruction inst))
+ (let ((labeller (inst-labeller inst)))
+ (when labeller
+ (setf labels (funcall labeller chunk labels dstate)))))
segment
dstate)
(setf (dstate-labels dstate) labels)
;; erase any notes that got there by accident
(setf (dstate-notes dstate) nil)))
+;;; If any labels in DSTATE have been added since the last call to
+;;; this function, give them label-numbers, enter them in the
+;;; hash-table, and make sure the label list is in sorted order.
(defun number-labels (dstate)
- #!+sb-doc
- "If any labels in DSTATE have been added since the last call to this
- function, give them label-numbers, enter them in the hash-table, and make
- sure the label list is in sorted order."
(let ((labels (dstate-labels dstate)))
(when (and labels (null (cdar labels)))
;; at least one label left un-numbered
(format nil "L~D" max)))))
(setf (dstate-labels dstate) labels))))
\f
+;;; Get the instruction-space, creating it if necessary.
(defun get-inst-space ()
- #!+sb-doc
- "Get the instruction-space, creating it if necessary."
(let ((ispace *disassem-inst-space*))
(when (null ispace)
(let ((insts nil))
- (maphash #'(lambda (name inst-flavs)
- (declare (ignore name))
- (dolist (flav inst-flavs)
- (push flav insts)))
+ (maphash (lambda (name inst-flavs)
+ (declare (ignore name))
+ (dolist (flav inst-flavs)
+ (push flav insts)))
*disassem-insts*)
(setf ispace (build-inst-space insts)))
(setf *disassem-inst-space* ispace))
(defun add-offs-note-hook (segment addr note)
(add-offs-hook segment
addr
- #'(lambda (stream dstate)
- (declare (type (or null stream) stream)
- (type disassem-state dstate))
- (when stream
- (note note dstate)))))
+ (lambda (stream dstate)
+ (declare (type (or null stream) stream)
+ (type disassem-state dstate))
+ (when stream
+ (note note dstate)))))
(defun add-offs-comment-hook (segment addr comment)
(add-offs-hook segment
addr
- #'(lambda (stream dstate)
- (declare (type (or null stream) stream)
- (ignore dstate))
- (when stream
- (write-string ";;; " stream)
- (etypecase comment
- (string
- (write-string comment stream))
- (function
- (funcall comment stream)))
- (terpri stream)))))
+ (lambda (stream dstate)
+ (declare (type (or null stream) stream)
+ (ignore dstate))
+ (when stream
+ (write-string ";;; " stream)
+ (etypecase comment
+ (string
+ (write-string comment stream))
+ (function
+ (funcall comment stream)))
+ (terpri stream)))))
(defun add-fun-hook (dstate function)
(push function (dstate-fun-hooks dstate)))
;; 4 bits per hex digit
(ceiling (integer-length (logxor from (+ from length))) 4)))
+;;; Print the current address in DSTATE to STREAM, plus any labels that
+;;; correspond to it, and leave the cursor in the instruction column.
(defun print-current-address (stream dstate)
- #!+sb-doc
- "Print the current address in DSTATE to STREAM, plus any labels that
- correspond to it, and leave the cursor in the instruction column."
(declare (type stream stream)
(type disassem-state dstate))
(let* ((location
(*print-level* 3))
,@body)))
+;;; Print a newline to STREAM, inserting any pending notes in DSTATE
+;;; as end-of-line comments. If there is more than one note, a
+;;; separate line will be used for each one.
(defun print-notes-and-newline (stream dstate)
- #!+sb-doc
- "Print a newline to STREAM, inserting any pending notes in DSTATE as
- end-of-line comments. If there is more than one note, a separate line
- will be used for each one."
(declare (type stream stream)
(type disassem-state dstate))
(with-print-restrictions
(dolist (note (dstate-notes dstate))
- (format stream "~Vt; " *disassem-note-column*)
+ (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)))
+;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions.
(defun print-bytes (num stream dstate)
- #!+sb-doc
- "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
(declare (type offset num)
(type stream stream)
(type disassem-state dstate))
(write-string ", " stream))
(format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs))))))
+;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions.
(defun print-words (num stream dstate)
- #!+sb-doc
- "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
(declare (type offset num)
(type stream stream)
(type disassem-state dstate))
(unless (zerop word-offs)
(write-string ", " stream))
(let ((word 0) (bit-shift 0))
- (dotimes (byte-offs sb!vm:word-bytes)
+ (dotimes (byte-offs sb!vm:n-word-bytes)
(let ((byte
(sb!sys:sap-ref-8
sap
(+ start-offs
- (* word-offs sb!vm:word-bytes)
+ (* word-offs sb!vm:n-word-bytes)
byte-offs))))
(setf word
(if (eq byte-order :big-endian)
- (+ (ash word sb!vm:byte-bits) byte)
+ (+ (ash word sb!vm:n-byte-bits) byte)
(+ word (ash byte bit-shift))))
- (incf bit-shift sb!vm:byte-bits)))
- (format stream "#X~V,'0X" (ash sb!vm:word-bits -2) word)))))
+ (incf bit-shift sb!vm:n-byte-bits)))
+ (format stream "#X~V,'0X" (ash sb!vm:n-word-bits -2) word)))))
\f
(defvar *default-dstate-hooks* (list #'lra-hook))
+;;; Make a disassembler-state object.
(defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
- #!+sb-doc
- "Make a disassembler-state object."
(let ((sap
(sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
(alignment *disassem-inst-alignment-bytes*)
(type offset offset))
(let ((old-sap (sb!sys:sap+ (funcall function input) offset)))
(declare (type sb!sys:system-area-pointer old-sap))
- #'(lambda ()
- (let ((new-addr
- (+ (sb!sys:sap-int (funcall function input)) offset)))
- ;; Saving the sap like this avoids consing except when the sap
- ;; changes (because the sap-int, arith, etc., get inlined).
- (declare (type address new-addr))
- (if (= (sb!sys:sap-int old-sap) new-addr)
- old-sap
- (setf old-sap (sb!sys:int-sap new-addr)))))))
+ (lambda ()
+ (let ((new-addr
+ (+ (sb!sys:sap-int (funcall function input)) offset)))
+ ;; Saving the sap like this avoids consing except when the sap
+ ;; changes (because the sap-int, arith, etc., get inlined).
+ (declare (type address new-addr))
+ (if (= (sb!sys:sap-int old-sap) new-addr)
+ old-sap
+ (setf old-sap (sb!sys:int-sap new-addr)))))))
(defun vector-sap-maker (vector offset)
(declare (optimize (speed 3))
(declare (optimize (speed 3))
(type address address))
(let ((sap (sb!sys:int-sap address)))
- #'(lambda () sap)))
+ (lambda () sap)))
\f
+;;; Return a memory segment located at the system-area-pointer returned by
+;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
+;;;
+;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
+;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a
+;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
+;;; objects).
(defun make-segment (sap-maker length
&key
code virtual-location
- debug-function source-form-cache
+ debug-fun source-form-cache
hooks)
- #!+sb-doc
- "Return a memory segment located at the system-area-pointer returned by
- SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
- Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
- the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
- object), and :HOOKS (a list of offs-hook objects)."
(declare (type (function () sb!sys:system-area-pointer) sap-maker)
(type length length)
(type (or null address) virtual-location)
- (type (or null sb!di:debug-function) debug-function)
+ (type (or null sb!di:debug-fun) debug-fun)
(type (or null source-form-cache) source-form-cache))
(let* ((segment
(%make-segment
(sb!sys:sap-int (funcall sap-maker)))
:hooks hooks
:code code)))
- (add-debugging-hooks segment debug-function source-form-cache)
+ (add-debugging-hooks segment debug-fun source-form-cache)
(add-fun-header-hooks segment)
segment))
(defun print-fun-headers (function)
(declare (type compiled-function function))
(let* ((self (fun-self function))
- (code (sb!kernel:function-code-header self)))
+ (code (sb!kernel:fun-code-header self)))
(format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%"
code
(sb!kernel:code-header-ref code
fun
fun-offset
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-name-slot))
+ code (+ fun-offset sb!vm:simple-fun-name-slot))
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-arglist-slot))
+ code (+ fun-offset sb!vm:simple-fun-arglist-slot))
(sb!kernel:code-header-ref
- code (+ fun-offset sb!vm:function-type-slot)))))))
+ code (+ fun-offset sb!vm:simple-fun-type-slot)))))))
\f
;;; getting at the source code...
-(defstruct (source-form-cache (:conc-name sfcache-))
+(defstruct (source-form-cache (:conc-name sfcache-)
+ (:copier nil))
(debug-source nil :type (or null sb!di:debug-source))
(top-level-form-index -1 :type fixnum)
(top-level-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)
- )
+ (last-form-retrieved -1 :type fixnum))
(defun get-top-level-form (debug-source tlf-index)
(let ((name (sb!di:debug-source-name debug-source)))
(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))))
+ (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
\f
;;;; stuff to use debugging-info to augment the disassembly
-(defun code-function-map (code)
+(defun code-fun-map (code)
(declare (type sb!kernel:code-component code))
- (sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code)))
+ (sb!di::get-debug-info-fun-map (sb!kernel:%code-debug-info code)))
-(defstruct location-group
- (locations #() :type (vector (or list fixnum)))
- )
+(defstruct (location-group (:copier nil))
+ (locations #() :type (vector (or list fixnum))))
-(defstruct storage-info
+(defstruct (storage-info (:copier nil))
(groups nil :type list) ; alist of (name . location-group)
(debug-vars #() :type vector))
+;;; Return the vector of DEBUG-VARs currently associated with DSTATE.
(defun dstate-debug-vars (dstate)
- #!+sb-doc
- "Return the vector of DEBUG-VARs currently associated with DSTATE."
(declare (type disassem-state dstate))
(storage-info-debug-vars (seg-storage-info (dstate-segment dstate))))
+;;; Given the OFFSET of a location within the location-group called
+;;; LG-NAME, see whether there's a current mapping to a source
+;;; variable in DSTATE, and if so, return the offset of that variable
+;;; in the current debug-var vector.
(defun find-valid-storage-location (offset lg-name dstate)
- #!+sb-doc
- "Given the OFFSET of a location within the location-group called LG-NAME,
- see whether there's a current mapping to a source variable in DSTATE, and
- if so, return the offset of that variable in the current debug-var vector."
(declare (type offset offset)
(type symbol lg-name)
(type disassem-state dstate))
(zerop (bit currently-valid used-by)))
used-by))
(list
- (some #'(lambda (num)
- (and (not
- (zerop
- (bit currently-valid num)))
- num))
+ (some (lambda (num)
+ (and (not
+ (zerop
+ (bit currently-valid num)))
+ num))
used-by)))))
(and debug-var-num
(progn
debug-var-num))
))))))))
+;;; Return a new vector which has the same contents as the old one
+;;; VEC, plus new cells (for a total size of NEW-LEN). The additional
+;;; elements are initialized to INITIAL-ELEMENT.
(defun grow-vector (vec new-len &optional initial-element)
- #!+sb-doc
- "Return a new vector which has the same contents as the old one VEC, plus
- new cells (for a total size of NEW-LEN). The additional elements are
- initialized to INITIAL-ELEMENT."
(declare (type vector vec)
(type fixnum new-len))
(let ((new
(setf (aref new i) (aref vec i)))
new))
-(defun storage-info-for-debug-function (debug-function)
- #!+sb-doc
- "Returns a STORAGE-INFO struction describing the object-to-source
- variable mappings from DEBUG-FUNCTION."
- (declare (type sb!di:debug-function debug-function))
+;;; Return a STORAGE-INFO struction describing the object-to-source
+;;; variable mappings from DEBUG-FUN.
+(defun storage-info-for-debug-fun (debug-fun)
+ (declare (type sb!di:debug-fun debug-fun))
(let ((sc-vec sb!c::*backend-sc-numbers*)
(groups nil)
- (debug-vars (sb!di::debug-function-debug-vars
- debug-function)))
+ (debug-vars (sb!di::debug-fun-debug-vars
+ debug-fun)))
(and debug-vars
(dotimes (debug-var-offset
(length debug-vars)
)))))))
)))
-(defun source-available-p (debug-function)
+(defun source-available-p (debug-fun)
(handler-case
- (sb!di:do-debug-function-blocks (block debug-function)
+ (sb!di:do-debug-fun-blocks (block debug-fun)
(declare (ignore block))
(return t))
(sb!di:no-debug-blocks () nil)))
(setf (dstate-output-state dstate)
:block-boundary))))
-(defun add-source-tracking-hooks (segment debug-function &optional sfcache)
- #!+sb-doc
- "Add hooks to track to track the source code in SEGMENT during
- disassembly. SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
- structure, in which case it is used to cache forms from files."
+;;; Add hooks to track to track the source code in SEGMENT during
+;;; disassembly. SFCACHE can be either NIL or it can be a
+;;; SOURCE-FORM-CACHE structure, in which case it is used to cache
+;;; forms from files.
+(defun add-source-tracking-hooks (segment debug-fun &optional sfcache)
(declare (type segment segment)
- (type (or null sb!di:debug-function) debug-function)
+ (type (or null sb!di:debug-fun) debug-fun)
(type (or null source-form-cache) sfcache))
(let ((last-block-pc -1))
(flet ((add-hook (pc fun &optional before-address)
:before-address before-address)
(seg-hooks segment))))
(handler-case
- (sb!di:do-debug-function-blocks (block debug-function)
+ (sb!di:do-debug-fun-blocks (block debug-fun)
(let ((first-location-in-block-p t))
(sb!di:do-debug-block-locations (loc block)
(let ((pc (sb!di::compiled-code-location-pc loc)))
(/= pc last-block-pc))
(setf first-location-in-block-p nil)
(add-hook pc
- #'(lambda (stream dstate)
- (print-block-boundary stream dstate))
+ (lambda (stream dstate)
+ (print-block-boundary stream dstate))
t)
(setf last-block-pc pc))
(let ((at-block-begin (= pc last-block-pc)))
(add-hook
pc
- #'(lambda (stream dstate)
- (declare (ignore dstate))
- (when stream
- (unless at-block-begin
- (terpri stream))
- (format stream ";;; [~D] "
- (sb!di:code-location-form-number
- loc))
- (prin1-short form stream)
- (terpri stream)
- (terpri stream)))
+ (lambda (stream dstate)
+ (declare (ignore dstate))
+ (when stream
+ (unless at-block-begin
+ (terpri stream))
+ (format stream ";;; [~D] "
+ (sb!di:code-location-form-number
+ loc))
+ (prin1-short form stream)
+ (terpri stream)
+ (terpri stream)))
t)))))
;; Keep track of variable live-ness as best we can.
loc))))
(add-hook
pc
- #'(lambda (stream dstate)
- (declare (ignore stream))
- (setf (dstate-current-valid-locations dstate)
- live-set)
- #+nil
- (note #'(lambda (stream)
- (let ((*print-length* nil))
- (format stream "live set: ~S"
- live-set)))
- dstate))))
+ (lambda (stream dstate)
+ (declare (ignore stream))
+ (setf (dstate-current-valid-locations dstate)
+ live-set)
+ #+nil
+ (note (lambda (stream)
+ (let ((*print-length* nil))
+ (format stream "live set: ~S"
+ live-set)))
+ dstate))))
))))
(sb!di:no-debug-blocks () nil)))))
-(defun add-debugging-hooks (segment debug-function &optional sfcache)
- (when debug-function
+(defun add-debugging-hooks (segment debug-fun &optional sfcache)
+ (when debug-fun
(setf (seg-storage-info segment)
- (storage-info-for-debug-function debug-function))
- (add-source-tracking-hooks segment debug-function sfcache)
- (let ((kind (sb!di:debug-function-kind debug-function)))
+ (storage-info-for-debug-fun debug-fun))
+ (add-source-tracking-hooks segment debug-fun sfcache)
+ (let ((kind (sb!di:debug-fun-kind debug-fun)))
(flet ((anh (n)
(push (make-offs-hook
:offset 0
- :function #'(lambda (stream dstate)
- (declare (ignore stream))
- (note n dstate)))
+ :function (lambda (stream dstate)
+ (declare (ignore stream))
+ (note n dstate)))
(seg-hooks segment))))
(case kind
(:external)
((nil)
- (anh "No-arg-parsing entry point"))
+ (anh "no-arg-parsing entry point"))
(t
- (anh #'(lambda (stream)
- (format stream "~S entry point" kind)))))))))
+ (anh (lambda (stream)
+ (format stream "~S entry point" kind)))))))))
\f
+;;; Return a list of the segments of memory containing machine code
+;;; instructions for FUNCTION.
(defun get-function-segments (function)
- #!+sb-doc
- "Returns a list of the segments of memory containing machine code
- instructions for FUNCTION."
(declare (type compiled-function function))
(let* ((code (fun-code function))
- (function-map (code-function-map code))
- (fname (sb!kernel:%function-name function))
+ (fun-map (code-fun-map code))
+ (fname (sb!kernel:%simple-fun-name function))
(sfcache (make-source-form-cache)))
(let ((first-block-seen-p nil)
(nil-block-seen-p nil)
(last-offset 0)
- (last-debug-function nil)
+ (last-debug-fun nil)
(segments nil))
(flet ((add-seg (offs len df)
(when (> len 0)
(push (make-code-segment code offs len
- :debug-function df
+ :debug-fun df
:source-form-cache sfcache)
segments))))
- (dotimes (fmap-index (length function-map))
- (let ((fmap-entry (aref function-map fmap-index)))
+ (dotimes (fmap-index (length fun-map))
+ (let ((fmap-entry (aref fun-map fmap-index)))
(etypecase fmap-entry
(integer
(when first-block-seen-p
(add-seg last-offset
(- fmap-entry last-offset)
- last-debug-function)
- (setf last-debug-function nil))
+ last-debug-fun)
+ (setf last-debug-fun nil))
(setf last-offset fmap-entry))
- (sb!c::compiled-debug-function
- (let ((name (sb!c::compiled-debug-function-name fmap-entry))
- (kind (sb!c::compiled-debug-function-kind fmap-entry)))
+ (sb!c::compiled-debug-fun
+ (let ((name (sb!c::compiled-debug-fun-name fmap-entry))
+ (kind (sb!c::compiled-debug-fun-kind fmap-entry)))
#+nil
(format t ";;; SAW ~S ~S ~S,~S ~D,~D~%"
name kind first-block-seen-p nil-block-seen-p
last-offset
- (sb!c::compiled-debug-function-start-pc fmap-entry))
+ (sb!c::compiled-debug-fun-start-pc fmap-entry))
(cond (#+nil (eq last-offset fun-offset)
(and (equal name fname) (not first-block-seen-p))
(setf first-block-seen-p t))
(return))
(when first-block-seen-p
(setf nil-block-seen-p t))))
- (setf last-debug-function
- (sb!di::make-compiled-debug-function fmap-entry code))
+ (setf last-debug-fun
+ (sb!di::make-compiled-debug-fun fmap-entry code))
)))))
(let ((max-offset (code-inst-area-length code)))
- (when (and first-block-seen-p last-debug-function)
+ (when (and first-block-seen-p last-debug-fun)
(add-seg last-offset
(- max-offset last-offset)
- last-debug-function))
+ last-debug-fun))
(if (null segments)
(let ((offs (fun-insts-offset function)))
(make-code-segment code offs (- max-offset offs)))
(nreverse segments)))))))
+;;; Return a list of the segments of memory containing machine code
+;;; instructions for the code-component CODE. If START-OFFSET and/or
+;;; LENGTH is supplied, only that part of the code-segment is used
+;;; (but these are constrained to lie within the code-segment).
(defun get-code-segments (code
&optional
- (start-offs 0)
+ (start-offset 0)
(length (code-inst-area-length code)))
- #!+sb-doc
- "Returns a list of the segments of memory containing machine code
- instructions for the code-component CODE. If START-OFFS and/or LENGTH is
- supplied, only that part of the code-segment is used (but these are
- constrained to lie within the code-segment)."
(declare (type sb!kernel:code-component code)
- (type offset start-offs)
+ (type offset start-offset)
(type length length))
(let ((segments nil))
(when code
- (let ((function-map (code-function-map code))
+ (let ((fun-map (code-fun-map code))
(sfcache (make-source-form-cache)))
(let ((last-offset 0)
- (last-debug-function nil))
+ (last-debug-fun nil))
(flet ((add-seg (offs len df)
(let* ((restricted-offs
- (min (max start-offs offs) (+ start-offs length)))
+ (min (max start-offset offs)
+ (+ start-offset length)))
(restricted-len
- (- (min (max start-offs (+ offs len))
- (+ start-offs length))
+ (- (min (max start-offset (+ offs len))
+ (+ start-offset length))
restricted-offs)))
(when (> restricted-len 0)
(push (make-code-segment code
restricted-offs restricted-len
- :debug-function df
+ :debug-fun df
:source-form-cache sfcache)
segments)))))
- (dotimes (fmap-index (length function-map))
- (let ((fmap-entry (aref function-map fmap-index)))
- (etypecase fmap-entry
+ (dotimes (fun-map-index (length fun-map))
+ (let ((fun-map-entry (aref fun-map fun-map-index)))
+ (etypecase fun-map-entry
(integer
- (add-seg last-offset (- fmap-entry last-offset)
- last-debug-function)
- (setf last-debug-function nil)
- (setf last-offset fmap-entry))
- (sb!c::compiled-debug-function
- (setf last-debug-function
- (sb!di::make-compiled-debug-function fmap-entry
- code))))))
- (when last-debug-function
+ (add-seg last-offset (- fun-map-entry last-offset)
+ last-debug-fun)
+ (setf last-debug-fun nil)
+ (setf last-offset fun-map-entry))
+ (sb!c::compiled-debug-fun
+ (setf last-debug-fun
+ (sb!di::make-compiled-debug-fun fun-map-entry
+ code))))))
+ (when last-debug-fun
(add-seg last-offset
(- (code-inst-area-length code) last-offset)
- last-debug-function))))))
+ last-debug-fun))))))
(if (null segments)
- (make-code-segment code start-offs length)
+ (make-code-segment code start-offset length)
(nreverse segments))))
\f
-#+nil
-(defun find-function-segment (fun)
- #!+sb-doc
- "Return the address of the instructions for function and its length.
- The length is computed using a heuristic, and so may not be accurate."
- (declare (type compiled-function fun))
- (let* ((code
- (fun-code fun))
- (fun-addr
- (- (sb!kernel:get-lisp-obj-address fun) sb!vm:function-pointer-type))
- (max-length
- (code-inst-area-length code))
- (upper-bound
- (+ (code-inst-area-address code) max-length)))
- (do ((some-fun (code-first-function code)
- (fun-next some-fun)))
- ((null some-fun)
- (values fun-addr (- upper-bound fun-addr)))
- (let ((some-addr (fun-address some-fun)))
- (when (and (> some-addr fun-addr)
- (< some-addr upper-bound))
- (setf upper-bound some-addr))))))
-\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)
- #!+sb-doc
- "Returns 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, this will return 0 and 0."
(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)))
+ (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
+;;; one to another.
(defun label-segments (seglist dstate)
- #!+sb-doc
- "Computes 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 it can find references from one to another."
(declare (type list seglist)
(type disassem-state dstate))
(dolist (seg seglist)
(add-segment-labels seg dstate))
- ;; now remove any labels that don't point anywhere in the segments we have
+ ;; Now remove any labels that don't point anywhere in the segments
+ ;; we have.
(setf (dstate-labels dstate)
- (remove-if #'(lambda (lab)
- (not
- (some #'(lambda (seg)
- (let ((start (seg-virtual-location seg)))
- (<= start
- (car lab)
- (+ start (seg-length seg)))))
- seglist)))
+ (remove-if (lambda (lab)
+ (not
+ (some (lambda (seg)
+ (let ((start (seg-virtual-location seg)))
+ (<= start
+ (car lab)
+ (+ start (seg-length seg)))))
+ seglist)))
(dstate-labels dstate))))
+;;; Disassemble the machine code instructions in SEGMENT to STREAM.
(defun disassemble-segment (segment stream dstate)
- #!+sb-doc
- "Disassemble the machine code instructions in SEGMENT to STREAM."
(declare (type segment segment)
(type stream stream)
(type disassem-state dstate))
(let ((*print-pretty* nil)) ; otherwise the pp conses hugely
(number-labels dstate)
(map-segment-instructions
- #'(lambda (chunk inst)
- (declare (type dchunk chunk) (type instruction inst))
- (let ((printer (inst-printer inst)))
- (when printer
- (funcall printer chunk inst stream dstate))))
+ (lambda (chunk inst)
+ (declare (type dchunk chunk) (type instruction inst))
+ (let ((printer (inst-printer inst)))
+ (when printer
+ (funcall printer chunk inst stream dstate))))
segment
dstate
stream)))
+;;; Disassemble the machine code instructions in each memory segment
+;;; in SEGMENTS in turn to STREAM.
(defun disassemble-segments (segments stream dstate)
- #!+sb-doc
- "Disassemble the machine code instructions in each memory segment in
- SEGMENTS in turn to STREAM."
(declare (type list segments)
(type stream stream)
(type disassem-state dstate))
\f
;;;; top-level functions
+;;; Disassemble the machine code instructions for FUNCTION.
(defun disassemble-function (function &key
(stream *standard-output*)
(use-labels t))
- #!+sb-doc
- "Disassemble the machine code instructions for FUNCTION."
(declare (type compiled-function function)
(type stream stream)
(type (member t nil) use-labels))
(function-lambda-expression function)
(declare (ignore name))
(when closurep
- (error "cannot compile a lexical closure"))
+ (error "can't compile a lexical closure"))
(compile nil lambda)))
(defun compiled-function-or-lose (thing &optional (name thing))
(and (listp thing)
(eq (car thing) 'setf)))
(compiled-function-or-lose (fdefinition thing) thing))
- ((sb!eval:interpreted-function-p thing)
- (compile-function-lambda-expr thing))
((functionp thing)
thing)
((and (listp thing)
- (eq (car thing) 'sb!impl::lambda))
+ (eq (car thing) 'lambda))
(compile nil thing))
(t
(error "can't make a compiled function from ~S" name))))
(stream *standard-output*)
(use-labels t))
#!+sb-doc
- "Disassemble the machine code associated with OBJECT, which can be a
+ "Disassemble the compiled code associated with OBJECT, which can be a
function, a lambda expression, or a symbol with a function definition. If
it is not already compiled, the compiler is called to produce something to
disassemble."
(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)
- ;; we can't detect closures, so be careful
- (disassemble-function (fun-self fun)
- :stream stream
- :use-labels use-labels)))
- (values)))
+ (disassemble-function (compiled-function-or-lose object)
+ :stream stream
+ :use-labels use-labels)
+ nil))
+;;; Disassembles the given area of memory starting at ADDRESS and
+;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
+;;; could move during a GC, you'd better disable it around the call to
+;;; this function.
(defun disassemble-memory (address
length
&key
(stream *standard-output*)
code-component
(use-labels t))
- #!+sb-doc
- "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
- Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
- you'd better disable it around the call to this function."
(declare (type (or address sb!sys:system-area-pointer) address)
(type length length)
(type stream stream)
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
+;;; Disassemble the machine code instructions associated with
+;;; CODE-COMPONENT (this may include multiple entry points).
(defun disassemble-code-component (code-component &key
(stream *standard-output*)
(use-labels t))
- #!+sb-doc
- "Disassemble the machine code instructions associated with
- CODE-COMPONENT (this may include multiple entry points)."
(declare (type (or null sb!kernel:code-component compiled-function)
code-component)
(type stream stream)
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
\f
-;;; Code for making useful segments from arbitrary lists of code-blocks
+;;; code for making useful segments from arbitrary lists of code-blocks
-;;; The maximum size of an instruction -- 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!).
+;;; 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 sap-to-vector (sap start end)
- (let* ((length (- end start))
- (result (make-array length :element-type '(unsigned-byte 8)))
- (sap (sb!sys:sap+ sap start)))
- (dotimes (i length)
- (setf (aref result i) (sb!sys:sap-ref-8 sap i)))
- result))
-
-(defun add-block-segments (sap amount seglist location connecting-vec dstate)
+(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)
(setf (seg-length seg) length)
(incf location length)
(push seg seglist)))))
- (let ((connecting-overflow 0))
+ (let ((connecting-overflow 0)
+ (amount (length seg-code-block)))
(when connecting-vec
- ;; tack on some of the new block to the old overflow vector
+ ;; Tack on some of the new block to the old overflow vector.
(let* ((beginning-of-block-amount
- (if sap (min max-instruction-size amount) 0))
+ (if seg-code-block (min max-instruction-size amount) 0))
(connecting-vec
- (if sap
+ (if seg-code-block
(concatenate
'(vector (unsigned-byte 8))
connecting-vec
- (sap-to-vector sap 0 beginning-of-block-amount))
+ (subseq seg-code-block 0 beginning-of-block-amount))
connecting-vec)))
(when (and (< (length connecting-vec) max-instruction-size)
- (not (null sap)))
+ (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 sap wasn't large
- ;; enough to do this (and is now entirely on the end of the
- ;; overflow-vector), just save it for next time.
+ ;; 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
:virtual-location location)))
(setf connecting-overflow (segment-overflow seg dstate))
(addit seg connecting-overflow)))))
- (cond ((null sap)
- ;; Nothing more to add.
+ (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
;; in the overflow vector for the time-being.
(values seglist
location
- (sap-to-vector sap connecting-overflow amount)))
+ (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-segment #'(lambda ()
- (sb!sys:sap+ sap connecting-overflow))
- initial-length
- :virtual-location location))
+ (make-vector-segment seg-code-block
+ connecting-overflow
+ initial-length
+ :virtual-location location))
(overflow
(segment-overflow seg dstate)))
(addit seg overflow)
(values seglist
location
- (sap-to-vector sap
- (+ connecting-overflow (seg-length seg))
- amount))))))))
+ (subseq seg-code-block
+ (+ connecting-overflow (seg-length seg))
+ amount))))))))
\f
;;;; code to disassemble assembler segments
(let ((location 0)
(disassem-segments nil)
(connecting-vec nil))
- (error "stub: code not converted to new SEGMENT WHN 19990322" ; KLUDGE
- assem-segment) ; (to avoid "ASSEM-SEGMENT defined but never used")
- ;; old code, needs to be converted to use less-SAPpy ASSEM-SEGMENTs:
- #|(sb!assem:segment-map-output
+ (sb!assem:on-segment-contents-vectorly
assem-segment
- #'(lambda (sap amount)
- (multiple-value-setq (disassem-segments location connecting-vec)
- (add-block-segments sap amount
- disassem-segments location
- connecting-vec
- dstate))))|#
+ (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 nil
- disassem-segments location
+ (add-block-segments nil
+ disassem-segments
+ location
connecting-vec
dstate)))
(sort disassem-segments #'< :key #'seg-virtual-location)))
-;;; FIXME: I noticed that this is only called by #!+SB-SHOW code. It would
-;;; be good to see whether this is the only caller of any other functions.
-#!+sb-show
+;;; Disassemble the machine code instructions associated with
+;;; ASSEM-SEGMENT (of type assem:segment).
(defun disassemble-assem-segment (assem-segment stream)
- #!+sb-doc
- "Disassemble the machine code instructions associated with
- ASSEM-SEGMENT (of type assem:segment)."
(declare (type sb!assem:segment assem-segment)
(type stream stream))
(let* ((dstate (make-dstate))
\f
;;; routines to find things in the Lisp environment
-;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots
+;;; 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)
;;; access function of the slot.
(defun grok-symbol-slot-ref (address)
(declare (type address address))
- (if (not (aligned-p address sb!vm:word-bytes))
+ (if (not (aligned-p address sb!vm:n-word-bytes))
(values nil nil)
(do ((slots-tail *grokked-symbol-slots* (cdr slots-tail)))
((null slots-tail)
(maybe-symbol-addr (- address slot-offset))
(maybe-symbol
(sb!kernel:make-lisp-obj
- (+ maybe-symbol-addr sb!vm:other-pointer-type))))
+ (+ maybe-symbol-addr sb!vm:other-pointer-lowtag))))
(when (symbolp maybe-symbol)
(return (values maybe-symbol (cdr field))))))))
(values
(sb!kernel:code-header-ref code
(ash (+ byte-offset
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
(- sb!vm:word-shift)))
t)
(values nil nil))))
+(defun get-code-constant-absolute (addr dstate)
+ (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)))))))
+
(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.
+(defvar *foreign-symbols-by-addr* nil)
+
+;;; Build an address-name hash-table from the name-address hash
+(defun invert-address-hash (htable &optional (addr-hash (make-hash-table)))
+ (maphash (lambda (name address)
+ (setf (gethash address addr-hash) name))
+ htable)
+ addr-hash)
+
+;;; Return the name of the primitive Lisp assembler routine or foreign
+;;; symbol located at ADDRESS, or NIL if there isn't one.
(defun find-assembler-routine (address)
(declare (type address address))
(when (null *assembler-routines-by-addr*)
- (setf *assembler-routines-by-addr* (make-hash-table))
- (maphash #'(lambda (name address)
- (setf (gethash address *assembler-routines-by-addr*) name))
- sb!kernel:*assembler-routines*))
+ (setf *assembler-routines-by-addr*
+ (invert-address-hash sb!fasl:*assembler-routines*))
+ (setf *assembler-routines-by-addr*
+ (invert-address-hash sb!fasl:*static-foreign-symbols*
+ *assembler-routines-by-addr*)))
(gethash address *assembler-routines-by-addr*))
\f
;;;; some handy function for machine-dependent code to use...
\f
;;;; optional routines to make notes about code
+;;; Store NOTE (which can be either a string or a function with a
+;;; single stream argument) to be printed as an end-of-line comment
+;;; after the current instruction is disassembled.
(defun note (note dstate)
- #!+sb-doc
- "Store NOTE (which can be either a string or a function with a single
- stream argument) to be printed as an end-of-line comment after the current
- instruction is disassembled."
(declare (type (or string function) note)
(type disassem-state dstate))
(push note (dstate-notes dstate)))
(prin1-short thing stream)
(prin1-short `',thing stream)))
+;;; Store a note about the lisp constant located BYTE-OFFSET bytes
+;;; from the current code-component, to be printed as an end-of-line
+;;; comment after the current instruction is disassembled.
(defun note-code-constant (byte-offset dstate)
- #!+sb-doc
- "Store a note about the lisp constant located BYTE-OFFSET bytes from the
- current code-component, to be printed as an end-of-line comment after the
- current instruction is disassembled."
(declare (type offset byte-offset)
(type disassem-state dstate))
(multiple-value-bind (const valid)
(get-code-constant byte-offset dstate)
(when valid
- (note #'(lambda (stream)
- (prin1-quoted-short const stream))
+ (note (lambda (stream)
+ (prin1-quoted-short const stream))
dstate))
const))
+;;; 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)
+ (declare (type address addr)
+ (type disassem-state dstate))
+ (multiple-value-bind (const valid)
+ (get-code-constant-absolute addr dstate)
+ (when valid
+ (note (lambda (stream)
+ (prin1-quoted-short const stream))
+ dstate))
+ (values const valid)))
+
+;;; If the memory address located NIL-BYTE-OFFSET bytes from the
+;;; constant NIL is a valid slot in a symbol, store a note describing
+;;; which symbol and slot, to be printed as an end-of-line comment
+;;; after the current instruction is disassembled. Returns non-NIL iff
+;;; a note was recorded.
(defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
- #!+sb-doc
- "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
- is a valid slot in a symbol, store a note describing which symbol and slot,
- to be printed as an end-of-line comment after the current instruction is
- disassembled. Returns non-NIL iff a note was recorded."
(declare (type offset nil-byte-offset)
(type disassem-state dstate))
(multiple-value-bind (symbol access-fun)
(grok-nil-indexed-symbol-slot-ref nil-byte-offset)
(when access-fun
- (note #'(lambda (stream)
- (prin1 (if (eq access-fun 'symbol-value)
- symbol
- `(,access-fun ',symbol))
- stream))
+ (note (lambda (stream)
+ (prin1 (if (eq access-fun 'symbol-value)
+ symbol
+ `(,access-fun ',symbol))
+ stream))
dstate))
access-fun))
+;;; If the memory address located NIL-BYTE-OFFSET bytes from the
+;;; constant NIL is a valid lisp object, store a note describing which
+;;; symbol and slot, to be printed as an end-of-line comment after the
+;;; current instruction is disassembled. Returns non-NIL iff a note
+;;; was recorded.
(defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
- #!+sb-doc
- "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
- is a valid lisp object, store a note describing which symbol and slot, to
- be printed as an end-of-line comment after the current instruction is
- disassembled. Returns non-NIL iff a note was recorded."
(declare (type offset nil-byte-offset)
(type disassem-state dstate))
(let ((obj (get-nil-indexed-object nil-byte-offset)))
- (note #'(lambda (stream)
- (prin1-quoted-short obj stream))
+ (note (lambda (stream)
+ (prin1-quoted-short obj stream))
dstate)
t))
+;;; If ADDRESS is the address of a primitive assembler routine or
+;;; foreign symbol, store a note describing which one, to be printed
+;;; as an end-of-line comment after the current instruction is
+;;; disassembled. Returns non-NIL iff a note was recorded. If
+;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made.
(defun maybe-note-assembler-routine (address note-address-p dstate)
- #!+sb-doc
- "If ADDRESS is the address of a primitive assembler routine, store a note
- describing which one, to be printed as an end-of-line comment after the
- current instruction is disassembled. Returns non-NIL iff a note was
- recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made."
- (declare (type address address)
- (type disassem-state dstate))
+ (declare (type disassem-state dstate))
+ (unless (typep address 'address)
+ (return-from maybe-note-assembler-routine nil))
(let ((name (find-assembler-routine address)))
(unless (null name)
- (note #'(lambda (stream)
- (if NOTE-ADDRESS-P
- (format stream "#X~8,'0x: ~S" address name)
- (prin1 name stream)))
+ (note (lambda (stream)
+ (if note-address-p
+ (format stream "#x~8,'0x: ~a" address name)
+ (princ name stream)))
dstate))
name))
+;;; If there's a valid mapping from OFFSET in the storage class
+;;; SC-NAME to a source variable, make a note of the source-variable
+;;; name, to be printed as an end-of-line comment after the current
+;;; instruction is disassembled. Returns non-NIL iff a note was
+;;; recorded.
(defun maybe-note-single-storage-ref (offset sc-name dstate)
- #!+sb-doc
- "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
- source variable, make a note of the source-variable name, to be printed as
- an end-of-line comment after the current instruction is disassembled.
- Returns non-NIL iff a note was recorded."
(declare (type offset offset)
(type symbol sc-name)
(type disassem-state dstate))
(let ((storage-location
(find-valid-storage-location offset sc-name dstate)))
(when storage-location
- (note #'(lambda (stream)
- (princ (sb!di:debug-var-symbol
- (aref (storage-info-debug-vars
- (seg-storage-info (dstate-segment dstate)))
- storage-location))
- stream))
+ (note (lambda (stream)
+ (princ (sb!di:debug-var-symbol
+ (aref (storage-info-debug-vars
+ (seg-storage-info (dstate-segment dstate)))
+ storage-location))
+ stream))
dstate)
t)))
+;;; If there's a valid mapping from OFFSET in the storage-base called
+;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with
+;;; the source-variable name, to be printed as an end-of-line comment
+;;; after the current instruction is disassembled. Returns non-NIL iff
+;;; a note was recorded.
(defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate)
- #!+sb-doc
- "If there's a valid mapping from OFFSET in the storage-base called SB-NAME
- to a source variable, make a note equating ASSOC-WITH with the
- source-variable name, to be printed as an end-of-line comment after the
- current instruction is disassembled. Returns non-NIL iff a note was
- recorded."
(declare (type offset offset)
(type symbol sb-name)
(type (or symbol string) assoc-with)
(let ((storage-location
(find-valid-storage-location offset sb-name dstate)))
(when storage-location
- (note #'(lambda (stream)
- (format stream "~A = ~S"
- assoc-with
- (sb!di:debug-var-symbol
- (aref (dstate-debug-vars dstate)
- storage-location))
- stream))
+ (note (lambda (stream)
+ (format stream "~A = ~S"
+ assoc-with
+ (sb!di:debug-var-symbol
+ (aref (dstate-debug-vars dstate)
+ storage-location))
+ stream))
dstate)
t)))
\f
(sb!c:sc-offset-scn sc-offs))
:offset (sb!c:sc-offset-offset sc-offs))))
+;;; When called from an error break instruction's :DISASSEM-CONTROL (or
+;;; :DISASSEM-PRINTER) function, will correctly deal with printing the
+;;; arguments to the break.
+;;;
+;;; ERROR-PARSE-FUN should be a function that accepts:
+;;; 1) a SYSTEM-AREA-POINTER
+;;; 2) a BYTE-OFFSET from the SAP to begin at
+;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
+;;; the byte length of the arguments (to avoid unnecessary consing)
+;;; It should read information from the SAP starting at BYTE-OFFSET, and
+;;; return four values:
+;;; 1) the error number
+;;; 2) the total length, in bytes, of the information
+;;; 3) a list of SC-OFFSETs of the locations of the error parameters
+;;; 4) a list of the length (as read from the SAP), in bytes, of each
+;;; of the return values.
(defun handle-break-args (error-parse-fun stream dstate)
- #!+sb-doc
- "When called from an error break instruction's :DISASSEM-CONTROL (or
- :DISASSEM-PRINTER) function, will correctly deal with printing the
- arguments to the break.
-
- ERROR-PARSE-FUN should be a function that accepts:
- 1) a SYSTEM-AREA-POINTER
- 2) a BYTE-OFFSET from the SAP to begin at
- 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
- the byte length of the arguments (to avoid unnecessary consing)
- It should read information from the SAP starting at BYTE-OFFSET, and return
- four values:
- 1) the error number
- 2) the total length, in bytes, of the information
- 3) a list of SC-OFFSETs of the locations of the error parameters
- 4) a list of the length (as read from the SAP), in bytes, of each of the
- return-values."
(declare (type function error-parse-fun)
(type (or null stream) stream)
(type disassem-state dstate))