Fix typos in docstrings and function names.

[sbcl.git] / src / compiler / disassem.lisp

diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp
index 4af4cf7..c1d7780 100644 (file)
--- a/src/compiler/disassem.lisp
+++ b/src/compiler/disassem.lisp
@@ -13,16 +13,16 @@
 \f
 ;;; types and defaults
 
 \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 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))
 
 (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 ()
 (deftype filtered-value-index ()
   `(integer 0 ,max-filtered-value-index))
 (deftype filtered-value-vector ()

@@ -35,7 +35,6 @@
 (declaim (type hash-table *disassem-insts*))
 
 (defvar *disassem-inst-space* nil)
 (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)
 
 ;;; minimum alignment of instructions, in bytes
 (defvar *disassem-inst-alignment-bytes* sb!vm:n-word-bytes)

@@ -47,10 +46,18 @@
 ;;; 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.
 ;;; 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*))
 
 (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.")
 
   #!+sb-doc
   "The column in which end-of-line comments for notes are started.")
 

@@ -85,7 +92,7 @@
          ;; 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)
          ;; 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)))))
        (let ((params
               (or sb!c:*backend-disassem-params*
                   (setf sb!c:*backend-disassem-params* (make-params)))))

@@ -102,14 +109,18 @@
 |#
 \f
 ;;;; cached functions
 |#
 \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))
 
   (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.
 \f
 ;;;; A DCHUNK contains the bits we look at to decode an
 ;;;; instruction.

@@ -128,15 +139,15 @@
                  dchunk=
                  dchunk-count-bits))
 
                  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))
 
 
 (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))
 
 (defun dchunk-extract (from pos)
   (declare (type dchunk from))

@@ -178,15 +189,33 @@
            (type offset byte-offset)
            (optimize (speed 3) (safety 0)))
   (the dchunk
            (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))
 
 (defun dchunk-corrected-extract (from pos unit-bits byte-order)
   (declare (type dchunk from))

@@ -229,7 +258,7 @@
   (mask dchunk-zero :type dchunk)       ; bits in the inst that are constant
   (id dchunk-zero :type dchunk)         ; value of those constant bits
 
   (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)
 
 
   (print-name nil :type symbol)
 

@@ -256,6 +285,10 @@
 (def!method print-object ((ispace inst-space) stream)
   (print-unreadable-object (ispace stream :type t :identity t)))
 
 (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
 (defstruct (inst-space-choice (:conc-name ischoice-)
                               (:copier nil))
   (common-id dchunk-zero :type dchunk)  ; applies to *parent's* mask

@@ -292,10 +325,10 @@
 
 (defvar *disassem-inst-formats* (make-hash-table))
 (defvar *disassem-arg-types* nil)
 
 (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 :type symbol)
   (fields nil :type list)
 

@@ -315,7 +348,7 @@
   (name nil)
   (args 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
 
   (default-printer nil :type list))
 \f

@@ -336,16 +369,17 @@
   (%make-funstate :args args))
 
 (defun funstate-compatible-p (funstate args)
   (%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)
          (funstate-arg-temps funstate)))
 
 (defun arg-or-lose (name funstate)

@@ -418,12 +452,12 @@
         (values wrapper-name `(defparameter ,wrapper-name ,form)))))
 
 (defun filter-overrides (overrides evalp)
         (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))
 
           overrides))
 

-(defparameter *arg-function-params*
+(defparameter *arg-fun-params*

   '((:printer . (value stream dstate))
     (:use-label . (value dstate))
     (:prefilter . (value dstate))))
   '((:printer . (value stream dstate))
     (:use-label . (value dstate))
     (:prefilter . (value dstate))))

