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