\f
;;; types and defaults
-(defconstant label-column-width 7)
+(def!constant label-column-width 7)
(deftype text-width () '(integer 0 1000))
(deftype alignment () '(integer 0 64))
(deftype offset () '(signed-byte 24))
(deftype address () '(unsigned-byte 32))
-(deftype length () '(unsigned-byte 24))
+(deftype disassem-length () '(unsigned-byte 24))
(deftype column () '(integer 0 1000))
-(defconstant max-filtered-value-index 32)
+(def!constant max-filtered-value-index 32)
(deftype filtered-value-index ()
`(integer 0 ,max-filtered-value-index))
(deftype filtered-value-vector ()
(declaim (type hash-table *disassem-insts*))
(defvar *disassem-inst-space* nil)
-(declaim (type (or null inst-space) *disassem-inst-space*))
;;; minimum alignment of instructions, in bytes
(defvar *disassem-inst-alignment-bytes* sb!vm:n-word-bytes)
dchunk=
dchunk-count-bits))
-(defconstant dchunk-bits 32)
+(def!constant dchunk-bits 32)
(deftype dchunk ()
`(unsigned-byte ,dchunk-bits))
(deftype dchunk-index ()
`(integer 0 ,dchunk-bits))
-(defconstant dchunk-zero 0)
-(defconstant dchunk-one #xFFFFFFFF)
+(def!constant dchunk-zero 0)
+(def!constant dchunk-one #xFFFFFFFF)
(defun dchunk-extract (from pos)
(declare (type dchunk from))
(mask dchunk-zero :type dchunk) ; bits in the inst that are constant
(id dchunk-zero :type dchunk) ; value of those constant bits
- (length 0 :type length) ; in bytes
+ (length 0 :type disassem-length) ; in bytes
(print-name nil :type symbol)
(def!method print-object ((ispace inst-space) stream)
(print-unreadable-object (ispace stream :type t :identity t)))
+;;; now that we've defined the structure, we can declaim the type of
+;;; the variable:
+(declaim (type (or null inst-space) *disassem-inst-space*))
+
(defstruct (inst-space-choice (:conc-name ischoice-)
(:copier nil))
(common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
(defvar *disassem-arg-types* nil)
(defvar *disassem-fun-cache* (make-fun-cache))
-(defstruct (argument (:conc-name arg-)
- (:copier nil))
+(defstruct (arg (:copier nil)
+ (:predicate nil))
(name nil :type symbol)
(fields nil :type list)
(name nil)
(args nil :type list)
- (length 0 :type length) ; in bytes
+ (length 0 :type disassem-length) ; in bytes
(default-printer nil :type list))
\f
fields, they are all sign-extended.
:TYPE arg-type-name
- Inherit any properties of the given argument-type.
+ Inherit any properties of the given argument type.
:PREFILTER function
A function which is called (along with all other prefilters, in the
(let* ((arg-pos (position arg-name args :key #'arg-name))
(arg
(if (null arg-pos)
- (let ((arg (make-argument :name arg-name)))
+ (let ((arg (make-arg :name arg-name)))
(if (null args)
(setf args (list arg))
(push arg (cdr (last args))))
(car (push (cons kind nil) (cdr this-arg-temps))))))
(setf (cdr this-kind-temps) (cons vars forms)))))
\f
-(defmacro define-argument-type (name &rest args)
- #!+sb-doc
- "DEFINE-ARGUMENT-TYPE Name {Key Value}*
- Define a disassembler argument type NAME (which can then be referenced in
- another argument definition using the :TYPE argument). &KEY args are:
-
- :SIGN-EXTEND boolean
- If non-NIL, the raw value of this argument is sign-extended.
-
- :TYPE arg-type-name
- Inherit any properties of given argument-type.
-
- :PREFILTER function
- A function which is called (along with all other prefilters, in the
- order that their arguments appear in the instruction- format) before
- any printing is done, to filter the raw value. Any uses of READ-SUFFIX
- must be done inside a prefilter.
-
- :PRINTER function-string-or-vector
- A function, string, or vector which is used to print an argument of
- this type.
-
- :USE-LABEL
- If non-NIL, the value of an argument of this type is used as an
- address, and if that address occurs inside the disassembled code, it is
- replaced by a label. If this is a function, it is called to filter the
- value."
+;;; DEFINE-ARG-TYPE Name {Key Value}*
+;;;
+;;; Define a disassembler argument type NAME (which can then be referenced in
+;;; another argument definition using the :TYPE argument). &KEY args are:
+;;;
+;;; :SIGN-EXTEND boolean
+;;; If non-NIL, the raw value of this argument is sign-extended.
+;;;
+;;; :TYPE arg-type-name
+;;; Inherit any properties of given arg-type.
+;;;
+;;; :PREFILTER function
+;;; A function which is called (along with all other prefilters,
+;;; in the order that their arguments appear in the instruction-
+;;; format) before any printing is done, to filter the raw value.
+;;; Any uses of READ-SUFFIX must be done inside a prefilter.
+;;;
+;;; :PRINTER function-string-or-vector
+;;; A function, string, or vector which is used to print an argument of
+;;; this type.
+;;;
+;;; :USE-LABEL
+;;; If non-NIL, the value of an argument of this type is used as
+;;; an address, and if that address occurs inside the disassembled
+;;; code, it is replaced by a label. If this is a function, it is
+;;; called to filter the value.
+(defmacro define-arg-type (name &rest args)
(gen-arg-type-def-form name args))
+;;; Generate a form to define a disassembler argument type. See
+;;; DEFINE-ARG-TYPE for more information.
(defun gen-arg-type-def-form (name args &optional (evalp t))
- #!+sb-doc
- "Generate a form to define a disassembler argument type. See
- DEFINE-ARGUMENT-TYPE for more info."
(multiple-value-bind (args wrapper-defs)
(munge-fun-refs args evalp t name)
`(progn
(let ((form (maybe-listify adjusted-forms)))
(if (and (not (eq use-label t))
(not (atom adjusted-forms))
- (/= (Length adjusted-forms) 1))
+ (/= (length adjusted-forms) 1))
(pd-error
"cannot label a multiple-field argument ~
unless using a function: ~S" arg)
(cons car cdr)))
(defun sharing-mapcar (fun list)
+ (declare (type function fun))
#!+sb-doc
"A simple (one list arg) mapcar that avoids consing up a new list
as long as the results of calling FUN on the elements of LIST are
(declare (ignorable #'local-filter #'local-extract)
(inline (setf local-filtered-value)
local-filter local-extract))
- ;; Use them for side-effects only.
+ ;; Use them for side effects only.
(let* ,(make-arg-temp-bindings funstate)
,@(forms)))))))))
\f
(declaim (maybe-inline sign-extend aligned-p align tab tab0))
(defun bytes-to-bits (bytes)
- (declare (type length bytes))
+ (declare (type disassem-length bytes))
(* bytes sb!vm:n-byte-bits))
(defun bits-to-bytes (bits)
- (declare (type length bits))
+ (declare (type disassem-length bits))
(multiple-value-bind (bytes rbits)
(truncate bits sb!vm:n-byte-bits)
(when (not (zerop rbits))
(type disassem-state dstate)
(optimize (speed 3) (safety 0)))
(sign-extend (read-suffix length dstate) length))
+\f
+;;; All state during disassembly. We store some seemingly redundant
+;;; 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)
+ (: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 (missing-arg) :type sb!sys:system-area-pointer)
+ ;; 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))
+ ;; for user code to hang stuff off of
+ (properties nil :type list)
+ (filtered-values (make-array max-filtered-value-index)
+ :type filtered-value-vector)
+ ;; used for prettifying printing
+ (addr-print-len nil :type (or null (integer 0 20)))
+ (argument-column 0 :type column)
+ ;; to make output look nicer
+ (output-state :beginning
+ :type (member :beginning
+ :block-boundary
+ nil))
+
+ ;; 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)
+
+ ;; alist of (address . label-number), popped as it's used
+ (cur-labels nil :type list)
+ ;; OFFS-HOOKs, popped as they're used
+ (cur-offs-hooks nil :type list)
+
+ ;; for the current location
+ (notes nil :type list)
+
+ ;; 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
+ "+~W~@[ in ~S~]"
+ (dstate-cur-offs dstate)
+ (dstate-segment dstate))))
+
+;;; Return the absolute address of the current instruction in DSTATE.
+(defun dstate-cur-addr (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)
+ (the address (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-next-offs dstate))))
;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
;;;
projects / sbcl.git / blobdiff