@@ -434,7 +468,7 @@
          (wrapper-defs nil))
         ((null tail)
          (values params (nreverse wrapper-defs)))
          (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))
         (when fun-arg
           (let* ((fun-form (cadr tail))
                  (quoted-fun-form `',fun-form))

@@ -452,20 +486,20 @@
 (defun gen-args-def-form (overrides format-form &optional (evalp t))
   (let ((args-var (gensym)))
     `(let ((,args-var (copy-list (format-args ,format-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
                  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
   (declare (type symbol base-name))
   (declare (type (or symbol string) uniquified-name))
   (destructuring-bind

@@ -479,11 +513,11 @@
       `(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))
       `(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
          (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)
                                      `(format-default-printer ,format-var)
                                      (maybe-quote evalp printer-form))
                                args funcache)

@@ -491,9 +525,9 @@
                (find-labeller-fun ',uniquified-name args funcache)
              (multiple-value-bind (prefilter-fun prefilter-defun)
                  (find-prefilter-fun ',uniquified-name
                (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
                (multiple-value-bind (mask id)
                    (compute-mask-id args)
                  (values

@@ -548,7 +582,7 @@
       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
       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
       one, or be added to the end.
   :DEFAULT-PRINTER printer-list
       Use the given PRINTER-LIST as a format to print any instructions of

@@ -580,7 +614,7 @@
       fields, they are all sign-extended.
 
   :TYPE arg-type-name
       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
 
   :PREFILTER function
       A function which is called (along with all other prefilters, in the

@@ -638,10 +672,10 @@
                       :args ,args-var))
                (eval
                 `(progn
                       :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
                              ,args-var))))))))))
 
 ;;; FIXME: probably needed only at build-the-system time, not in

@@ -662,13 +696,13 @@
   (let* ((arg-pos (position arg-name args :key #'arg-name))
          (arg
           (if (null arg-pos)
   (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)
                 (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))
     (when (and field-p (not fields-p))
       (setf fields (list field))
       (setf fields-p t))

@@ -691,20 +725,20 @@
           can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
          arg-name))
       (setf (arg-fields arg)
           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 ~W bits wide.~:>"
                                      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))
 
                     fields)))
     args))
 

@@ -752,8 +786,8 @@
               ((atom (cadr atk))
                (push `(,(cadr atk) ,(cddr atk)) bindings))
               (t
               ((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))
                      (cadr atk)
                      (cddr atk))))))
     bindings))

@@ -812,39 +846,38 @@
                (car (push (cons kind nil) (cdr this-arg-temps))))))
       (setf (cdr this-kind-temps) (cons vars forms)))))
 \f
                (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))
 
   (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))
 (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
   (multiple-value-bind (args wrapper-defs)
       (munge-fun-refs args evalp t name)
     `(progn

@@ -855,35 +888,35 @@
 \f
 (defmacro def-arg-form-kind ((&rest names) &rest inits)
   `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
 \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)
                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)
 
 (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)
 
 (defun valsrc-equal (f1 f2)
   (if (null f1)

@@ -892,73 +925,73 @@
              (value-or-source f2))))
 
 (def-arg-form-kind (:filtering)
              (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)
 
 (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)
 
 (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)
 
 (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)
                               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)
 
 ;;; 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))
 
 (defun remember-printer-use (arg funstate)
   (set-arg-temps nil nil arg :printed funstate))

@@ -985,13 +1018,13 @@
       (valsrc-value thing)
       thing))
 \f
       (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)))
 
   (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))
   (dolist (cached-fun cached-funs nil)
     (let ((funstate (cached-fun-funstate cached-fun)))
       (when (and (equal constraint (cached-fun-constraint cached-fun))

@@ -999,29 +1032,29 @@
                      (funstate-compatible-p funstate args)))
         (return 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 (missing-arg)))
-                                 &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)
   (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
        (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)
                 (values ,name-var
                         `(progn
                            ,(progn ,@defun-maker-forms)

@@ -1034,15 +1067,15 @@
   (if (null printer-source)
       (values nil nil)
       (let ((printer-source (preprocess-printer printer-source args)))
   (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 fun-name)
   (let ((printer-form (compile-printer-list source funstate))
 \f
 (defun make-printer-defun (source funstate fun-name)
   (let ((printer-form (compile-printer-list source funstate))

@@ -1122,8 +1155,8 @@
            test
            key
            (sharing-mapcar
            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)))))
 
             body))))
         (t form)))))
 

