src/compiler/disassem.lisp

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