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