\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 address () '(unsigned-byte #.sb!vm:n-word-bits))
+(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:word-bytes)
+(defvar *disassem-inst-alignment-bytes* sb!vm:n-word-bytes)
(declaim (type alignment *disassem-inst-alignment-bytes*))
(defvar *disassem-location-column-width* 8)
(defvar *disassem-opcode-column-width* 6)
(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.")
;; these are not in the params because they only exist at compile time
(defparameter ,(format-table-name) (make-hash-table))
(defparameter ,(arg-type-table-name) nil)
- (defparameter ,(function-cache-name) (make-function-cache)))
+ (defparameter ,(fun-cache-name) (make-fun-cache)))
(let ((params
(or sb!c:*backend-disassem-params*
(setf sb!c:*backend-disassem-params* (make-params)))))
|#
\f
;;;; cached functions
+;;;;
+;;;; FIXME: Is it important to cache these? For performance? Or why?
+;;;; If performance: *Really*? How fast does disassembly need to be??
+;;;; So: Could we just punt this?
-(defstruct (function-cache (:copier nil))
+(defstruct (fun-cache (:copier nil))
(printers nil :type list)
(labellers nil :type list)
(prefilters nil :type list))
-(defvar *disassem-function-cache* (make-function-cache))
-(declaim (type function-cache *disassem-function-cache*))
+(defvar *disassem-fun-cache* (make-fun-cache))
+(declaim (type fun-cache *disassem-fun-cache*))
\f
;;;; A DCHUNK contains the bits we look at to decode an
;;;; instruction.
dchunk=
dchunk-count-bits))
-(defconstant dchunk-bits 32)
+(def!constant dchunk-bits #.sb!vm:n-word-bits)
(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 #.(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)
;; disassembly functions
(prefilter nil :type (or null function))
(labeller nil :type (or null function))
- (printer (required-argument) :type (or null function))
+ (printer (missing-arg) :type (or null function))
(control nil :type (or null function))
;; instructions that are the same as this instruction but with more
(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
- (subspace (required-argument) :type (or inst-space instruction)))
+ (subspace (missing-arg) :type (or inst-space instruction)))
\f
;;;; These are the kind of values we can compute for an argument, and
;;;; how to compute them. The :CHECKER functions make sure that a given
(defstruct (arg-form-kind (:copier nil))
(names nil :type list)
- (producer (required-argument) :type function)
- (checker (required-argument) :type function))
+ (producer (missing-arg) :type function)
+ (checker (missing-arg) :type function))
(defun arg-form-kind-or-lose (kind)
(or (getf *arg-form-kinds* kind)
(defvar *disassem-inst-formats* (make-hash-table))
(defvar *disassem-arg-types* nil)
-(defvar *disassem-function-cache* (make-function-cache))
+(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
(%make-funstate :args args))
(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)))))
+ (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
+ (= (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)
(values wrapper-name `(defparameter ,wrapper-name ,form)))))
(defun filter-overrides (overrides evalp)
- (mapcar #'(lambda (override)
- (list* (car override) (cadr override)
- (munge-fun-refs (cddr override) evalp)))
+ (mapcar (lambda (override)
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
overrides))
-(defparameter *arg-function-params*
+(defparameter *arg-fun-params*
'((:printer . (value stream dstate))
(:use-label . (value dstate))
(:prefilter . (value dstate))))
(wrapper-defs nil))
((null tail)
(values params (nreverse wrapper-defs)))
- (let ((fun-arg (assoc (car tail) *arg-function-params*)))
+ (let ((fun-arg (assoc (car tail) *arg-fun-params*)))
(when fun-arg
(let* ((fun-form (cadr tail))
(quoted-fun-form `',fun-form))
(defun gen-args-def-form (overrides format-form &optional (evalp t))
(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))
+ ,@(mapcar (lambda (override)
+ (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
`(let* ((*current-instruction-flavor* ',(cons base-name format-name))
(,format-var (format-or-lose ',format-name))
(args ,(gen-args-def-form field-defs format-var evalp))
- (funcache *disassem-function-cache*))
+ (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
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
:args ,args-var))
(eval
`(progn
- ,@(mapcar #'(lambda (arg)
- (when (arg-fields arg)
- (gen-arg-access-macro-def-form
- arg ,args-var ',name)))
+ ,@(mapcar (lambda (arg)
+ (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
(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))))
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))
can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
arg-name))
(setf (arg-fields arg)
- (mapcar #'(lambda (bytespec)
- (when (> (+ (byte-position bytespec)
- (byte-size bytespec))
- format-length)
- (error "~@<in arg ~S: ~3I~:_~
+ (mapcar (lambda (bytespec)
+ (when (> (+ (byte-position bytespec)
+ (byte-size bytespec))
+ format-length)
+ (error "~@<in arg ~S: ~3I~:_~
The field ~S doesn't fit in an ~
- instruction-format ~D bits wide.~:>"
- arg-name
- bytespec
- format-length))
- (correct-dchunk-bytespec-for-endianness
- bytespec
- format-length
- sb!c:*backend-byte-order*))
+ instruction-format ~W bits wide.~:>"
+ arg-name
+ bytespec
+ format-length))
+ (correct-dchunk-bytespec-for-endianness
+ bytespec
+ format-length
+ sb!c:*backend-byte-order*))
fields)))
args))
((atom (cadr atk))
(push `(,(cadr atk) ,(cddr atk)) bindings))
(t
- (mapc #'(lambda (var form)
- (push `(,var ,form) bindings))
+ (mapc (lambda (var form)
+ (push `(,var ,form) bindings))
(cadr atk)
(cddr atk))))))
bindings))
(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
\f
(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))
+ ,@(mapcar (lambda (name)
+ `(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)))
- :checker #'(lambda (new-arg old-arg)
- (equal (arg-fields new-arg)
- (arg-fields old-arg))))
+ :producer (lambda (arg funstate)
+ (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))))
(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)))
- :checker #'(lambda (new-arg old-arg)
- (equal (arg-sign-extend-p new-arg)
- (arg-sign-extend-p old-arg))))
+ :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)))
+ :checker (lambda (new-arg old-arg)
+ (equal (arg-sign-extend-p new-arg)
+ (arg-sign-extend-p old-arg))))
(defun valsrc-equal (f1 f2)
(if (null f1)
(value-or-source f2))))
(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))))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
+ :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))))
+ :checker (lambda (new-arg 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))))
- :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))))))
+ :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))))
+ :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))))))
(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)))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
+ :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)))
+ :checker (lambda (new-arg 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 ~
+ :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 ~
unless using a function: ~S" arg)
- `((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))))
+ `((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))))
;;; 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!"))
- :checker #'(lambda (new-arg old-arg)
- (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
+ :producer (lambda (&rest noise)
+ (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))))
(defun remember-printer-use (arg funstate)
(set-arg-temps nil nil arg :printed funstate))
(valsrc-value thing)
thing))
\f
-(defstruct (cached-function (:conc-name cached-fun-)
- (:copier nil))
+(defstruct (cached-fun (:conc-name cached-fun-)
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
-(defun find-cached-function (cached-funs args constraint)
+(defun find-cached-fun (cached-funs args constraint)
(dolist (cached-fun cached-funs nil)
(let ((funstate (cached-fun-funstate cached-fun)))
(when (and (equal constraint (cached-fun-constraint cached-fun))
(funstate-compatible-p funstate args)))
(return cached-fun)))))
-(defmacro !with-cached-function ((name-var
- funstate-var
- cache
- cache-slot
- args
- &key
- constraint
- (stem (required-argument)))
- &body defun-maker-forms)
+(defmacro !with-cached-fun ((name-var
+ 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-function (,cache-slot ,cache)
- ,args ,constraint-var)))
+ (,cache-var (find-cached-fun (,cache-slot ,cache)
+ ,args ,constraint-var)))
(cond (,cache-var
(values (cached-fun-name ,cache-var) nil))
(t
(let* ((,name-var (symbolicate "CACHED-FUN--" ,stem))
(,funstate-var (make-funstate ,args))
(,cache-var
- (make-cached-function :name ,name-var
- :funstate ,funstate-var
- :constraint ,constraint-var)))
+ (make-cached-fun :name ,name-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-function
- (name funstate cache function-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 function-name)
+(defun make-printer-defun (source funstate fun-name)
(let ((printer-form (compile-printer-list source funstate))
(bindings (make-arg-temp-bindings funstate)))
- `(defun ,function-name (chunk inst stream dstate)
+ `(defun ,fun-name (chunk inst stream dstate)
(declare (type dchunk chunk)
(type instruction inst)
(type stream stream)
test
key
(sharing-mapcar
- #'(lambda (sub-test)
- (preprocess-test subj sub-test args))
+ (lambda (sub-test)
+ (preprocess-test subj sub-test args))
body))))
(t form)))))
printer
: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)))
+ (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)))
(cdr printer))))
(quote printer)
(t
(sharing-mapcar
- #'(lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
+ (lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
printer)))))
+;;; Return a version of the disassembly-template PRINTER with
+;;; compile-time tests (e.g. :constant without a value), and any
+;;; :CHOOSE operators resolved properly for the args ARGS.
+;;;
+;;; (:CHOOSE Sub*) simply returns the first Sub in which every field
+;;; reference refers to a valid arg.
(defun preprocess-printer (printer args)
- #!+sb-doc
- "Returns a version of the disassembly-template PRINTER with compile-time
- tests (e.g. :constant without a value), and any :CHOOSE operators resolved
- properly for the args ARGS. (:CHOOSE Sub*) simply returns the first Sub in
- which every field reference refers to a valid arg."
(preprocess-conditionals (preprocess-chooses printer args) args))
\f
+;;; Return the first non-keyword symbol in a depth-first search of TREE.
(defun find-first-field-name (tree)
- #!+sb-doc
- "Returns the first non-keyword symbol in a depth-first search of TREE."
(cond ((null tree)
nil)
((and (symbolp tree) (not (keywordp tree)))
((eq (car printer) :choose)
(pick-printer-choice (cdr printer) args))
(t
- (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
+ (sharing-mapcar (lambda (sub) (preprocess-chooses sub args))
printer))))
\f
;;;; some simple functions that help avoid consing when we're just
(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
((symbolp printer)
(find printer args :key #'arg-name))
((listp printer)
- (every #'(lambda (x) (all-arg-refs-relevant-p x args))
+ (every (lambda (x) (all-arg-refs-relevant-p x args))
printer))
(t t)))
((eq (car source) 'function)
`(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)))
+ `(cond ,@(mapcar (lambda (clause)
+ `(,(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
`(equal ,(listify-fields val-form-1)
,(listify-fields val-form-2)))
(t
- `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
+ `(and ,@(mapcar (lambda (v1 v2) `(= ,v1 ,v2))
val-form-1 val-form-2))))))
(defun compile-test (subj test funstate)
(arg2 (arg-or-lose (car body) funstate)))
(unless (and (= (length (arg-fields arg1))
(length (arg-fields arg2)))
- (every #'(lambda (bs1 bs2)
- (= (byte-size bs1) (byte-size bs2)))
+ (every (lambda (bs1 bs2)
+ (= (byte-size bs1) (byte-size bs2)))
(arg-fields arg1)
(arg-fields arg2)))
(pd-error "can't compare differently sized fields: ~
(compare-fields-form (gen-arg-forms arg1 :numeric funstate)
(gen-arg-forms arg2 :numeric funstate))))
((eq key :or)
- `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ `(or ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
body)))
((eq key :and)
- `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ `(and ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
body)))
((eq key :not)
`(not ,(compile-test subj (car body) funstate)))
(mapcar #'arg-name (remove-if-not #'arg-use-label args))))
(if (null labelled-fields)
(values nil nil)
- (!with-cached-function
- (name funstate cache function-cache-labellers args
+ (!with-cached-fun
+ (name funstate cache fun-cache-labellers args
:stem (concatenate 'string "LABELLER-" (string %name))
:constraint labelled-fields)
(let ((labels-form 'labels))
(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-function
- (name funstate cache function-cache-prefilters args
+ (!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)
(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))
- (* bytes sb!vm:byte-bits))
+ (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:byte-bits)
+ (truncate bits sb!vm:n-byte-bits)
(when (not (zerop rbits))
- (error "~D bits is not a byte-multiple." bits))
+ (error "~W bits is not a byte-multiple." bits))
bytes))
(defun sign-extend (int size)
(dpb int (byte size 0) -1)
int))
+;;; Is ADDRESS aligned on a SIZE byte boundary?
(defun aligned-p (address size)
- #!+sb-doc
- "Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary."
(declare (type address address)
(type alignment size))
(zerop (logand (1- size) address)))
+;;; Return ADDRESS aligned *upward* to a SIZE byte boundary.
(defun align (address size)
- #!+sb-doc
- "Return ADDRESS aligned *upward* to a SIZE byte boundary."
(declare (type address address)
(type alignment size))
(logandc1 (1- size) (+ (1- size) address)))
(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))
-
+\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)
+ ;; for user code to hang stuff off of, cleared each time before an
+ ;; instruction is processed
+ (inst-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.
+;;;
;;; KLUDGE: The associated run-time machinery for this is in
;;; target-disassem.lisp (much later). This is here just to make sure
;;; it's defined before it's used. -- WHN ca. 19990701
(defmacro dstate-get-prop (dstate name)
- #!+sb-doc
- "Get the value of the property called NAME in DSTATE. Also setf'able."
`(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