src/compiler/disassem.lisp

   1 ;;;; machine-independent disassembler
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!DISASSEM")
  13 \f
  14 ;;; types and defaults
  15
  16 (defconstant label-column-width 7)
  17
  18 (deftype text-width () '(integer 0 1000))
  19 (deftype alignment () '(integer 0 64))
  20 (deftype offset () '(signed-byte 24))
  21 (deftype address () '(unsigned-byte 32))
  22 (deftype length () '(unsigned-byte 24))
  23 (deftype column () '(integer 0 1000))
  24
  25 (defconstant max-filtered-value-index 32)
  26 (deftype filtered-value-index ()
  27   `(integer 0 ,max-filtered-value-index))
  28 (deftype filtered-value-vector ()
  29   `(simple-array t (,max-filtered-value-index)))
  30 \f
  31 ;;;; disassembly parameters
  32
  33 ;;; instructions
  34 (defvar *disassem-insts* (make-hash-table :test 'eq))
  35 (declaim (type hash-table *disassem-insts*))
  36
  37 (defvar *disassem-inst-space* nil)
  38 (declaim (type (or null inst-space) *disassem-inst-space*))
  39
  40 ;;; minimum alignment of instructions, in bytes
  41 (defvar *disassem-inst-alignment-bytes* sb!vm:word-bytes)
  42 (declaim (type alignment *disassem-inst-alignment-bytes*))
  43
  44 (defvar *disassem-location-column-width* 8)
  45 (declaim (type text-width *disassem-location-column-width*))
  46
  47 ;;; the width of the column in which instruction-names are printed. A
  48 ;;; value of zero gives the effect of not aligning the arguments at
  49 ;;; all.
  50 (defvar *disassem-opcode-column-width* 6)
  51 (declaim (type text-width *disassem-opcode-column-width*))
  52
  53 (defvar *disassem-note-column* 45
  54   #!+sb-doc
  55   "The column in which end-of-line comments for notes are started.")
  56
  57 ;;; the old CMU CL code to set the CMU CL disassembly parameters
  58 #|
  59 (defmacro set-disassem-params (&rest args)
  60   #!+sb-doc
  61   "Specify global disassembler params. &KEY arguments include:
  62
  63   :INSTRUCTION-ALIGNMENT number
  64       Minimum alignment of instructions, in bits.
  65
  66   :ADDRESS-SIZE number
  67       Size of a machine address, in bits.
  68
  69   :OPCODE-COLUMN-WIDTH
  70       Width of the column used for printing the opcode portion of the
  71       instruction, or NIL to use the default."
  72   (gen-preamble-form args))
  73
  74 (defun gen-preamble-form (args)
  75   #!+sb-doc
  76   "Generate a form to specify global disassembler params. See the
  77   documentation for SET-DISASSEM-PARAMS for more info."
  78   (destructuring-bind
  79       (&key instruction-alignment
  80             address-size
  81             (opcode-column-width nil opcode-column-width-p))
  82       args
  83     `(progn
  84        (eval-when (:compile-toplevel :execute)
  85          ;; these are not in the params because they only exist at compile time
  86          (defparameter ,(format-table-name) (make-hash-table))
  87          (defparameter ,(arg-type-table-name) nil)
  88          (defparameter ,(function-cache-name) (make-function-cache)))
  89        (let ((params
  90               (or sb!c:*backend-disassem-params*
  91                   (setf sb!c:*backend-disassem-params* (make-params)))))
  92          (declare (ignorable params))
  93          ,(when instruction-alignment
  94             `(setf (params-instruction-alignment params)
  95                    (bits-to-bytes ,instruction-alignment)))
  96          ,(when address-size
  97             `(setf (params-location-column-width params)
  98                    (* 2 ,address-size)))
  99          ,(when opcode-column-width-p
 100             `(setf (params-opcode-column-width params) ,opcode-column-width))
 101          'disassem-params))))
 102 |#
 103 \f
 104 ;;;; cached functions
 105
 106 (defstruct (function-cache (:copier nil))
 107   (printers nil :type list)
 108   (labellers nil :type list)
 109   (prefilters nil :type list))
 110
 111 (defvar *disassem-function-cache* (make-function-cache))
 112 (declaim (type function-cache *disassem-function-cache*))
 113 \f
 114 ;;;; A DCHUNK contains the bits we look at to decode an
 115 ;;;; instruction.
 116 ;;;; I tried to keep this abstract so that if using integers > the machine
 117 ;;;; word size conses too much, it can be changed to use bit-vectors or
 118 ;;;; something.
 119 ;;;;
 120 ;;;; KLUDGE: It's not clear that using bit-vectors would be any more efficient.
 121 ;;;; Perhaps the abstraction could go away. -- WHN 19991124
 122
 123 #!-sb-fluid
 124 (declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not
 125                  dchunk-make-mask dchunk-make-field
 126                  sap-ref-dchunk
 127                  dchunk-extract
 128                  dchunk=
 129                  dchunk-count-bits))
 130
 131 (defconstant dchunk-bits 32)
 132
 133 (deftype dchunk ()
 134   `(unsigned-byte ,dchunk-bits))
 135 (deftype dchunk-index ()
 136   `(integer 0 ,dchunk-bits))
 137
 138 (defconstant dchunk-zero 0)
 139 (defconstant dchunk-one #xFFFFFFFF)
 140
 141 (defun dchunk-extract (from pos)
 142   (declare (type dchunk from))
 143   (the dchunk (ldb pos (the dchunk from))))
 144
 145 (defmacro dchunk-copy (x)
 146   `(the dchunk ,x))
 147
 148 (defun dchunk-or (to from)
 149   (declare (type dchunk to from))
 150   (the dchunk (logior to from)))
 151 (defun dchunk-and (to from)
 152   (declare (type dchunk to from))
 153   (the dchunk (logand to from)))
 154 (defun dchunk-clear (to from)
 155   (declare (type dchunk to from))
 156   (the dchunk (logandc2 to from)))
 157 (defun dchunk-not (from)
 158   (declare (type dchunk from))
 159   (the dchunk (logand dchunk-one (lognot from))))
 160
 161 (defmacro dchunk-andf (to from)
 162   `(setf ,to (dchunk-and ,to ,from)))
 163 (defmacro dchunk-orf (to from)
 164   `(setf ,to (dchunk-or ,to ,from)))
 165 (defmacro dchunk-clearf (to from)
 166   `(setf ,to (dchunk-clear ,to ,from)))
 167
 168 (defun dchunk-make-mask (pos)
 169   (the dchunk (mask-field pos -1)))
 170 (defun dchunk-make-field (pos value)
 171   (the dchunk (dpb value pos 0)))
 172
 173 (defmacro make-dchunk (value)
 174   `(the dchunk ,value))
 175
 176 (defun sap-ref-dchunk (sap byte-offset byte-order)
 177   (declare (type sb!sys:system-area-pointer sap)
 178            (type offset byte-offset)
 179            (optimize (speed 3) (safety 0)))
 180   (the dchunk
 181        (if (eq byte-order :big-endian)
 182            (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 24)
 183               (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 16)
 184               (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 8)
 185               (sb!sys:sap-ref-8 sap (+ 3 byte-offset)))
 186            (+ (sb!sys:sap-ref-8 sap byte-offset)
 187               (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
 188               (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
 189               (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24)))))
 190
 191 (defun dchunk-corrected-extract (from pos unit-bits byte-order)
 192   (declare (type dchunk from))
 193   (if (eq byte-order :big-endian)
 194       (ldb (byte (byte-size pos)
 195                  (+ (byte-position pos) (- dchunk-bits unit-bits)))
 196            (the dchunk from))
 197       (ldb pos (the dchunk from))))
 198
 199 (defmacro dchunk-insertf (place pos value)
 200   `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
 201
 202 (defun dchunk= (x y)
 203   (declare (type dchunk x y))
 204   (= x y))
 205 (defmacro dchunk-zerop (x)
 206   `(dchunk= ,x dchunk-zero))
 207
 208 (defun dchunk-strict-superset-p (sup sub)
 209   (and (zerop (logandc2 sub sup))
 210        (not (zerop (logandc2 sup sub)))))
 211
 212 (defun dchunk-count-bits (x)
 213   (declare (type dchunk x))
 214   (logcount x))
 215 \f
 216 (defstruct (instruction (:conc-name inst-)
 217                         (:constructor
 218                          make-instruction (name
 219                                            format-name
 220                                            print-name
 221                                            length
 222                                            mask id
 223                                            printer
 224                                            labeller prefilter control))
 225                         (:copier nil))
 226   (name nil :type (or symbol string))
 227   (format-name nil :type (or symbol string))
 228
 229   (mask dchunk-zero :type dchunk)       ; bits in the inst that are constant
 230   (id dchunk-zero :type dchunk)         ; value of those constant bits
 231
 232   (length 0 :type length)               ; in bytes
 233
 234   (print-name nil :type symbol)
 235
 236   ;; disassembly functions
 237   (prefilter nil :type (or null function))
 238   (labeller nil :type (or null function))
 239   (printer (required-argument) :type (or null function))
 240   (control nil :type (or null function))
 241
 242   ;; instructions that are the same as this instruction but with more
 243   ;; constraints
 244   (specializers nil :type list))
 245 (def!method print-object ((inst instruction) stream)
 246   (print-unreadable-object (inst stream :type t :identity t)
 247     (format stream "~A(~A)" (inst-name inst) (inst-format-name inst))))
 248 \f
 249 ;;;; an instruction space holds all known machine instructions in a
 250 ;;;; form that can be easily searched
 251
 252 (defstruct (inst-space (:conc-name ispace-)
 253                        (:copier nil))
 254   (valid-mask dchunk-zero :type dchunk) ; applies to *children*
 255   (choices nil :type list))
 256 (def!method print-object ((ispace inst-space) stream)
 257   (print-unreadable-object (ispace stream :type t :identity t)))
 258
 259 (defstruct (inst-space-choice (:conc-name ischoice-)
 260                               (:copier nil))
 261   (common-id dchunk-zero :type dchunk)  ; applies to *parent's* mask
 262   (subspace (required-argument) :type (or inst-space instruction)))
 263 \f
 264 ;;;; These are the kind of values we can compute for an argument, and
 265 ;;;; how to compute them. The :CHECKER functions make sure that a given
 266 ;;;; argument is compatible with another argument for a given use.
 267
 268 (defvar *arg-form-kinds* nil)
 269
 270 (defstruct (arg-form-kind (:copier nil))
 271   (names nil :type list)
 272   (producer (required-argument) :type function)
 273   (checker (required-argument) :type function))
 274
 275 (defun arg-form-kind-or-lose (kind)
 276   (or (getf *arg-form-kinds* kind)
 277       (pd-error "unknown arg-form kind ~S" kind)))
 278
 279 (defun find-arg-form-producer (kind)
 280   (arg-form-kind-producer (arg-form-kind-or-lose kind)))
 281 (defun find-arg-form-checker (kind)
 282   (arg-form-kind-checker (arg-form-kind-or-lose kind)))
 283
 284 (defun canonicalize-arg-form-kind (kind)
 285   (car (arg-form-kind-names (arg-form-kind-or-lose kind))))
 286 \f
 287 ;;;; only used during compilation of the instructions for a backend
 288 ;;;;
 289 ;;;; FIXME: If only used then, isn't there some way we could do
 290 ;;;; EVAL-WHEN tricks to keep this stuff from appearing in the target
 291 ;;;; system?
 292
 293 (defvar *disassem-inst-formats* (make-hash-table))
 294 (defvar *disassem-arg-types* nil)
 295 (defvar *disassem-function-cache* (make-function-cache))
 296
 297 (defstruct (argument (:conc-name arg-)
 298                      (:copier nil))
 299   (name nil :type symbol)
 300   (fields nil :type list)
 301
 302   (value nil :type (or list integer))
 303   (sign-extend-p nil :type (member t nil))
 304
 305   ;; position in a vector of prefiltered values
 306   (position 0 :type fixnum)
 307
 308   ;; functions to use
 309   (printer nil)
 310   (prefilter nil)
 311   (use-label nil))
 312
 313 (defstruct (instruction-format (:conc-name format-)
 314                                (:copier nil))
 315   (name nil)
 316   (args nil :type list)
 317
 318   (length 0 :type length)               ; in bytes
 319
 320   (default-printer nil :type list))
 321 \f
 322 ;;; A FUNSTATE holds the state of any arguments used in a disassembly
 323 ;;; function.
 324 (defstruct (funstate (:conc-name funstate-)
 325                      (:constructor %make-funstate)
 326                      (:copier nil))
 327   (args nil :type list)
 328   (arg-temps nil :type list))           ; See below.
 329
 330 (defun make-funstate (args)
 331   ;; give the args a position
 332   (let ((i 0))
 333     (dolist (arg args)
 334       (setf (arg-position arg) i)
 335       (incf i)))
 336   (%make-funstate :args args))
 337
 338 (defun funstate-compatible-p (funstate args)
 339   (every #'(lambda (this-arg-temps)
 340              (let* ((old-arg (car this-arg-temps))
 341                     (new-arg (find (arg-name old-arg) args :key #'arg-name)))
 342                (and new-arg
 343                     (every #'(lambda (this-kind-temps)
 344                                (funcall (find-arg-form-checker
 345                                          (car this-kind-temps))
 346                                         new-arg
 347                                         old-arg))
 348                            (cdr this-arg-temps)))))
 349          (funstate-arg-temps funstate)))
 350
 351 (defun arg-or-lose (name funstate)
 352   (let ((arg (find name (funstate-args funstate) :key #'arg-name)))
 353     (when (null arg)
 354       (pd-error "unknown argument ~S" name))
 355     arg))
 356 \f
 357 ;;;; Since we can't include some values in compiled output as they are
 358 ;;;; (notably functions), we sometimes use a VALSRC structure to keep
 359 ;;;; track of the source from which they were derived.
 360
 361 (defstruct (valsrc (:constructor %make-valsrc)
 362                    (:copier nil))
 363   (value nil)
 364   (source nil))
 365
 366 (defun make-valsrc (value source)
 367   (cond ((equal value source)
 368          source)
 369         ((and (listp value) (eq (car value) 'function))
 370          value)
 371         (t
 372          (%make-valsrc :value value :source source))))
 373
 374 ;;; machinery to provide more meaningful error messages during compilation
 375 (defvar *current-instruction-flavor* nil)
 376 (defun pd-error (fmt &rest args)
 377   (if *current-instruction-flavor*
 378       (error "~@<in printer-definition for ~S(~S): ~3I~:_~?~:>"
 379              (car *current-instruction-flavor*)
 380              (cdr *current-instruction-flavor*)
 381              fmt args)
 382       (apply #'error fmt args)))
 383
 384 ;;; FIXME:
 385 ;;;  1. This should become a utility in SB!INT.
 386 ;;;  2. Arrays and structures and maybe other things are
 387 ;;;     self-evaluating too.
 388 (defun self-evaluating-p (x)
 389   (typecase x
 390     (null t)
 391     (keyword t)
 392     (symbol (eq x t))
 393     (cons nil)
 394     (t t)))
 395
 396 (defun maybe-quote (evalp form)
 397   (if (or evalp (self-evaluating-p form)) form `',form))
 398
 399 ;;; Detect things that obviously don't need wrapping, like
 400 ;;; variable-refs and #'function.
 401 (defun doesnt-need-wrapping-p (form)
 402   (or (symbolp form)
 403       (and (listp form)
 404            (eq (car form) 'function)
 405            (symbolp (cadr form)))))
 406
 407 (defun make-wrapper (form arg-name funargs prefix)
 408   (if (and (listp form)
 409            (eq (car form) 'function))
 410       ;; a function def
 411       (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
 412             (wrapper-args (make-gensym-list (length funargs))))
 413         (values `#',wrapper-name
 414                 `(defun ,wrapper-name ,wrapper-args
 415                    (funcall ,form ,@wrapper-args))))
 416       ;; something else
 417       (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*")))
 418         (values wrapper-name `(defparameter ,wrapper-name ,form)))))
 419
 420 (defun filter-overrides (overrides evalp)
 421   (mapcar #'(lambda (override)
 422               (list* (car override) (cadr override)
 423                      (munge-fun-refs (cddr override) evalp)))
 424           overrides))
 425
 426 (defparameter *arg-function-params*
 427   '((:printer . (value stream dstate))
 428     (:use-label . (value dstate))
 429     (:prefilter . (value dstate))))
 430
 431 (defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix ""))
 432   (let ((params (copy-list params)))
 433     (do ((tail params (cdr tail))
 434          (wrapper-defs nil))
 435         ((null tail)
 436          (values params (nreverse wrapper-defs)))
 437       (let ((fun-arg (assoc (car tail) *arg-function-params*)))
 438         (when fun-arg
 439           (let* ((fun-form (cadr tail))
 440                  (quoted-fun-form `',fun-form))
 441             (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form)))
 442               (multiple-value-bind (access-form wrapper-def-form)
 443                   (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix)
 444                 (setf quoted-fun-form `',access-form)
 445                 (push wrapper-def-form wrapper-defs)))
 446             (if evalp
 447                 (setf (cadr tail)
 448                       `(make-valsrc ,fun-form ,quoted-fun-form))
 449                 (setf (cadr tail)
 450                       fun-form))))))))
 451
 452 (defun gen-args-def-form (overrides format-form &optional (evalp t))
 453   (let ((args-var (gensym)))
 454     `(let ((,args-var (copy-list (format-args ,format-form))))
 455        ,@(mapcar #'(lambda (override)
 456                      (update-args-form args-var
 457                                        `',(car override)
 458                                        (and (cdr override)
 459                                             (cons :value (cdr override)))
 460                                        evalp))
 461                  overrides)
 462        ,args-var)))
 463
 464 (defun gen-printer-def-forms-def-form (base-name
 465                                        uniquified-name
 466                                        def
 467                                        &optional
 468                                        (evalp t))
 469   (declare (type symbol base-name))
 470   (declare (type (or symbol string) uniquified-name))
 471   (destructuring-bind
 472       (format-name
 473        (&rest field-defs)
 474        &optional (printer-form :default)
 475        &key ((:print-name print-name-form) `',base-name) control)
 476       def
 477     (let ((format-var (gensym))
 478           (field-defs (filter-overrides field-defs evalp)))
 479       `(let* ((*current-instruction-flavor* ',(cons base-name format-name))
 480               (,format-var (format-or-lose ',format-name))
 481               (args ,(gen-args-def-form field-defs format-var evalp))
 482               (funcache *disassem-function-cache*))
 483          (multiple-value-bind (printer-fun printer-defun)
 484              (find-printer-fun ',uniquified-name
 485                                ',format-name
 486                                ,(if (eq printer-form :default)
 487                                      `(format-default-printer ,format-var)
 488                                      (maybe-quote evalp printer-form))
 489                                args funcache)
 490            (multiple-value-bind (labeller-fun labeller-defun)
 491                (find-labeller-fun ',uniquified-name args funcache)
 492              (multiple-value-bind (prefilter-fun prefilter-defun)
 493                  (find-prefilter-fun ',uniquified-name
 494                                      ',format-name
 495                                      args
 496                                      funcache)
 497                (multiple-value-bind (mask id)
 498                    (compute-mask-id args)
 499                  (values
 500                   `(make-instruction ',',base-name
 501                                      ',',format-name
 502                                      ,',print-name-form
 503                                      ,(format-length ,format-var)
 504                                      ,mask
 505                                      ,id
 506                                      ,(and printer-fun `#',printer-fun)
 507                                      ,(and labeller-fun `#',labeller-fun)
 508                                      ,(and prefilter-fun `#',prefilter-fun)
 509                                      ,',control)
 510                   `(progn
 511                      ,@(and printer-defun (list printer-defun))
 512                      ,@(and labeller-defun (list labeller-defun))
 513                      ,@(and prefilter-defun (list prefilter-defun))))
 514                  ))))))))
 515
 516 (defun update-args-form (var name-form descrip-forms evalp
 517                              &optional format-length-form)
 518   `(setf ,var
 519          ,(if evalp
 520               `(modify-or-add-arg ,name-form
 521                                   ,var
 522                                   *disassem-arg-types*
 523                                   ,@(and format-length-form
 524                                          `(:format-length
 525                                             ,format-length-form))
 526                                   ,@descrip-forms)
 527               `(apply #'modify-or-add-arg
 528                       ,name-form
 529                       ,var
 530                       *disassem-arg-types*
 531                       ,@(and format-length-form
 532                              `(:format-length ,format-length-form))
 533                       ',descrip-forms))))
 534
 535 (defun format-or-lose (name)
 536   (or (gethash name *disassem-inst-formats*)
 537       (pd-error "unknown instruction format ~S" name)))
 538
 539 ;;; FIXME: needed only at build-the-system time, not in running system
 540 (defmacro define-instruction-format (header &rest fields)
 541   #!+sb-doc
 542   "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def*
 543   Define an instruction format NAME for the disassembler's use. LENGTH is
 544   the length of the format in bits.
 545   Possible FORMAT-KEYs:
 546
 547   :INCLUDE other-format-name
 548       Inherit all arguments and properties of the given format. Any
 549       arguments defined in the current format definition will either modify
 550       the copy of an existing argument (keeping in the same order with
 551       respect to when pre-filter's are called), if it has the same name as
 552       one, or be added to the end.
 553   :DEFAULT-PRINTER printer-list
 554       Use the given PRINTER-LIST as a format to print any instructions of
 555       this format when they don't specify something else.
 556
 557   Each ARG-DEF defines one argument in the format, and is of the form
 558     (Arg-Name {Arg-Key Value}*)
 559
 560   Possible ARG-KEYs (the values are evaluated unless otherwise specified):
 561
 562   :FIELDS byte-spec-list
 563       The argument takes values from these fields in the instruction. If
 564       the list is of length one, then the corresponding value is supplied by
 565       itself; otherwise it is a list of the values. The list may be NIL.
 566   :FIELD byte-spec
 567       The same as :FIELDS (list byte-spec).
 568
 569   :VALUE value
 570       If the argument only has one field, this is the value it should have,
 571       otherwise it's a list of the values of the individual fields. This can
 572       be overridden in an instruction-definition or a format definition
 573       including this one by specifying another, or NIL to indicate that it's
 574       variable.
 575
 576   :SIGN-EXTEND boolean
 577       If non-NIL, the raw value of this argument is sign-extended,
 578       immediately after being extracted from the instruction (before any
 579       prefilters are run, for instance). If the argument has multiple
 580       fields, they are all sign-extended.
 581
 582   :TYPE arg-type-name
 583       Inherit any properties of the given argument-type.
 584
 585   :PREFILTER function
 586       A function which is called (along with all other prefilters, in the
 587       order that their arguments appear in the instruction-format) before
 588       any printing is done, to filter the raw value. Any uses of READ-SUFFIX
 589       must be done inside a prefilter.
 590
 591   :PRINTER function-string-or-vector
 592       A function, string, or vector which is used to print this argument.
 593
 594   :USE-LABEL
 595       If non-NIL, the value of this argument is used as an address, and if
 596       that address occurs inside the disassembled code, it is replaced by a
 597       label. If this is a function, it is called to filter the value."
 598   (gen-format-def-form header fields))
 599
 600 ;;; FIXME: needed only at build-the-system time, not in running system
 601 (defun gen-format-def-form (header descrips &optional (evalp t))
 602   #!+sb-doc
 603   "Generate a form to define an instruction format. See
 604   DEFINE-INSTRUCTION-FORMAT for more info."
 605   (when (atom header)
 606     (setf header (list header)))
 607   (destructuring-bind (name length &key default-printer include) header
 608     (let ((args-var (gensym))
 609           (length-var (gensym))
 610           (all-wrapper-defs nil)
 611           (arg-count 0))
 612       (collect ((arg-def-forms))
 613         (dolist (descrip descrips)
 614           (let ((name (pop descrip)))
 615             (multiple-value-bind (descrip wrapper-defs)
 616                 (munge-fun-refs
 617                  descrip evalp t (format nil "~:@(~A~)-~D" name arg-count))
 618               (arg-def-forms
 619                (update-args-form args-var `',name descrip evalp length-var))
 620               (setf all-wrapper-defs
 621                     (nconc wrapper-defs all-wrapper-defs)))
 622             (incf arg-count)))
 623         `(progn
 624            ,@all-wrapper-defs
 625            (eval-when (:compile-toplevel :execute)
 626              (let ((,length-var ,length)
 627                    (,args-var
 628                     ,(and include
 629                           `(copy-list
 630                             (format-args
 631                              (format-or-lose ,include))))))
 632                ,@(arg-def-forms)
 633                (setf (gethash ',name *disassem-inst-formats*)
 634                      (make-instruction-format
 635                       :name ',name
 636                       :length (bits-to-bytes ,length-var)
 637                       :default-printer ,(maybe-quote evalp default-printer)
 638                       :args ,args-var))
 639                (eval
 640                 `(progn
 641                    ,@(mapcar #'(lambda (arg)
 642                                  (when (arg-fields arg)
 643                                    (gen-arg-access-macro-def-form
 644                                     arg ,args-var ',name)))
 645                              ,args-var))))))))))
 646
 647 ;;; FIXME: probably needed only at build-the-system time, not in
 648 ;;; final target system
 649 (defun modify-or-add-arg (arg-name
 650                           args
 651                           type-table
 652                           &key
 653                           (value nil value-p)
 654                           (type nil type-p)
 655                           (prefilter nil prefilter-p)
 656                           (printer nil printer-p)
 657                           (sign-extend nil sign-extend-p)
 658                           (use-label nil use-label-p)
 659                           (field nil field-p)
 660                           (fields nil fields-p)
 661                           format-length)
 662   (let* ((arg-pos (position arg-name args :key #'arg-name))
 663          (arg
 664           (if (null arg-pos)
 665               (let ((arg (make-argument :name arg-name)))
 666                 (if (null args)
 667                     (setf args (list arg))
 668                     (push arg (cdr (last args))))
 669                 arg)
 670               (setf (nth arg-pos args)
 671                     (copy-structure (nth arg-pos args))))))
 672     (when (and field-p (not fields-p))
 673       (setf fields (list field))
 674       (setf fields-p t))
 675     (when type-p
 676       (set-arg-from-type arg type type-table))
 677     (when value-p
 678       (setf (arg-value arg) value))
 679     (when prefilter-p
 680       (setf (arg-prefilter arg) prefilter))
 681     (when sign-extend-p
 682       (setf (arg-sign-extend-p arg) sign-extend))
 683     (when printer-p
 684       (setf (arg-printer arg) printer))
 685     (when use-label-p
 686       (setf (arg-use-label arg) use-label))
 687     (when fields-p
 688       (when (null format-length)
 689         (error
 690          "~@<in arg ~S: ~3I~:_~
 691           can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
 692          arg-name))
 693       (setf (arg-fields arg)
 694             (mapcar #'(lambda (bytespec)
 695                         (when (> (+ (byte-position bytespec)
 696                                     (byte-size bytespec))
 697                                  format-length)
 698                           (error "~@<in arg ~S: ~3I~:_~
 699                                      The field ~S doesn't fit in an ~
 700                                      instruction-format ~D bits wide.~:>"
 701                                  arg-name
 702                                  bytespec
 703                                  format-length))
 704                         (correct-dchunk-bytespec-for-endianness
 705                          bytespec
 706                          format-length
 707                          sb!c:*backend-byte-order*))
 708                     fields)))
 709     args))
 710
 711 (defun gen-arg-access-macro-def-form (arg args format-name)
 712   (let* ((funstate (make-funstate args))
 713          (arg-val-form (arg-value-form arg funstate :adjusted))
 714          (bindings (make-arg-temp-bindings funstate)))
 715     `(sb!xc:defmacro ,(symbolicate format-name "-" (arg-name arg))
 716          (chunk dstate)
 717        `(let ((chunk ,chunk) (dstate ,dstate))
 718           (declare (ignorable chunk dstate))
 719           (flet ((local-filtered-value (offset)
 720                    (declare (type filtered-value-index offset))
 721                    (aref (dstate-filtered-values dstate) offset))
 722                  (local-extract (bytespec)
 723                    (dchunk-extract chunk bytespec)))
 724             (declare (ignorable #'local-filtered-value #'local-extract)
 725                      (inline local-filtered-value local-extract))
 726             (let* ,',bindings
 727               ,',arg-val-form))))))
 728
 729 (defun arg-value-form (arg funstate
 730                        &optional
 731                        (kind :final)
 732                        (allow-multiple-p (not (eq kind :numeric))))
 733   (let ((forms (gen-arg-forms arg kind funstate)))
 734     (when (and (not allow-multiple-p)
 735                (listp forms)
 736                (/= (length forms) 1))
 737       (pd-error "~S must not have multiple values." arg))
 738     (maybe-listify forms)))
 739
 740 (defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order)
 741   (if (eq byte-order :big-endian)
 742       (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits)))
 743       bs))
 744
 745 (defun make-arg-temp-bindings (funstate)
 746   ;; (Everything is in reverse order, so we just use PUSH, which
 747   ;; results in everything being in the right order at the end.)
 748   (let ((bindings nil))
 749     (dolist (ats (funstate-arg-temps funstate))
 750       (dolist (atk (cdr ats))
 751         (cond ((null (cadr atk)))
 752               ((atom (cadr atk))
 753                (push `(,(cadr atk) ,(cddr atk)) bindings))
 754               (t
 755                (mapc #'(lambda (var form)
 756                          (push `(,var ,form) bindings))
 757                      (cadr atk)
 758                      (cddr atk))))))
 759     bindings))
 760
 761 (defun gen-arg-forms (arg kind funstate)
 762   (multiple-value-bind (vars forms)
 763       (get-arg-temp arg kind funstate)
 764     (when (null forms)
 765       (multiple-value-bind (new-forms single-value-p)
 766           (funcall (find-arg-form-producer kind) arg funstate)
 767         (setq forms new-forms)
 768         (cond ((or single-value-p (atom forms))
 769                (unless (symbolp forms)
 770                  (setq vars (gensym))))
 771               ((every #'symbolp forms)
 772                ;; just use the same as the forms
 773                (setq vars nil))
 774               (t
 775                (setq vars (make-gensym-list (length forms)))))
 776         (set-arg-temps vars forms arg kind funstate)))
 777     (or vars forms)))
 778
 779 (defun maybe-listify (forms)
 780   (cond ((atom forms)
 781          forms)
 782         ((/= (length forms) 1)
 783          `(list ,@forms))
 784         (t
 785          (car forms))))
 786 \f
 787 (defun set-arg-from-type (arg type-name table)
 788   (let ((type-arg (find type-name table :key #'arg-name)))
 789     (when (null type-arg)
 790       (pd-error "unknown argument type: ~S" type-name))
 791     (setf (arg-printer arg) (arg-printer type-arg))
 792     (setf (arg-prefilter arg) (arg-prefilter type-arg))
 793     (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg))
 794     (setf (arg-use-label arg) (arg-use-label type-arg))))
 795
 796 (defun get-arg-temp (arg kind funstate)
 797   (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate))))
 798     (if this-arg-temps
 799         (let ((this-kind-temps
 800                (assoc (canonicalize-arg-form-kind kind)
 801                       (cdr this-arg-temps))))
 802           (values (cadr this-kind-temps) (cddr this-kind-temps)))
 803         (values nil nil))))
 804
 805 (defun set-arg-temps (vars forms arg kind funstate)
 806   (let ((this-arg-temps
 807          (or (assoc arg (funstate-arg-temps funstate))
 808              (car (push (cons arg nil) (funstate-arg-temps funstate)))))
 809         (kind (canonicalize-arg-form-kind kind)))
 810     (let ((this-kind-temps
 811            (or (assoc kind (cdr this-arg-temps))
 812                (car (push (cons kind nil) (cdr this-arg-temps))))))
 813       (setf (cdr this-kind-temps) (cons vars forms)))))
 814 \f
 815 (defmacro define-argument-type (name &rest args)
 816   #!+sb-doc
 817   "DEFINE-ARGUMENT-TYPE Name {Key Value}*
 818   Define a disassembler argument type NAME (which can then be referenced in
 819   another argument definition using the :TYPE argument). &KEY args are:
 820
 821   :SIGN-EXTEND boolean
 822       If non-NIL, the raw value of this argument is sign-extended.
 823
 824   :TYPE arg-type-name
 825       Inherit any properties of given argument-type.
 826
 827   :PREFILTER function
 828       A function which is called (along with all other prefilters, in the
 829       order that their arguments appear in the instruction- format) before
 830       any printing is done, to filter the raw value. Any uses of READ-SUFFIX
 831       must be done inside a prefilter.
 832
 833   :PRINTER function-string-or-vector
 834       A function, string, or vector which is used to print an argument of
 835       this type.
 836
 837   :USE-LABEL
 838       If non-NIL, the value of an argument of this type is used as an
 839       address, and if that address occurs inside the disassembled code, it is
 840       replaced by a label. If this is a function, it is called to filter the
 841       value."
 842   (gen-arg-type-def-form name args))
 843
 844 (defun gen-arg-type-def-form (name args &optional (evalp t))
 845   #!+sb-doc
 846   "Generate a form to define a disassembler argument type. See
 847   DEFINE-ARGUMENT-TYPE for more info."
 848   (multiple-value-bind (args wrapper-defs)
 849       (munge-fun-refs args evalp t name)
 850     `(progn
 851        ,@wrapper-defs
 852        (eval-when (:compile-toplevel :execute)
 853          ,(update-args-form '*disassem-arg-types* `',name args evalp))
 854        ',name)))
 855 \f
 856 (defmacro def-arg-form-kind ((&rest names) &rest inits)
 857   `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
 858      ,@(mapcar #'(lambda (name)
 859                    `(setf (getf *arg-form-kinds* ',name) kind))
 860                names)))
 861
 862 (def-arg-form-kind (:raw)
 863   :producer #'(lambda (arg funstate)
 864                 (declare (ignore funstate))
 865                 (mapcar #'(lambda (bytespec)
 866                             `(the (unsigned-byte ,(byte-size bytespec))
 867                                   (local-extract ',bytespec)))
 868                         (arg-fields arg)))
 869   :checker #'(lambda (new-arg old-arg)
 870                (equal (arg-fields new-arg)
 871                       (arg-fields old-arg))))
 872
 873 (def-arg-form-kind (:sign-extended :unfiltered)
 874   :producer #'(lambda (arg funstate)
 875                 (let ((raw-forms (gen-arg-forms arg :raw funstate)))
 876                   (if (and (arg-sign-extend-p arg) (listp raw-forms))
 877                       (mapcar #'(lambda (form field)
 878                                   `(the (signed-byte ,(byte-size field))
 879                                         (sign-extend ,form
 880                                                      ,(byte-size field))))
 881                               raw-forms
 882                               (arg-fields arg))
 883                       raw-forms)))
 884   :checker #'(lambda (new-arg old-arg)
 885                (equal (arg-sign-extend-p new-arg)
 886                       (arg-sign-extend-p old-arg))))
 887
 888 (defun valsrc-equal (f1 f2)
 889   (if (null f1)
 890       (null f2)
 891       (equal (value-or-source f1)
 892              (value-or-source f2))))
 893
 894 (def-arg-form-kind (:filtering)
 895   :producer #'(lambda (arg funstate)
 896                 (let ((sign-extended-forms
 897                        (gen-arg-forms arg :sign-extended funstate))
 898                       (pf (arg-prefilter arg)))
 899                   (if pf
 900                       (values
 901                        `(local-filter ,(maybe-listify sign-extended-forms)
 902                                       ,(source-form pf))
 903                        t)
 904                       (values sign-extended-forms nil))))
 905   :checker #'(lambda (new-arg old-arg)
 906                (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
 907
 908 (def-arg-form-kind (:filtered :unadjusted)
 909   :producer #'(lambda (arg funstate)
 910                 (let ((pf (arg-prefilter arg)))
 911                   (if pf
 912                       (values `(local-filtered-value ,(arg-position arg)) t)
 913                       (gen-arg-forms arg :sign-extended funstate))))
 914   :checker #'(lambda (new-arg old-arg)
 915                (let ((pf1 (arg-prefilter new-arg))
 916                      (pf2 (arg-prefilter old-arg)))
 917                  (if (null pf1)
 918                      (null pf2)
 919                      (= (arg-position new-arg)
 920                         (arg-position old-arg))))))
 921
 922 (def-arg-form-kind (:adjusted :numeric :unlabelled)
 923   :producer #'(lambda (arg funstate)
 924                 (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
 925                       (use-label (arg-use-label arg)))
 926                   (if (and use-label (not (eq use-label t)))
 927                       (list
 928                        `(adjust-label ,(maybe-listify filtered-forms)
 929                                       ,(source-form use-label)))
 930                       filtered-forms)))
 931   :checker #'(lambda (new-arg old-arg)
 932                (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
 933
 934 (def-arg-form-kind (:labelled :final)
 935   :producer #'(lambda (arg funstate)
 936                 (let ((adjusted-forms
 937                        (gen-arg-forms arg :adjusted funstate))
 938                       (use-label (arg-use-label arg)))
 939                   (if use-label
 940                       (let ((form (maybe-listify adjusted-forms)))
 941                         (if (and (not (eq use-label t))
 942                                  (not (atom adjusted-forms))
 943                                  (/= (Length adjusted-forms) 1))
 944                             (pd-error
 945                              "cannot label a multiple-field argument ~
 946                               unless using a function: ~S" arg)
 947                             `((lookup-label ,form))))
 948                       adjusted-forms)))
 949   :checker #'(lambda (new-arg old-arg)
 950                (let ((lf1 (arg-use-label new-arg))
 951                      (lf2 (arg-use-label old-arg)))
 952                  (if (null lf1) (null lf2) t))))
 953
 954 ;;; This is a bogus kind that's just used to ensure that printers are
 955 ;;; compatible...
 956 (def-arg-form-kind (:printed)
 957   :producer #'(lambda (&rest noise)
 958                 (declare (ignore noise))
 959                 (pd-error "bogus! can't use the :printed value of an arg!"))
 960   :checker #'(lambda (new-arg old-arg)
 961                (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
 962
 963 (defun remember-printer-use (arg funstate)
 964   (set-arg-temps nil nil arg :printed funstate))
 965 \f
 966 ;;; Returns a version of THING suitable for including in an evaluable
 967 ;;; position in some form.
 968 (defun source-form (thing)
 969   (cond ((valsrc-p thing)
 970          (valsrc-source thing))
 971         ((functionp thing)
 972          (pd-error
 973           "can't dump functions, so function ref form must be quoted: ~S"
 974           thing))
 975         ((self-evaluating-p thing)
 976          thing)
 977         ((eq (car thing) 'function)
 978          thing)
 979         (t
 980          `',thing)))
 981
 982 ;;; Return anything but a VALSRC structure.
 983 (defun value-or-source (thing)
 984   (if (valsrc-p thing)
 985       (valsrc-value thing)
 986       thing))
 987 \f
 988 (defstruct (cached-function (:conc-name cached-fun-)
 989                             (:copier nil))
 990   (funstate nil :type (or null funstate))
 991   (constraint nil :type list)
 992   (name nil :type (or null symbol)))
 993
 994 (defun find-cached-function (cached-funs args constraint)
 995   (dolist (cached-fun cached-funs nil)
 996     (let ((funstate (cached-fun-funstate cached-fun)))
 997       (when (and (equal constraint (cached-fun-constraint cached-fun))
 998                  (or (null funstate)
 999                      (funstate-compatible-p funstate args)))
1000         (return cached-fun)))))
1001
1002 (defmacro !with-cached-function ((name-var
1003                                   funstate-var
1004                                   cache
1005                                   cache-slot
1006                                   args
1007                                   &key
1008                                   constraint
1009                                   (stem (required-argument)))
1010                                  &body defun-maker-forms)
1011   (let ((cache-var (gensym))
1012         (constraint-var (gensym)))
1013     `(let* ((,constraint-var ,constraint)
1014             (,cache-var (find-cached-function (,cache-slot ,cache)
1015                                               ,args ,constraint-var)))
1016        (cond (,cache-var
1017               (values (cached-fun-name ,cache-var) nil))
1018              (t
1019               (let* ((,name-var (symbolicate "CACHED-FUN--" ,stem))
1020                      (,funstate-var (make-funstate ,args))
1021                      (,cache-var
1022                       (make-cached-function :name ,name-var
1023                                             :funstate ,funstate-var
1024                                             :constraint ,constraint-var)))
1025                 (values ,name-var
1026                         `(progn
1027                            ,(progn ,@defun-maker-forms)
1028                            (eval-when (:compile-toplevel :execute)
1029                              (push ,,cache-var
1030                                    (,',cache-slot ',,cache)))))))))))
1031 \f
1032 (defun find-printer-fun (%name %format-name printer-source args cache)
1033   (declare (type (or string symbol) %name))
1034   (if (null printer-source)
1035       (values nil nil)
1036       (let ((printer-source (preprocess-printer printer-source args)))
1037         (!with-cached-function
1038            (name funstate cache function-cache-printers args
1039                  :constraint printer-source
1040                  :stem (concatenate 'string
1041                                     (string %name)
1042                                     "-"
1043                                     (symbol-name %format-name)
1044                                     "-PRINTER"))
1045          (make-printer-defun printer-source funstate name)))))
1046 \f
1047 (defun make-printer-defun (source funstate function-name)
1048   (let ((printer-form (compile-printer-list source funstate))
1049         (bindings (make-arg-temp-bindings funstate)))
1050     `(defun ,function-name (chunk inst stream dstate)
1051        (declare (type dchunk chunk)
1052                 (type instruction inst)
1053                 (type stream stream)
1054                 (type disassem-state dstate))
1055        (macrolet ((local-format-arg (arg fmt)
1056                     `(funcall (formatter ,fmt) stream ,arg)))
1057          (flet ((local-tab-to-arg-column ()
1058                   (tab (dstate-argument-column dstate) stream))
1059                 (local-print-name ()
1060                   (princ (inst-print-name inst) stream))
1061                 (local-write-char (ch)
1062                   (write-char ch stream))
1063                 (local-princ (thing)
1064                   (princ thing stream))
1065                 (local-princ16 (thing)
1066                   (princ16 thing stream))
1067                 (local-call-arg-printer (arg printer)
1068                   (funcall printer arg stream dstate))
1069                 (local-call-global-printer (fun)
1070                   (funcall fun chunk inst stream dstate))
1071                 (local-filtered-value (offset)
1072                   (declare (type filtered-value-index offset))
1073                   (aref (dstate-filtered-values dstate) offset))
1074                 (local-extract (bytespec)
1075                   (dchunk-extract chunk bytespec))
1076                 (lookup-label (lab)
1077                   (or (gethash lab (dstate-label-hash dstate))
1078                       lab))
1079                 (adjust-label (val adjust-fun)
1080                   (funcall adjust-fun val dstate)))
1081            (declare (ignorable #'local-tab-to-arg-column
1082                                #'local-print-name
1083                                #'local-princ #'local-princ16
1084                                #'local-write-char
1085                                #'local-call-arg-printer
1086                                #'local-call-global-printer
1087                                #'local-extract
1088                                #'local-filtered-value
1089                                #'lookup-label #'adjust-label)
1090                     (inline local-tab-to-arg-column
1091                             local-princ local-princ16
1092                             local-call-arg-printer local-call-global-printer
1093                             local-filtered-value local-extract
1094                             lookup-label adjust-label))
1095            (let* ,bindings
1096              ,@printer-form))))))
1097 \f
1098 (defun preprocess-test (subj form args)
1099   (multiple-value-bind (subj test)
1100       (if (and (consp form) (symbolp (car form)) (not (keywordp (car form))))
1101           (values (car form) (cdr form))
1102           (values subj form))
1103     (let ((key (if (consp test) (car test) test))
1104           (body (if (consp test) (cdr test) nil)))
1105       (case key
1106         (:constant
1107          (if (null body)
1108              ;; If no supplied constant values, just any constant is ok,
1109              ;; just see whether there's some constant value in the arg.
1110              (not
1111               (null
1112                (arg-value
1113                 (or (find subj args :key #'arg-name)
1114                     (pd-error "unknown argument ~S" subj)))))
1115              ;; Otherwise, defer to run-time.
1116              form))
1117         ((:or :and :not)
1118          (sharing-cons
1119           form
1120           subj
1121           (sharing-cons
1122            test
1123            key
1124            (sharing-mapcar
1125             #'(lambda (sub-test)
1126                 (preprocess-test subj sub-test args))
1127             body))))
1128         (t form)))))
1129
1130 (defun preprocess-conditionals (printer args)
1131   (if (atom printer)
1132       printer
1133       (case (car printer)
1134         (:unless
1135          (preprocess-conditionals
1136           `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer)))
1137           args))
1138         (:when
1139          (preprocess-conditionals `(:cond (,(cdr printer))) args))
1140         (:if
1141          (preprocess-conditionals
1142           `(:cond (,(nth 1 printer) ,(nth 2 printer))
1143                   (t ,(nth 3 printer)))
1144           args))
1145         (:cond
1146          (sharing-cons
1147           printer
1148           :cond
1149           (sharing-mapcar
1150            #'(lambda (clause)
1151                (let ((filtered-body
1152                       (sharing-mapcar
1153                        #'(lambda (sub-printer)
1154                            (preprocess-conditionals sub-printer args))
1155                        (cdr clause))))
1156                  (sharing-cons
1157                   clause
1158                   (preprocess-test (find-first-field-name filtered-body)
1159                                    (car clause)
1160                                    args)
1161                   filtered-body)))
1162            (cdr printer))))
1163         (quote printer)
1164         (t
1165          (sharing-mapcar
1166           #'(lambda (sub-printer)
1167               (preprocess-conditionals sub-printer args))
1168           printer)))))
1169
1170 ;;; Return a version of the disassembly-template PRINTER with
1171 ;;; compile-time tests (e.g. :constant without a value), and any
1172 ;;; :CHOOSE operators resolved properly for the args ARGS.
1173 ;;;
1174 ;;; (:CHOOSE Sub*) simply returns the first Sub in which every field
1175 ;;; reference refers to a valid arg.
1176 (defun preprocess-printer (printer args)
1177   (preprocess-conditionals (preprocess-chooses printer args) args))
1178 \f
1179 ;;; Return the first non-keyword symbol in a depth-first search of TREE.
1180 (defun find-first-field-name (tree)
1181   (cond ((null tree)
1182          nil)
1183         ((and (symbolp tree) (not (keywordp tree)))
1184          tree)
1185         ((atom tree)
1186          nil)
1187         ((eq (car tree) 'quote)
1188          nil)
1189         (t
1190          (or (find-first-field-name (car tree))
1191              (find-first-field-name (cdr tree))))))
1192
1193 (defun preprocess-chooses (printer args)
1194   (cond ((atom printer)
1195          printer)
1196         ((eq (car printer) :choose)
1197          (pick-printer-choice (cdr printer) args))
1198         (t
1199          (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
1200                          printer))))
1201 \f
1202 ;;;; some simple functions that help avoid consing when we're just
1203 ;;;; recursively filtering things that usually don't change
1204
1205 (defun sharing-cons (old-cons car cdr)
1206   #!+sb-doc
1207   "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return
1208   OLD-CONS, otherwise return (cons CAR CDR)."
1209   (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons)))
1210       old-cons
1211       (cons car cdr)))
1212
1213 (defun sharing-mapcar (fun list)
1214   #!+sb-doc
1215   "A simple (one list arg) mapcar that avoids consing up a new list
1216   as long as the results of calling FUN on the elements of LIST are
1217   eq to the original."
1218   (and list
1219        (sharing-cons list
1220                      (funcall fun (car list))
1221                      (sharing-mapcar fun (cdr list)))))
1222 \f
1223 (defun all-arg-refs-relevant-p (printer args)
1224   (cond ((or (null printer) (keywordp printer) (eq printer t))
1225          t)
1226         ((symbolp printer)
1227          (find printer args :key #'arg-name))
1228         ((listp printer)
1229          (every #'(lambda (x) (all-arg-refs-relevant-p x args))
1230                 printer))
1231         (t t)))
1232
1233 (defun pick-printer-choice (choices args)
1234   (dolist (choice choices
1235            (pd-error "no suitable choice found in ~S" choices))
1236     (when (all-arg-refs-relevant-p choice args)
1237       (return choice))))
1238
1239 (defun compile-printer-list (sources funstate)
1240   (unless (null sources)
1241     ;; Coalesce adjacent symbols/strings, and convert to strings if possible,
1242     ;; since they require less consing to write.
1243     (do ((el (car sources) (car sources))
1244          (names nil (cons (strip-quote el) names)))
1245         ((not (string-or-qsym-p el))
1246          (when names
1247            ;; concatenate adjacent strings and symbols
1248            (let ((string
1249                   (apply #'concatenate
1250                          'string
1251                          (mapcar #'string (nreverse names)))))
1252              (push (if (some #'alpha-char-p string)
1253                        `',(make-symbol string) ; Preserve casifying output.
1254                        string)
1255                    sources))))
1256       (pop sources))
1257     (cons (compile-printer-body (car sources) funstate)
1258           (compile-printer-list (cdr sources) funstate))))
1259
1260 (defun compile-printer-body (source funstate)
1261   (cond ((null source)
1262          nil)
1263         ((eq source :name)
1264          `(local-print-name))
1265         ((eq source :tab)
1266          `(local-tab-to-arg-column))
1267         ((keywordp source)
1268          (pd-error "unknown printer element: ~S" source))
1269         ((symbolp source)
1270          (compile-print source funstate))
1271         ((atom source)
1272          `(local-princ ',source))
1273         ((eq (car source) :using)
1274          (unless (or (stringp (cadr source))
1275                      (and (listp (cadr source))
1276                           (eq (caadr source) 'function)))
1277            (pd-error "The first arg to :USING must be a string or #'function."))
1278          (compile-print (caddr source) funstate
1279                         (cons (eval (cadr source)) (cadr source))))
1280         ((eq (car source) :plus-integer)
1281          ;; prints the given field proceed with a + or a -
1282          (let ((form
1283                 (arg-value-form (arg-or-lose (cadr source) funstate)
1284                                 funstate
1285                                 :numeric)))
1286            `(progn
1287               (when (>= ,form 0)
1288                 (local-write-char #\+))
1289               (local-princ ,form))))
1290         ((eq (car source) 'quote)
1291          `(local-princ ,source))
1292         ((eq (car source) 'function)
1293          `(local-call-global-printer ,source))
1294         ((eq (car source) :cond)
1295          `(cond ,@(mapcar #'(lambda (clause)
1296                               `(,(compile-test (find-first-field-name
1297                                                 (cdr clause))
1298                                                (car clause)
1299                                                funstate)
1300                                 ,@(compile-printer-list (cdr clause)
1301                                                         funstate)))
1302                           (cdr source))))
1303         ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
1304         (t
1305          `(progn ,@(compile-printer-list source funstate)))))
1306
1307 (defun compile-print (arg-name funstate &optional printer)
1308   (let* ((arg (arg-or-lose arg-name funstate))
1309          (printer (or printer (arg-printer arg)))
1310          (printer-val (value-or-source printer))
1311          (printer-src (source-form printer)))
1312     (remember-printer-use arg funstate)
1313     (cond ((stringp printer-val)
1314            `(local-format-arg ,(arg-value-form arg funstate) ,printer-val))
1315           ((vectorp printer-val)
1316            `(local-princ
1317              (aref ,printer-src
1318                    ,(arg-value-form arg funstate :numeric))))
1319           ((or (functionp printer-val)
1320                (and (consp printer-val) (eq (car printer-val) 'function)))
1321            `(local-call-arg-printer ,(arg-value-form arg funstate)
1322                                     ,printer-src))
1323           ((or (null printer-val) (eq printer-val t))
1324            `(,(if (arg-use-label arg) 'local-princ16 'local-princ)
1325              ,(arg-value-form arg funstate)))
1326           (t
1327            (pd-error "illegal printer: ~S" printer-src)))))
1328
1329 (defun string-or-qsym-p (thing)
1330   (or (stringp thing)
1331       (and (consp thing)
1332            (eq (car thing) 'quote)
1333            (or (stringp (cadr thing))
1334                (symbolp (cadr thing))))))
1335
1336 (defun strip-quote (thing)
1337   (if (and (consp thing) (eq (car thing) 'quote))
1338       (cadr thing)
1339       thing))
1340 \f
1341 (defun compare-fields-form (val-form-1 val-form-2)
1342   (flet ((listify-fields (fields)
1343            (cond ((symbolp fields) fields)
1344                  ((every #'constantp fields) `',fields)
1345                  (t `(list ,@fields)))))
1346     (cond ((or (symbolp val-form-1) (symbolp val-form-2))
1347            `(equal ,(listify-fields val-form-1)
1348                    ,(listify-fields val-form-2)))
1349           (t
1350            `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
1351                            val-form-1 val-form-2))))))
1352
1353 (defun compile-test (subj test funstate)
1354   (when (and (consp test) (symbolp (car test)) (not (keywordp (car test))))
1355     (setf subj (car test)
1356           test (cdr test)))
1357   (let ((key (if (consp test) (car test) test))
1358         (body (if (consp test) (cdr test) nil)))
1359     (cond ((null key)
1360            nil)
1361           ((eq key t)
1362            t)
1363           ((eq key :constant)
1364            (let* ((arg (arg-or-lose subj funstate))
1365                   (fields (arg-fields arg))
1366                   (consts body))
1367              (when (not (= (length fields) (length consts)))
1368                (pd-error "The number of constants doesn't match number of ~
1369                           fields in: (~S :constant~{ ~S~})"
1370                          subj body))
1371              (compare-fields-form (gen-arg-forms arg :numeric funstate)
1372                                   consts)))
1373           ((eq key :positive)
1374            `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
1375                0))
1376           ((eq key :negative)
1377            `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
1378                0))
1379           ((eq key :same-as)
1380            (let ((arg1 (arg-or-lose subj funstate))
1381                  (arg2 (arg-or-lose (car body) funstate)))
1382              (unless (and (= (length (arg-fields arg1))
1383                              (length (arg-fields arg2)))
1384                           (every #'(lambda (bs1 bs2)
1385                                      (= (byte-size bs1) (byte-size bs2)))
1386                                  (arg-fields arg1)
1387                                  (arg-fields arg2)))
1388                (pd-error "can't compare differently sized fields: ~
1389                           (~S :same-as ~S)" subj (car body)))
1390              (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
1391                                   (gen-arg-forms arg2 :numeric funstate))))
1392           ((eq key :or)
1393            `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
1394                           body)))
1395           ((eq key :and)
1396            `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
1397                            body)))
1398           ((eq key :not)
1399            `(not ,(compile-test subj (car body) funstate)))
1400           ((and (consp key) (null body))
1401            (compile-test subj key funstate))
1402           (t
1403            (pd-error "bogus test-form: ~S" test)))))
1404 \f
1405 (defun find-labeller-fun (%name args cache)
1406   (let ((labelled-fields
1407          (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
1408     (if (null labelled-fields)
1409         (values nil nil)
1410         (!with-cached-function
1411             (name funstate cache function-cache-labellers args
1412              :stem (concatenate 'string "LABELLER-" (string %name))
1413              :constraint labelled-fields)
1414           (let ((labels-form 'labels))
1415             (dolist (arg args)
1416               (when (arg-use-label arg)
1417                 (setf labels-form
1418                       `(let ((labels ,labels-form)
1419                              (addr
1420                               ,(arg-value-form arg funstate :adjusted nil)))
1421                          (if (assoc addr labels :test #'eq)
1422                              labels
1423                              (cons (cons addr nil) labels))))))
1424             `(defun ,name (chunk labels dstate)
1425                (declare (type list labels)
1426                         (type dchunk chunk)
1427                         (type disassem-state dstate))
1428                (flet ((local-filtered-value (offset)
1429                         (declare (type filtered-value-index offset))
1430                         (aref (dstate-filtered-values dstate) offset))
1431                       (local-extract (bytespec)
1432                         (dchunk-extract chunk bytespec))
1433                       (adjust-label (val adjust-fun)
1434                         (funcall adjust-fun val dstate)))
1435                  (declare (ignorable #'local-filtered-value #'local-extract
1436                                      #'adjust-label)
1437                           (inline local-filtered-value local-extract
1438                                   adjust-label))
1439                  (let* ,(make-arg-temp-bindings funstate)
1440                    ,labels-form))))))))
1441
1442 (defun find-prefilter-fun (%name %format-name args cache)
1443   (declare (type (or symbol string) %name %format-name))
1444   (let ((filtered-args (mapcar #'arg-name
1445                                (remove-if-not #'arg-prefilter args))))
1446     (if (null filtered-args)
1447         (values nil nil)
1448         (!with-cached-function
1449             (name funstate cache function-cache-prefilters args
1450              :stem (concatenate 'string
1451                                 (string %name)
1452                                 "-"
1453                                 (string %format-name)
1454                                 "-PREFILTER")
1455              :constraint filtered-args)
1456           (collect ((forms))
1457             (dolist (arg args)
1458               (let ((pf (arg-prefilter arg)))
1459                 (when pf
1460                   (forms
1461                    `(setf (local-filtered-value ,(arg-position arg))
1462                           ,(maybe-listify
1463                             (gen-arg-forms arg :filtering funstate)))))
1464                 ))
1465             `(defun ,name (chunk dstate)
1466                (declare (type dchunk chunk)
1467                         (type disassem-state dstate))
1468                (flet (((setf local-filtered-value) (value offset)
1469                        (declare (type filtered-value-index offset))
1470                        (setf (aref (dstate-filtered-values dstate) offset)
1471                              value))
1472                       (local-filter (value filter)
1473                                     (funcall filter value dstate))
1474                       (local-extract (bytespec)
1475                                      (dchunk-extract chunk bytespec)))
1476                 (declare (ignorable #'local-filter #'local-extract)
1477                          (inline (setf local-filtered-value)
1478                                  local-filter local-extract))
1479                 ;; Use them for side-effects only.
1480                 (let* ,(make-arg-temp-bindings funstate)
1481                   ,@(forms)))))))))
1482 \f
1483 (defun compute-mask-id (args)
1484   (let ((mask dchunk-zero)
1485         (id dchunk-zero))
1486     (dolist (arg args (values mask id))
1487       (let ((av (arg-value arg)))
1488         (when av
1489           (do ((fields (arg-fields arg) (cdr fields))
1490                (values (if (atom av) (list av) av) (cdr values)))
1491               ((null fields))
1492             (let ((field-mask (dchunk-make-mask (car fields))))
1493               (when (/= (dchunk-and mask field-mask) dchunk-zero)
1494                 (pd-error "The field ~S in arg ~S overlaps some other field."
1495                           (car fields)
1496                           (arg-name arg)))
1497               (dchunk-insertf id (car fields) (car values))
1498               (dchunk-orf mask field-mask))))))))
1499
1500 (defun install-inst-flavors (name flavors)
1501   (setf (gethash name *disassem-insts*)
1502         flavors))
1503 \f
1504 #!-sb-fluid (declaim (inline bytes-to-bits))
1505 (declaim (maybe-inline sign-extend aligned-p align tab tab0))
1506
1507 (defun bytes-to-bits (bytes)
1508   (declare (type length bytes))
1509   (* bytes sb!vm:byte-bits))
1510
1511 (defun bits-to-bytes (bits)
1512   (declare (type length bits))
1513   (multiple-value-bind (bytes rbits)
1514       (truncate bits sb!vm:byte-bits)
1515     (when (not (zerop rbits))
1516       (error "~D bits is not a byte-multiple." bits))
1517     bytes))
1518
1519 (defun sign-extend (int size)
1520   (declare (type integer int)
1521            (type (integer 0 128) size))
1522   (if (logbitp (1- size) int)
1523       (dpb int (byte size 0) -1)
1524       int))
1525
1526 ;;; Is ADDRESS aligned on a SIZE byte boundary?
1527 (defun aligned-p (address size)
1528   (declare (type address address)
1529            (type alignment size))
1530   (zerop (logand (1- size) address)))
1531
1532 ;;; Return ADDRESS aligned *upward* to a SIZE byte boundary.
1533 (defun align (address size)
1534   (declare (type address address)
1535            (type alignment size))
1536   (logandc1 (1- size) (+ (1- size) address)))
1537
1538 (defun tab (column stream)
1539   (funcall (formatter "~V,1t") stream column)
1540   nil)
1541 (defun tab0 (column stream)
1542   (funcall (formatter "~V,0t") stream column)
1543   nil)
1544
1545 (defun princ16 (value stream)
1546   (write value :stream stream :radix t :base 16 :escape nil))
1547 \f
1548 (defun read-signed-suffix (length dstate)
1549   (declare (type (member 8 16 32) length)
1550            (type disassem-state dstate)
1551            (optimize (speed 3) (safety 0)))
1552   (sign-extend (read-suffix length dstate) length))
1553
1554 ;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
1555 ;;;
1556 ;;; KLUDGE: The associated run-time machinery for this is in
1557 ;;; target-disassem.lisp (much later). This is here just to make sure
1558 ;;; it's defined before it's used. -- WHN ca. 19990701
1559 (defmacro dstate-get-prop (dstate name)
1560   `(getf (dstate-properties ,dstate) ,name))