@@ -1147,24 +1180,24 @@
           printer
           :cond
           (sharing-mapcar
           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
            (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
           printer)))))
 
 ;;; Return a version of the disassembly-template PRINTER with

@@ -1196,7 +1229,7 @@
         ((eq (car printer) :choose)
          (pick-printer-choice (cdr printer) args))
         (t
         ((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
                          printer))))
 \f
 ;;;; some simple functions that help avoid consing when we're just

@@ -1211,6 +1244,7 @@
       (cons car cdr)))
 
 (defun sharing-mapcar (fun list)
       (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
   #!+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

@@ -1226,7 +1260,7 @@
         ((symbolp printer)
          (find printer args :key #'arg-name))
         ((listp printer)
         ((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)))
 
                 printer))
         (t t)))
 

@@ -1292,13 +1326,13 @@
         ((eq (car source) 'function)
          `(local-call-global-printer ,source))
         ((eq (car source) :cond)
         ((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
                           (cdr source))))
         ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
         (t

@@ -1347,7 +1381,7 @@
            `(equal ,(listify-fields val-form-1)
                    ,(listify-fields val-form-2)))
           (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)
                            val-form-1 val-form-2))))))
 
 (defun compile-test (subj test funstate)

@@ -1381,8 +1415,8 @@
                  (arg2 (arg-or-lose (car body) funstate)))
              (unless (and (= (length (arg-fields arg1))
                              (length (arg-fields arg2)))
                  (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: ~
                                  (arg-fields arg1)
                                  (arg-fields arg2)))
                (pd-error "can't compare differently sized fields: ~

@@ -1390,10 +1424,10 @@
              (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
                                   (gen-arg-forms arg2 :numeric funstate))))
           ((eq key :or)
              (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)
                           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)))
                            body)))
           ((eq key :not)
            `(not ,(compile-test subj (car body) funstate)))

@@ -1407,8 +1441,8 @@
          (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
     (if (null labelled-fields)
         (values nil nil)
          (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))
              :stem (concatenate 'string "LABELLER-" (string %name))
              :constraint labelled-fields)
           (let ((labels-form 'labels))

@@ -1442,16 +1476,16 @@
 (defun find-prefilter-fun (%name %format-name args cache)
   (declare (type (or symbol string) %name %format-name))
   (let ((filtered-args (mapcar #'arg-name
 (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)
     (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
              :stem (concatenate 'string

-                               (string %name)
-                               "-"
-                               (string %format-name)
-                               "-PREFILTER")
+                                (string %name)
+                                "-"
+                                (string %format-name)
+                                "-PREFILTER")

              :constraint filtered-args)
           (collect ((forms))
             (dolist (arg args)
              :constraint filtered-args)
           (collect ((forms))
             (dolist (arg args)

@@ -1476,7 +1510,7 @@
                 (declare (ignorable #'local-filter #'local-extract)
                          (inline (setf local-filtered-value)
                                  local-filter local-extract))
                 (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
                 (let* ,(make-arg-temp-bindings funstate)
                   ,@(forms)))))))))
 \f

@@ -1505,11 +1539,11 @@
 (declaim (maybe-inline sign-extend aligned-p align tab tab0))
 
 (defun bytes-to-bits (bytes)
 (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)
   (* 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))
   (multiple-value-bind (bytes rbits)
       (truncate bits sb!vm:n-byte-bits)
     (when (not (zerop rbits))

@@ -1546,10 +1580,78 @@
   (write value :stream stream :radix t :base 16 :escape nil))
 \f
 (defun read-signed-suffix (length dstate)
   (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))
            (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 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)
+  (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 after a
+  ;; non-prefix 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.
 ;;;
 
 ;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
 ;;;

@@ -1558,3 +1660,12 @@
 ;;; it's defined before it's used. -- WHN ca. 19990701
 (defmacro dstate-get-prop (dstate name)
   `(getf (dstate-properties ,dstate) ,name))
 ;;; 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))