(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 address () '(unsigned-byte #.sb!vm:n-word-bits))
+(deftype disassem-length () '(unsigned-byte 24))
(deftype column () '(integer 0 1000))
(def!constant max-filtered-value-index 32)
(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)
;;; the width of the column in which instruction-names are printed. A
;;; value of zero gives the effect of not aligning the arguments at
;;; all.
-(defvar *disassem-opcode-column-width* 6)
+(defvar *disassem-opcode-column-width* 0)
(declaim (type text-width *disassem-opcode-column-width*))
-(defvar *disassem-note-column* 45
+;;; the width of the column in which instruction-bytes are printed. A
+;;; value of zero disables the printing of instruction bytes.
+(defvar *disassem-inst-column-width* 16
+ #!+sb-doc
+ "The width of instruction bytes.")
+(declaim (type text-width *disassem-inst-column-width*))
+
+
+(defvar *disassem-note-column* (+ 45 *disassem-inst-column-width*)
#!+sb-doc
"The column in which end-of-line comments for notes are started.")
dchunk=
dchunk-count-bits))
-(def!constant dchunk-bits 32)
+(def!constant dchunk-bits #.sb!vm:n-word-bits)
(deftype dchunk ()
`(unsigned-byte ,dchunk-bits))
`(integer 0 ,dchunk-bits))
(def!constant dchunk-zero 0)
-(def!constant dchunk-one #xFFFFFFFF)
+(def!constant dchunk-one #.(1- (expt 2 sb!vm:n-word-bits)))
(defun dchunk-extract (from pos)
(declare (type dchunk from))
(type offset byte-offset)
(optimize (speed 3) (safety 0)))
(the dchunk
- (if (eq byte-order :big-endian)
- (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 24)
- (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 16)
- (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 8)
- (sb!sys:sap-ref-8 sap (+ 3 byte-offset)))
- (+ (sb!sys:sap-ref-8 sap byte-offset)
- (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
- (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
- (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24)))))
+ (ecase dchunk-bits
+ (32 (if (eq byte-order :big-endian)
+ (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 24)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 8)
+ (sb!sys:sap-ref-8 sap (+ 3 byte-offset)))
+ (+ (sb!sys:sap-ref-8 sap byte-offset)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24))))
+ (64 (if (eq byte-order :big-endian)
+ (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 56)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 48)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 40)
+ (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 32)
+ (ash (sb!sys:sap-ref-8 sap (+ 4 byte-offset)) 24)
+ (ash (sb!sys:sap-ref-8 sap (+ 5 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 6 byte-offset)) 8)
+ (sb!sys:sap-ref-8 sap (+ 7 byte-offset)))
+ (+ (sb!sys:sap-ref-8 sap byte-offset)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24)
+ (ash (sb!sys:sap-ref-8 sap (+ 4 byte-offset)) 32)
+ (ash (sb!sys:sap-ref-8 sap (+ 5 byte-offset)) 40)
+ (ash (sb!sys:sap-ref-8 sap (+ 6 byte-offset)) 48)
+ (ash (sb!sys:sap-ref-8 sap (+ 7 byte-offset)) 56)))))))
(defun dchunk-corrected-extract (from pos unit-bits byte-order)
(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-fun-cache* (make-fun-cache))
(defstruct (arg (:copier nil)
- (:predicate 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
(defun funstate-compatible-p (funstate args)
(every (lambda (this-arg-temps)
- (let* ((old-arg (car this-arg-temps))
- (new-arg (find (arg-name old-arg) args :key #'arg-name)))
- (and new-arg
- (every (lambda (this-kind-temps)
- (funcall (find-arg-form-checker
- (car this-kind-temps))
- new-arg
- old-arg))
- (cdr this-arg-temps)))))
+ (let* ((old-arg (car this-arg-temps))
+ (new-arg (find (arg-name old-arg) args :key #'arg-name)))
+ (and new-arg
+ (= (arg-position old-arg) (arg-position new-arg))
+ (every (lambda (this-kind-temps)
+ (funcall (find-arg-form-checker
+ (car this-kind-temps))
+ new-arg
+ old-arg))
+ (cdr this-arg-temps)))))
(funstate-arg-temps funstate)))
(defun arg-or-lose (name funstate)
(defun filter-overrides (overrides evalp)
(mapcar (lambda (override)
- (list* (car override) (cadr override)
- (munge-fun-refs (cddr override) evalp)))
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
overrides))
(defparameter *arg-fun-params*
(let ((args-var (gensym)))
`(let ((,args-var (copy-list (format-args ,format-form))))
,@(mapcar (lambda (override)
- (update-args-form args-var
- `',(car override)
- (and (cdr override)
- (cons :value (cdr override)))
- evalp))
+ (update-args-form args-var
+ `',(car override)
+ (and (cdr override)
+ (cons :value (cdr override)))
+ evalp))
overrides)
,args-var)))
(defun gen-printer-def-forms-def-form (base-name
- uniquified-name
- def
- &optional
- (evalp t))
+ uniquified-name
+ def
+ &optional
+ (evalp t))
(declare (type symbol base-name))
(declare (type (or symbol string) uniquified-name))
(destructuring-bind
(funcache *disassem-fun-cache*))
(multiple-value-bind (printer-fun printer-defun)
(find-printer-fun ',uniquified-name
- ',format-name
- ,(if (eq printer-form :default)
+ ',format-name
+ ,(if (eq printer-form :default)
`(format-default-printer ,format-var)
(maybe-quote evalp printer-form))
args funcache)
(find-labeller-fun ',uniquified-name args funcache)
(multiple-value-bind (prefilter-fun prefilter-defun)
(find-prefilter-fun ',uniquified-name
- ',format-name
- args
- funcache)
+ ',format-name
+ args
+ funcache)
(multiple-value-bind (mask id)
(compute-mask-id args)
(values
Inherit all arguments and properties of the given format. Any
arguments defined in the current format definition will either modify
the copy of an existing argument (keeping in the same order with
- respect to when pre-filter's are called), if it has the same name as
+ respect to when prefilters are called), if it has the same name as
one, or be added to the end.
:DEFAULT-PRINTER printer-list
Use the given PRINTER-LIST as a format to print any instructions of
(eval
`(progn
,@(mapcar (lambda (arg)
- (when (arg-fields arg)
- (gen-arg-access-macro-def-form
- arg ,args-var ',name)))
+ (when (arg-fields arg)
+ (gen-arg-access-macro-def-form
+ arg ,args-var ',name)))
,args-var))))))))))
;;; FIXME: probably needed only at build-the-system time, not in
(push arg (cdr (last args))))
arg)
(setf (nth arg-pos args)
- (copy-structure (nth arg-pos args))))))
+ (copy-structure (nth arg-pos args))))))
(when (and field-p (not fields-p))
(setf fields (list field))
(setf fields-p t))
arg-name))
(setf (arg-fields arg)
(mapcar (lambda (bytespec)
- (when (> (+ (byte-position bytespec)
- (byte-size bytespec))
- format-length)
- (error "~@<in arg ~S: ~3I~:_~
+ (when (> (+ (byte-position bytespec)
+ (byte-size bytespec))
+ format-length)
+ (error "~@<in arg ~S: ~3I~:_~
The field ~S doesn't fit in an ~
instruction-format ~W bits wide.~:>"
- arg-name
- bytespec
- format-length))
- (correct-dchunk-bytespec-for-endianness
- bytespec
- format-length
- sb!c:*backend-byte-order*))
+ arg-name
+ bytespec
+ format-length))
+ (correct-dchunk-bytespec-for-endianness
+ bytespec
+ format-length
+ sb!c:*backend-byte-order*))
fields)))
args))
(push `(,(cadr atk) ,(cddr atk)) bindings))
(t
(mapc (lambda (var form)
- (push `(,var ,form) bindings))
+ (push `(,var ,form) bindings))
(cadr atk)
(cddr atk))))))
bindings))
;;;
;;; :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
(defmacro def-arg-form-kind ((&rest names) &rest inits)
`(let ((kind (make-arg-form-kind :names ',names ,@inits)))
,@(mapcar (lambda (name)
- `(setf (getf *arg-form-kinds* ',name) kind))
+ `(setf (getf *arg-form-kinds* ',name) kind))
names)))
(def-arg-form-kind (:raw)
:producer (lambda (arg funstate)
- (declare (ignore funstate))
- (mapcar (lambda (bytespec)
- `(the (unsigned-byte ,(byte-size bytespec))
- (local-extract ',bytespec)))
- (arg-fields arg)))
+ (declare (ignore funstate))
+ (mapcar (lambda (bytespec)
+ `(the (unsigned-byte ,(byte-size bytespec))
+ (local-extract ',bytespec)))
+ (arg-fields arg)))
:checker (lambda (new-arg old-arg)
- (equal (arg-fields new-arg)
- (arg-fields old-arg))))
+ (equal (arg-fields new-arg)
+ (arg-fields old-arg))))
(def-arg-form-kind (:sign-extended :unfiltered)
:producer (lambda (arg funstate)
- (let ((raw-forms (gen-arg-forms arg :raw funstate)))
- (if (and (arg-sign-extend-p arg) (listp raw-forms))
- (mapcar (lambda (form field)
- `(the (signed-byte ,(byte-size field))
- (sign-extend ,form
- ,(byte-size field))))
- raw-forms
- (arg-fields arg))
- raw-forms)))
+ (let ((raw-forms (gen-arg-forms arg :raw funstate)))
+ (if (and (arg-sign-extend-p arg) (listp raw-forms))
+ (mapcar (lambda (form field)
+ `(the (signed-byte ,(byte-size field))
+ (sign-extend ,form
+ ,(byte-size field))))
+ raw-forms
+ (arg-fields arg))
+ raw-forms)))
:checker (lambda (new-arg old-arg)
- (equal (arg-sign-extend-p new-arg)
- (arg-sign-extend-p old-arg))))
+ (equal (arg-sign-extend-p new-arg)
+ (arg-sign-extend-p old-arg))))
(defun valsrc-equal (f1 f2)
(if (null f1)
(def-arg-form-kind (:filtering)
:producer (lambda (arg funstate)
- (let ((sign-extended-forms
- (gen-arg-forms arg :sign-extended funstate))
- (pf (arg-prefilter arg)))
- (if pf
- (values
- `(local-filter ,(maybe-listify sign-extended-forms)
- ,(source-form pf))
- t)
- (values sign-extended-forms nil))))
+ (let ((sign-extended-forms
+ (gen-arg-forms arg :sign-extended funstate))
+ (pf (arg-prefilter arg)))
+ (if pf
+ (values
+ `(local-filter ,(maybe-listify sign-extended-forms)
+ ,(source-form pf))
+ t)
+ (values sign-extended-forms nil))))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
+ (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
(def-arg-form-kind (:filtered :unadjusted)
:producer (lambda (arg funstate)
- (let ((pf (arg-prefilter arg)))
- (if pf
- (values `(local-filtered-value ,(arg-position arg)) t)
- (gen-arg-forms arg :sign-extended funstate))))
+ (let ((pf (arg-prefilter arg)))
+ (if pf
+ (values `(local-filtered-value ,(arg-position arg)) t)
+ (gen-arg-forms arg :sign-extended funstate))))
:checker (lambda (new-arg old-arg)
- (let ((pf1 (arg-prefilter new-arg))
- (pf2 (arg-prefilter old-arg)))
- (if (null pf1)
- (null pf2)
- (= (arg-position new-arg)
- (arg-position old-arg))))))
+ (let ((pf1 (arg-prefilter new-arg))
+ (pf2 (arg-prefilter old-arg)))
+ (if (null pf1)
+ (null pf2)
+ (= (arg-position new-arg)
+ (arg-position old-arg))))))
(def-arg-form-kind (:adjusted :numeric :unlabelled)
:producer (lambda (arg funstate)
- (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
- (use-label (arg-use-label arg)))
- (if (and use-label (not (eq use-label t)))
- (list
- `(adjust-label ,(maybe-listify filtered-forms)
- ,(source-form use-label)))
- filtered-forms)))
+ (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
+ (use-label (arg-use-label arg)))
+ (if (and use-label (not (eq use-label t)))
+ (list
+ `(adjust-label ,(maybe-listify filtered-forms)
+ ,(source-form use-label)))
+ filtered-forms)))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
+ (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
(def-arg-form-kind (:labelled :final)
:producer (lambda (arg funstate)
- (let ((adjusted-forms
- (gen-arg-forms arg :adjusted funstate))
- (use-label (arg-use-label arg)))
- (if use-label
- (let ((form (maybe-listify adjusted-forms)))
- (if (and (not (eq use-label t))
- (not (atom adjusted-forms))
- (/= (Length adjusted-forms) 1))
- (pd-error
- "cannot label a multiple-field argument ~
+ (let ((adjusted-forms
+ (gen-arg-forms arg :adjusted funstate))
+ (use-label (arg-use-label arg)))
+ (if use-label
+ (let ((form (maybe-listify adjusted-forms)))
+ (if (and (not (eq use-label t))
+ (not (atom adjusted-forms))
+ (/= (length adjusted-forms) 1))
+ (pd-error
+ "cannot label a multiple-field argument ~
unless using a function: ~S" arg)
- `((lookup-label ,form))))
- adjusted-forms)))
+ `((lookup-label ,form))))
+ adjusted-forms)))
:checker (lambda (new-arg old-arg)
- (let ((lf1 (arg-use-label new-arg))
- (lf2 (arg-use-label old-arg)))
- (if (null lf1) (null lf2) t))))
+ (let ((lf1 (arg-use-label new-arg))
+ (lf2 (arg-use-label old-arg)))
+ (if (null lf1) (null lf2) t))))
;;; This is a bogus kind that's just used to ensure that printers are
;;; compatible...
(def-arg-form-kind (:printed)
:producer (lambda (&rest noise)
- (declare (ignore noise))
- (pd-error "bogus! can't use the :printed value of an arg!"))
+ (declare (ignore noise))
+ (pd-error "bogus! can't use the :printed value of an arg!"))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
+ (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
(defun remember-printer-use (arg funstate)
(set-arg-temps nil nil arg :printed funstate))
thing))
\f
(defstruct (cached-fun (:conc-name cached-fun-)
- (:copier nil))
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
(return cached-fun)))))
(defmacro !with-cached-fun ((name-var
- funstate-var
- cache
- cache-slot
- args
- &key
- constraint
- (stem (missing-arg)))
- &body defun-maker-forms)
+ funstate-var
+ cache
+ cache-slot
+ args
+ &key
+ constraint
+ (stem (missing-arg)))
+ &body defun-maker-forms)
(let ((cache-var (gensym))
(constraint-var (gensym)))
`(let* ((,constraint-var ,constraint)
(,cache-var (find-cached-fun (,cache-slot ,cache)
- ,args ,constraint-var)))
+ ,args ,constraint-var)))
(cond (,cache-var
(values (cached-fun-name ,cache-var) nil))
(t
(,funstate-var (make-funstate ,args))
(,cache-var
(make-cached-fun :name ,name-var
- :funstate ,funstate-var
- :constraint ,constraint-var)))
+ :funstate ,funstate-var
+ :constraint ,constraint-var)))
(values ,name-var
`(progn
,(progn ,@defun-maker-forms)
(if (null printer-source)
(values nil nil)
(let ((printer-source (preprocess-printer printer-source args)))
- (!with-cached-fun
- (name funstate cache fun-cache-printers args
- :constraint printer-source
- :stem (concatenate 'string
- (string %name)
- "-"
- (symbol-name %format-name)
- "-PRINTER"))
- (make-printer-defun printer-source funstate name)))))
+ (!with-cached-fun
+ (name funstate cache fun-cache-printers args
+ :constraint printer-source
+ :stem (concatenate 'string
+ (string %name)
+ "-"
+ (symbol-name %format-name)
+ "-PRINTER"))
+ (make-printer-defun printer-source funstate name)))))
\f
(defun make-printer-defun (source funstate fun-name)
(let ((printer-form (compile-printer-list source funstate))
key
(sharing-mapcar
(lambda (sub-test)
- (preprocess-test subj sub-test args))
+ (preprocess-test subj sub-test args))
body))))
(t form)))))
:cond
(sharing-mapcar
(lambda (clause)
- (let ((filtered-body
- (sharing-mapcar
- (lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
- (cdr clause))))
- (sharing-cons
- clause
- (preprocess-test (find-first-field-name filtered-body)
- (car clause)
- args)
- filtered-body)))
+ (let ((filtered-body
+ (sharing-mapcar
+ (lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
+ (cdr clause))))
+ (sharing-cons
+ clause
+ (preprocess-test (find-first-field-name filtered-body)
+ (car clause)
+ args)
+ filtered-body)))
(cdr printer))))
(quote printer)
(t
(sharing-mapcar
(lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
+ (preprocess-conditionals sub-printer args))
printer)))))
;;; Return a version of the disassembly-template PRINTER with
(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
`(local-call-global-printer ,source))
((eq (car source) :cond)
`(cond ,@(mapcar (lambda (clause)
- `(,(compile-test (find-first-field-name
- (cdr clause))
- (car clause)
- funstate)
- ,@(compile-printer-list (cdr clause)
- funstate)))
+ `(,(compile-test (find-first-field-name
+ (cdr clause))
+ (car clause)
+ funstate)
+ ,@(compile-printer-list (cdr clause)
+ funstate)))
(cdr source))))
;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
(t
(unless (and (= (length (arg-fields arg1))
(length (arg-fields arg2)))
(every (lambda (bs1 bs2)
- (= (byte-size bs1) (byte-size bs2)))
+ (= (byte-size bs1) (byte-size bs2)))
(arg-fields arg1)
(arg-fields arg2)))
(pd-error "can't compare differently sized fields: ~
(defun find-prefilter-fun (%name %format-name args cache)
(declare (type (or symbol string) %name %format-name))
(let ((filtered-args (mapcar #'arg-name
- (remove-if-not #'arg-prefilter args))))
+ (remove-if-not #'arg-prefilter args))))
(if (null filtered-args)
(values nil nil)
(!with-cached-fun
(name funstate cache fun-cache-prefilters args
:stem (concatenate 'string
- (string %name)
- "-"
- (string %format-name)
- "-PREFILTER")
+ (string %name)
+ "-"
+ (string %format-name)
+ "-PREFILTER")
:constraint filtered-args)
(collect ((forms))
(dolist (arg args)
(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))
(write value :stream stream :radix t :base 16 :escape nil))
\f
(defun read-signed-suffix (length dstate)
- (declare (type (member 8 16 32) length)
+ (declare (type (member 8 16 32 64) length)
(type disassem-state dstate)
(optimize (speed 3) (safety 0)))
(sign-extend (read-suffix length dstate) 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)
- (:copier nil))
+ (:constructor %make-dstate)
+ (:copier nil))
;; offset of current pos in segment
- (cur-offs 0 :type offset)
+ (cur-offs 0 :type offset)
;; offset of next position
- (next-offs 0 :type offset)
+ (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))
+ (segment-sap nil :type (or null 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)
+ (alignment sb!vm:n-word-bytes :type alignment)
(byte-order :little-endian
- :type (member :big-endian :little-endian))
+ :type (member :big-endian :little-endian))
;; for user code to hang stuff off of
(properties nil :type list)
+ ;; for user code to hang stuff off of, cleared each time after a
+ ;; non-prefix instruction is processed
+ (inst-properties nil :type list)
(filtered-values (make-array max-filtered-value-index)
- :type filtered-value-vector)
+ :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))
+ (output-state :beginning
+ :type (member :beginning
+ :block-boundary
+ nil))
;; alist of (address . label-number)
- (labels nil :type list)
+ (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)
;; 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)
+ (cur-offs-hooks nil :type list)
;; for the current location
(notes nil :type list)
(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))))
+ "+~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))))
+ (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))))
+ (dstate-next-offs dstate))))
;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
;;;
;;; it's defined before it's used. -- WHN ca. 19990701
(defmacro dstate-get-prop (dstate name)
`(getf (dstate-properties ,dstate) ,name))
+
+;;; Push NAME on the list of instruction properties in DSTATE.
+(defun dstate-put-inst-prop (dstate name)
+ (push name (dstate-inst-properties dstate)))
+
+;;; Return non-NIL if NAME is on the list of instruction properties in
+;;; DSTATE.
+(defun dstate-get-inst-prop (dstate name)
+ (member name (dstate-inst-properties dstate) :test #'eq))
projects / sbcl.git / blobdiff