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