src/compiler/x86/insts.lisp

   1 ;;;; that part of the description of the x86 instruction set (for
   2 ;;;; 80386 and above) which can live on the cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14 ;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
  15 ;;; I wonder whether the separation of the disassembler from the
  16 ;;; virtual machine is valid or adds value.
  17
  18 ;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
  19 (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
  20
  21 (deftype reg () '(unsigned-byte 3))
  22
  23 (def!constant +default-operand-size+ :dword)
  24 \f
  25 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  26
  27 (defun offset-next (value dstate)
  28   (declare (type integer value)
  29            (type sb!disassem:disassem-state dstate))
  30   (+ (sb!disassem:dstate-next-addr dstate) value))
  31
  32 (defparameter *default-address-size*
  33   ;; Actually, :DWORD is the only one really supported.
  34   :dword)
  35
  36 (defparameter *byte-reg-names*
  37   #(al cl dl bl ah ch dh bh))
  38 (defparameter *word-reg-names*
  39   #(ax cx dx bx sp bp si di))
  40 (defparameter *dword-reg-names*
  41   #(eax ecx edx ebx esp ebp esi edi))
  42
  43 (defun print-reg-with-width (value width stream dstate)
  44   (declare (ignore dstate))
  45   (princ (aref (ecase width
  46                  (:byte *byte-reg-names*)
  47                  (:word *word-reg-names*)
  48                  (:dword *dword-reg-names*))
  49                value)
  50          stream)
  51   ;; XXX plus should do some source-var notes
  52   )
  53
  54 (defun print-reg (value stream dstate)
  55   (declare (type reg value)
  56            (type stream stream)
  57            (type sb!disassem:disassem-state dstate))
  58   (print-reg-with-width value
  59                         (sb!disassem:dstate-get-prop dstate 'width)
  60                         stream
  61                         dstate))
  62
  63 (defun print-word-reg (value stream dstate)
  64   (declare (type reg value)
  65            (type stream stream)
  66            (type sb!disassem:disassem-state dstate))
  67   (print-reg-with-width value
  68                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
  69                             +default-operand-size+)
  70                         stream
  71                         dstate))
  72
  73 (defun print-byte-reg (value stream dstate)
  74   (declare (type reg value)
  75            (type stream stream)
  76            (type sb!disassem:disassem-state dstate))
  77   (print-reg-with-width value :byte stream dstate))
  78
  79 (defun print-addr-reg (value stream dstate)
  80   (declare (type reg value)
  81            (type stream stream)
  82            (type sb!disassem:disassem-state dstate))
  83   (print-reg-with-width value *default-address-size* stream dstate))
  84
  85 (defun print-reg/mem (value stream dstate)
  86   (declare (type (or list reg) value)
  87            (type stream stream)
  88            (type sb!disassem:disassem-state dstate))
  89   (if (typep value 'reg)
  90       (print-reg value stream dstate)
  91       (print-mem-access value stream nil dstate)))
  92
  93 ;; Same as print-reg/mem, but prints an explicit size indicator for
  94 ;; memory references.
  95 (defun print-sized-reg/mem (value stream dstate)
  96   (declare (type (or list reg) value)
  97            (type stream stream)
  98            (type sb!disassem:disassem-state dstate))
  99   (if (typep value 'reg)
 100       (print-reg value stream dstate)
 101       (print-mem-access value stream t dstate)))
 102
 103 (defun print-byte-reg/mem (value stream dstate)
 104   (declare (type (or list reg) value)
 105            (type stream stream)
 106            (type sb!disassem:disassem-state dstate))
 107   (if (typep value 'reg)
 108       (print-byte-reg value stream dstate)
 109       (print-mem-access value stream t dstate)))
 110
 111 (defun print-word-reg/mem (value stream dstate)
 112   (declare (type (or list reg) value)
 113            (type stream stream)
 114            (type sb!disassem:disassem-state dstate))
 115   (if (typep value 'reg)
 116       (print-word-reg value stream dstate)
 117       (print-mem-access value stream nil dstate)))
 118
 119 (defun print-label (value stream dstate)
 120   (declare (ignore dstate))
 121   (sb!disassem:princ16 value stream))
 122
 123 ;;; Returns either an integer, meaning a register, or a list of
 124 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
 125 ;;; may be missing or nil to indicate that it's not used or has the
 126 ;;; obvious default value (e.g., 1 for the index-scale).
 127 (defun prefilter-reg/mem (value dstate)
 128   (declare (type list value)
 129            (type sb!disassem:disassem-state dstate))
 130   (let ((mod (car value))
 131         (r/m (cadr value)))
 132     (declare (type (unsigned-byte 2) mod)
 133              (type (unsigned-byte 3) r/m))
 134     (cond ((= mod #b11)
 135            ;; registers
 136            r/m)
 137           ((= r/m #b100)
 138            ;; sib byte
 139            (let ((sib (sb!disassem:read-suffix 8 dstate)))
 140              (declare (type (unsigned-byte 8) sib))
 141              (let ((base-reg (ldb (byte 3 0) sib))
 142                    (index-reg (ldb (byte 3 3) sib))
 143                    (index-scale (ldb (byte 2 6) sib)))
 144                (declare (type (unsigned-byte 3) base-reg index-reg)
 145                         (type (unsigned-byte 2) index-scale))
 146                (let* ((offset
 147                        (case mod
 148                          (#b00
 149                           (if (= base-reg #b101)
 150                               (sb!disassem:read-signed-suffix 32 dstate)
 151                               nil))
 152                          (#b01
 153                           (sb!disassem:read-signed-suffix 8 dstate))
 154                          (#b10
 155                           (sb!disassem:read-signed-suffix 32 dstate)))))
 156                  (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
 157                        offset
 158                        (if (= index-reg #b100) nil index-reg)
 159                        (ash 1 index-scale))))))
 160           ((and (= mod #b00) (= r/m #b101))
 161            (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
 162           ((= mod #b00)
 163            (list r/m))
 164           ((= mod #b01)
 165            (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
 166           (t                            ; (= mod #b10)
 167            (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
 168
 169
 170 ;;; This is a sort of bogus prefilter that just stores the info globally for
 171 ;;; other people to use; it probably never gets printed.
 172 (defun prefilter-width (value dstate)
 173   (setf (sb!disassem:dstate-get-prop dstate 'width)
 174         (if (zerop value)
 175             :byte
 176             (let ((word-width
 177                    ;; set by a prefix instruction
 178                    (or (sb!disassem:dstate-get-prop dstate 'word-width)
 179                        +default-operand-size+)))
 180               (when (not (eql word-width +default-operand-size+))
 181                 ;; Reset it.
 182                 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
 183                       +default-operand-size+))
 184               word-width))))
 185
 186 (defun read-address (value dstate)
 187   (declare (ignore value))              ; always nil anyway
 188   (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
 189
 190 (defun width-bits (width)
 191   (ecase width
 192     (:byte 8)
 193     (:word 16)
 194     (:dword 32)
 195     (:float 32)
 196     (:double 64)))
 197
 198 ) ; EVAL-WHEN
 199 \f
 200 ;;;; disassembler argument types
 201
 202 (sb!disassem:define-arg-type displacement
 203   :sign-extend t
 204   :use-label #'offset-next
 205   :printer (lambda (value stream dstate)
 206              (sb!disassem:maybe-note-assembler-routine value nil dstate)
 207              (print-label value stream dstate)))
 208
 209 (sb!disassem:define-arg-type accum
 210   :printer (lambda (value stream dstate)
 211              (declare (ignore value)
 212                       (type stream stream)
 213                       (type sb!disassem:disassem-state dstate))
 214              (print-reg 0 stream dstate)))
 215
 216 (sb!disassem:define-arg-type word-accum
 217   :printer (lambda (value stream dstate)
 218              (declare (ignore value)
 219                       (type stream stream)
 220                       (type sb!disassem:disassem-state dstate))
 221              (print-word-reg 0 stream dstate)))
 222
 223 (sb!disassem:define-arg-type reg
 224   :printer #'print-reg)
 225
 226 (sb!disassem:define-arg-type addr-reg
 227   :printer #'print-addr-reg)
 228
 229 (sb!disassem:define-arg-type word-reg
 230   :printer #'print-word-reg)
 231
 232 (sb!disassem:define-arg-type imm-addr
 233   :prefilter #'read-address
 234   :printer #'print-label)
 235
 236 (sb!disassem:define-arg-type imm-data
 237   :prefilter (lambda (value dstate)
 238                (declare (ignore value)) ; always nil anyway
 239                (sb!disassem:read-suffix
 240                 (width-bits (sb!disassem:dstate-get-prop dstate 'width))
 241                 dstate)))
 242
 243 (sb!disassem:define-arg-type signed-imm-data
 244   :prefilter (lambda (value dstate)
 245                (declare (ignore value)) ; always nil anyway
 246                (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
 247                  (sb!disassem:read-signed-suffix (width-bits width) dstate))))
 248
 249 (sb!disassem:define-arg-type signed-imm-byte
 250   :prefilter (lambda (value dstate)
 251                (declare (ignore value)) ; always nil anyway
 252                (sb!disassem:read-signed-suffix 8 dstate)))
 253
 254 (sb!disassem:define-arg-type signed-imm-dword
 255   :prefilter (lambda (value dstate)
 256                (declare (ignore value)) ; always nil anyway
 257                (sb!disassem:read-signed-suffix 32 dstate)))
 258
 259 (sb!disassem:define-arg-type imm-word
 260   :prefilter (lambda (value dstate)
 261                (declare (ignore value)) ; always nil anyway
 262                (let ((width
 263                       (or (sb!disassem:dstate-get-prop dstate 'word-width)
 264                           +default-operand-size+)))
 265                  (sb!disassem:read-suffix (width-bits width) dstate))))
 266
 267 ;;; needed for the ret imm16 instruction
 268 (sb!disassem:define-arg-type imm-word-16
 269   :prefilter (lambda (value dstate)
 270                (declare (ignore value)) ; always nil anyway
 271                (sb!disassem:read-suffix 16 dstate)))
 272
 273 (sb!disassem:define-arg-type reg/mem
 274   :prefilter #'prefilter-reg/mem
 275   :printer #'print-reg/mem)
 276 (sb!disassem:define-arg-type sized-reg/mem
 277   ;; Same as reg/mem, but prints an explicit size indicator for
 278   ;; memory references.
 279   :prefilter #'prefilter-reg/mem
 280   :printer #'print-sized-reg/mem)
 281 (sb!disassem:define-arg-type byte-reg/mem
 282   :prefilter #'prefilter-reg/mem
 283   :printer #'print-byte-reg/mem)
 284 (sb!disassem:define-arg-type word-reg/mem
 285   :prefilter #'prefilter-reg/mem
 286   :printer #'print-word-reg/mem)
 287
 288 ;;; added by jrd
 289 (eval-when (:compile-toplevel :load-toplevel :execute)
 290 (defun print-fp-reg (value stream dstate)
 291   (declare (ignore dstate))
 292   (format stream "FR~D" value))
 293 (defun prefilter-fp-reg (value dstate)
 294   ;; just return it
 295   (declare (ignore dstate))
 296   value)
 297 ) ; EVAL-WHEN
 298 (sb!disassem:define-arg-type fp-reg
 299                              :prefilter #'prefilter-fp-reg
 300                              :printer #'print-fp-reg)
 301
 302 (sb!disassem:define-arg-type width
 303   :prefilter #'prefilter-width
 304   :printer (lambda (value stream dstate)
 305              (if;; (zerop value)
 306                  (or (null value)
 307                      (and (numberp value) (zerop value))) ; zzz jrd
 308                  (princ 'b stream)
 309                  (let ((word-width
 310                         ;; set by a prefix instruction
 311                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
 312                             +default-operand-size+)))
 313                    (princ (schar (symbol-name word-width) 0) stream)))))
 314
 315 (eval-when (:compile-toplevel :load-toplevel :execute)
 316 (defparameter *conditions*
 317   '((:o . 0)
 318     (:no . 1)
 319     (:b . 2) (:nae . 2) (:c . 2)
 320     (:nb . 3) (:ae . 3) (:nc . 3)
 321     (:eq . 4) (:e . 4) (:z . 4)
 322     (:ne . 5) (:nz . 5)
 323     (:be . 6) (:na . 6)
 324     (:nbe . 7) (:a . 7)
 325     (:s . 8)
 326     (:ns . 9)
 327     (:p . 10) (:pe . 10)
 328     (:np . 11) (:po . 11)
 329     (:l . 12) (:nge . 12)
 330     (:nl . 13) (:ge . 13)
 331     (:le . 14) (:ng . 14)
 332     (:nle . 15) (:g . 15)))
 333 (defparameter *condition-name-vec*
 334   (let ((vec (make-array 16 :initial-element nil)))
 335     (dolist (cond *conditions*)
 336       (when (null (aref vec (cdr cond)))
 337         (setf (aref vec (cdr cond)) (car cond))))
 338     vec))
 339 ) ; EVAL-WHEN
 340
 341 ;;; Set assembler parameters. (In CMU CL, this was done with
 342 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
 343 (eval-when (:compile-toplevel :load-toplevel :execute)
 344   (setf sb!assem:*assem-scheduler-p* nil))
 345
 346 (sb!disassem:define-arg-type condition-code
 347   :printer *condition-name-vec*)
 348
 349 (defun conditional-opcode (condition)
 350   (cdr (assoc condition *conditions* :test #'eq)))
 351 \f
 352 ;;;; disassembler instruction formats
 353
 354 (eval-when (:compile-toplevel :execute)
 355   (defun swap-if (direction field1 separator field2)
 356     `(:if (,direction :constant 0)
 357           (,field1 ,separator ,field2)
 358           (,field2 ,separator ,field1))))
 359
 360 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
 361   (op    :field (byte 8 0))
 362   ;; optional fields
 363   (accum :type 'accum)
 364   (imm))
 365
 366 (sb!disassem:define-instruction-format (simple 8)
 367   (op    :field (byte 7 1))
 368   (width :field (byte 1 0) :type 'width)
 369   ;; optional fields
 370   (accum :type 'accum)
 371   (imm))
 372
 373 ;;; Same as simple, but with direction bit
 374 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
 375   (op :field (byte 6 2))
 376   (dir :field (byte 1 1)))
 377
 378 ;;; Same as simple, but with the immediate value occurring by default,
 379 ;;; and with an appropiate printer.
 380 (sb!disassem:define-instruction-format (accum-imm 8
 381                                      :include 'simple
 382                                      :default-printer '(:name
 383                                                         :tab accum ", " imm))
 384   (imm :type 'imm-data))
 385
 386 (sb!disassem:define-instruction-format (reg-no-width 8
 387                                      :default-printer '(:name :tab reg))
 388   (op    :field (byte 5 3))
 389   (reg   :field (byte 3 0) :type 'word-reg)
 390   ;; optional fields
 391   (accum :type 'word-accum)
 392   (imm))
 393
 394 ;;; adds a width field to reg-no-width
 395 (sb!disassem:define-instruction-format (reg 8
 396                                         :default-printer '(:name :tab reg))
 397   (op    :field (byte 4 4))
 398   (width :field (byte 1 3) :type 'width)
 399   (reg   :field (byte 3 0) :type 'reg)
 400   ;; optional fields
 401   (accum :type 'accum)
 402   (imm)
 403   )
 404
 405 ;;; Same as reg, but with direction bit
 406 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
 407   (op  :field (byte 3 5))
 408   (dir :field (byte 1 4)))
 409
 410 (sb!disassem:define-instruction-format (two-bytes 16
 411                                         :default-printer '(:name))
 412   (op :fields (list (byte 8 0) (byte 8 8))))
 413
 414 (sb!disassem:define-instruction-format (reg-reg/mem 16
 415                                         :default-printer
 416                                         `(:name :tab reg ", " reg/mem))
 417   (op      :field (byte 7 1))
 418   (width   :field (byte 1 0)    :type 'width)
 419   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 420                                 :type 'reg/mem)
 421   (reg     :field (byte 3 11)   :type 'reg)
 422   ;; optional fields
 423   (imm))
 424
 425 ;;; same as reg-reg/mem, but with direction bit
 426 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
 427                                         :include 'reg-reg/mem
 428                                         :default-printer
 429                                         `(:name
 430                                           :tab
 431                                           ,(swap-if 'dir 'reg/mem ", " 'reg)))
 432   (op  :field (byte 6 2))
 433   (dir :field (byte 1 1)))
 434
 435 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
 436 (sb!disassem:define-instruction-format (reg/mem 16
 437                                         :default-printer '(:name :tab reg/mem))
 438   (op      :fields (list (byte 7 1) (byte 3 11)))
 439   (width   :field (byte 1 0)    :type 'width)
 440   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 441                                 :type 'sized-reg/mem)
 442   ;; optional fields
 443   (imm))
 444
 445 ;;; Same as reg/mem, but with the immediate value occurring by default,
 446 ;;; and with an appropiate printer.
 447 (sb!disassem:define-instruction-format (reg/mem-imm 16
 448                                         :include 'reg/mem
 449                                         :default-printer
 450                                         '(:name :tab reg/mem ", " imm))
 451   (reg/mem :type 'sized-reg/mem)
 452   (imm     :type 'imm-data))
 453
 454 ;;; Same as reg/mem, but with using the accumulator in the default printer
 455 (sb!disassem:define-instruction-format
 456     (accum-reg/mem 16
 457      :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
 458   (reg/mem :type 'reg/mem)              ; don't need a size
 459   (accum :type 'accum))
 460
 461 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
 462 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
 463                                         :default-printer
 464                                         `(:name :tab reg ", " reg/mem))
 465   (prefix  :field (byte 8 0)    :value #b00001111)
 466   (op      :field (byte 7 9))
 467   (width   :field (byte 1 8)    :type 'width)
 468   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 469                                 :type 'reg/mem)
 470   (reg     :field (byte 3 19)   :type 'reg)
 471   ;; optional fields
 472   (imm))
 473
 474 ;;; Same as reg/mem, but with a prefix of #b00001111
 475 (sb!disassem:define-instruction-format (ext-reg/mem 24
 476                                         :default-printer '(:name :tab reg/mem))
 477   (prefix  :field (byte 8 0)    :value #b00001111)
 478   (op      :fields (list (byte 7 9) (byte 3 19)))
 479   (width   :field (byte 1 8)    :type 'width)
 480   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 481                                 :type 'sized-reg/mem)
 482   ;; optional fields
 483   (imm))
 484
 485 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
 486                                         :include 'ext-reg/mem
 487                                         :default-printer
 488                                         '(:name :tab reg/mem ", " imm))
 489   (imm :type 'imm-data))
 490 \f
 491 ;;;; This section was added by jrd, for fp instructions.
 492
 493 ;;; regular fp inst to/from registers/memory
 494 (sb!disassem:define-instruction-format (floating-point 16
 495                                         :default-printer
 496                                         `(:name :tab reg/mem))
 497   (prefix :field (byte 5 3) :value #b11011)
 498   (op     :fields (list (byte 3 0) (byte 3 11)))
 499   (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
 500
 501 ;;; fp insn to/from fp reg
 502 (sb!disassem:define-instruction-format (floating-point-fp 16
 503                                         :default-printer `(:name :tab fp-reg))
 504   (prefix :field (byte 5 3) :value #b11011)
 505   (suffix :field (byte 2 14) :value #b11)
 506   (op     :fields (list (byte 3 0) (byte 3 11)))
 507   (fp-reg :field (byte 3 8) :type 'fp-reg))
 508
 509 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
 510 (sb!disassem:define-instruction-format
 511  (floating-point-fp-d 16
 512    :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
 513   (prefix :field (byte 5 3) :value #b11011)
 514   (suffix :field (byte 2 14) :value #b11)
 515   (op     :fields (list (byte 2 0) (byte 3 11)))
 516   (d      :field (byte 1 2))
 517   (fp-reg :field (byte 3 8) :type 'fp-reg))
 518
 519
 520 ;;; (added by (?) pfw)
 521 ;;; fp no operand isns
 522 (sb!disassem:define-instruction-format (floating-point-no 16
 523                                       :default-printer '(:name))
 524   (prefix :field (byte 8  0) :value #b11011001)
 525   (suffix :field (byte 3 13) :value #b111)
 526   (op     :field (byte 5  8)))
 527
 528 (sb!disassem:define-instruction-format (floating-point-3 16
 529                                       :default-printer '(:name))
 530   (prefix :field (byte 5 3) :value #b11011)
 531   (suffix :field (byte 2 14) :value #b11)
 532   (op     :fields (list (byte 3 0) (byte 6 8))))
 533
 534 (sb!disassem:define-instruction-format (floating-point-5 16
 535                                       :default-printer '(:name))
 536   (prefix :field (byte 8  0) :value #b11011011)
 537   (suffix :field (byte 3 13) :value #b111)
 538   (op     :field (byte 5  8)))
 539
 540 (sb!disassem:define-instruction-format (floating-point-st 16
 541                                       :default-printer '(:name))
 542   (prefix :field (byte 8  0) :value #b11011111)
 543   (suffix :field (byte 3 13) :value #b111)
 544   (op     :field (byte 5  8)))
 545
 546 (sb!disassem:define-instruction-format (string-op 8
 547                                      :include 'simple
 548                                      :default-printer '(:name width)))
 549
 550 (sb!disassem:define-instruction-format (short-cond-jump 16)
 551   (op    :field (byte 4 4))
 552   (cc    :field (byte 4 0) :type 'condition-code)
 553   (label :field (byte 8 8) :type 'displacement))
 554
 555 (sb!disassem:define-instruction-format (short-jump 16
 556                                      :default-printer '(:name :tab label))
 557   (const :field (byte 4 4) :value #b1110)
 558   (op    :field (byte 4 0))
 559   (label :field (byte 8 8) :type 'displacement))
 560
 561 (sb!disassem:define-instruction-format (near-cond-jump 16)
 562   (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
 563   (cc    :field (byte 4 8) :type 'condition-code)
 564   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 565   ;; long, so we fake it by using a prefilter to read the offset.
 566   (label :type 'displacement
 567          :prefilter (lambda (value dstate)
 568                       (declare (ignore value)) ; always nil anyway
 569                       (sb!disassem:read-signed-suffix 32 dstate))))
 570
 571 (sb!disassem:define-instruction-format (near-jump 8
 572                                      :default-printer '(:name :tab label))
 573   (op    :field (byte 8 0))
 574   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 575   ;; long, so we fake it by using a prefilter to read the address.
 576   (label :type 'displacement
 577          :prefilter (lambda (value dstate)
 578                       (declare (ignore value)) ; always nil anyway
 579                       (sb!disassem:read-signed-suffix 32 dstate))))
 580
 581
 582 (sb!disassem:define-instruction-format (cond-set 24
 583                                      :default-printer '('set cc :tab reg/mem))
 584   (prefix :field (byte 8 0) :value #b00001111)
 585   (op    :field (byte 4 12) :value #b1001)
 586   (cc    :field (byte 4 8) :type 'condition-code)
 587   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 588            :type 'byte-reg/mem)
 589   (reg     :field (byte 3 19)   :value #b000))
 590
 591 (sb!disassem:define-instruction-format (enter-format 32
 592                                      :default-printer '(:name
 593                                                         :tab disp
 594                                                         (:unless (:constant 0)
 595                                                           ", " level)))
 596   (op :field (byte 8 0))
 597   (disp :field (byte 16 8))
 598   (level :field (byte 8 24)))
 599
 600 ;;; Single byte instruction with an immediate byte argument.
 601 (sb!disassem:define-instruction-format (byte-imm 16
 602                                      :default-printer '(:name :tab code))
 603  (op :field (byte 8 0))
 604  (code :field (byte 8 8)))
 605 \f
 606 ;;;; primitive emitters
 607
 608 (define-bitfield-emitter emit-word 16
 609   (byte 16 0))
 610
 611 (define-bitfield-emitter emit-dword 32
 612   (byte 32 0))
 613
 614 (define-bitfield-emitter emit-byte-with-reg 8
 615   (byte 5 3) (byte 3 0))
 616
 617 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
 618   (byte 2 6) (byte 3 3) (byte 3 0))
 619
 620 (define-bitfield-emitter emit-sib-byte 8
 621   (byte 2 6) (byte 3 3) (byte 3 0))
 622 \f
 623 ;;;; fixup emitters
 624
 625 (defun emit-absolute-fixup (segment fixup)
 626   (note-fixup segment :absolute fixup)
 627   (let ((offset (fixup-offset fixup)))
 628     (if (label-p offset)
 629         (emit-back-patch segment
 630                          4 ; FIXME: sb!vm:n-word-bytes
 631                          (lambda (segment posn)
 632                            (declare (ignore posn))
 633                            (emit-dword segment
 634                                        (- (+ (component-header-length)
 635                                              (or (label-position offset)
 636                                                  0))
 637                                           other-pointer-lowtag))))
 638         (emit-dword segment (or offset 0)))))
 639
 640 (defun emit-relative-fixup (segment fixup)
 641   (note-fixup segment :relative fixup)
 642   (emit-dword segment (or (fixup-offset fixup) 0)))
 643 \f
 644 ;;;; the effective-address (ea) structure
 645
 646 (defun reg-tn-encoding (tn)
 647   (declare (type tn tn))
 648   (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
 649   (let ((offset (tn-offset tn)))
 650     (logior (ash (logand offset 1) 2)
 651             (ash offset -1))))
 652
 653 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
 654                (:copier nil))
 655   (size nil :type (member :byte :word :dword))
 656   (base nil :type (or tn null))
 657   (index nil :type (or tn null))
 658   (scale 1 :type (member 1 2 4 8))
 659   (disp 0 :type (or (signed-byte 32) fixup)))
 660 (def!method print-object ((ea ea) stream)
 661   (cond ((or *print-escape* *print-readably*)
 662          (print-unreadable-object (ea stream :type t)
 663            (format stream
 664                    "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
 665                    (ea-size ea)
 666                    (ea-base ea)
 667                    (ea-index ea)
 668                    (let ((scale (ea-scale ea)))
 669                      (if (= scale 1) nil scale))
 670                    (ea-disp ea))))
 671         (t
 672          (format stream "~A PTR [" (symbol-name (ea-size ea)))
 673          (when (ea-base ea)
 674            (write-string (sb!c::location-print-name (ea-base ea)) stream)
 675            (when (ea-index ea)
 676              (write-string "+" stream)))
 677          (when (ea-index ea)
 678            (write-string (sb!c::location-print-name (ea-index ea)) stream))
 679          (unless (= (ea-scale ea) 1)
 680            (format stream "*~A" (ea-scale ea)))
 681          (typecase (ea-disp ea)
 682            (null)
 683            (integer
 684             (format stream "~@D" (ea-disp ea)))
 685            (t
 686             (format stream "+~A" (ea-disp ea))))
 687          (write-char #\] stream))))
 688
 689 (defun emit-ea (segment thing reg &optional allow-constants)
 690   (etypecase thing
 691     (tn
 692      (ecase (sb-name (sc-sb (tn-sc thing)))
 693        (registers
 694         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
 695        (stack
 696         ;; Convert stack tns into an index off of EBP.
 697         (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
 698           (cond ((< -128 disp 127)
 699                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
 700                  (emit-byte segment disp))
 701                 (t
 702                  (emit-mod-reg-r/m-byte segment #b10 reg #b101)
 703                  (emit-dword segment disp)))))
 704        (constant
 705         (unless allow-constants
 706           (error
 707            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
 708         (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 709         (emit-absolute-fixup segment
 710                              (make-fixup nil
 711                                          :code-object
 712                                          (- (* (tn-offset thing) n-word-bytes)
 713                                             other-pointer-lowtag))))))
 714     (ea
 715      (let* ((base (ea-base thing))
 716             (index (ea-index thing))
 717             (scale (ea-scale thing))
 718             (disp (ea-disp thing))
 719             (mod (cond ((or (null base)
 720                             (and (eql disp 0)
 721                                  (not (= (reg-tn-encoding base) #b101))))
 722                         #b00)
 723                        ((and (fixnump disp) (<= -128 disp 127))
 724                         #b01)
 725                        (t
 726                         #b10)))
 727             (r/m (cond (index #b100)
 728                        ((null base) #b101)
 729                        (t (reg-tn-encoding base)))))
 730        (emit-mod-reg-r/m-byte segment mod reg r/m)
 731        (when (= r/m #b100)
 732          (let ((ss (1- (integer-length scale)))
 733                (index (if (null index)
 734                           #b100
 735                           (let ((index (reg-tn-encoding index)))
 736                             (if (= index #b100)
 737                                 (error "can't index off of ESP")
 738                                 index))))
 739                (base (if (null base)
 740                          #b101
 741                          (reg-tn-encoding base))))
 742            (emit-sib-byte segment ss index base)))
 743        (cond ((= mod #b01)
 744               (emit-byte segment disp))
 745              ((or (= mod #b10) (null base))
 746               (if (fixup-p disp)
 747                   (emit-absolute-fixup segment disp)
 748                   (emit-dword segment disp))))))
 749     (fixup
 750      (emit-mod-reg-r/m-byte segment #b00 reg #b101)
 751      (emit-absolute-fixup segment thing))))
 752
 753 (defun fp-reg-tn-p (thing)
 754   (and (tn-p thing)
 755        (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
 756
 757 ;;; like the above, but for fp-instructions--jrd
 758 (defun emit-fp-op (segment thing op)
 759   (if (fp-reg-tn-p thing)
 760       (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
 761                                                  (byte 3 0)
 762                                                  #b11000000)))
 763     (emit-ea segment thing op)))
 764
 765 (defun byte-reg-p (thing)
 766   (and (tn-p thing)
 767        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 768        (member (sc-name (tn-sc thing)) *byte-sc-names*)
 769        t))
 770
 771 (defun byte-ea-p (thing)
 772   (typecase thing
 773     (ea (eq (ea-size thing) :byte))
 774     (tn
 775      (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
 776     (t nil)))
 777
 778 (defun word-reg-p (thing)
 779   (and (tn-p thing)
 780        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 781        (member (sc-name (tn-sc thing)) *word-sc-names*)
 782        t))
 783
 784 (defun word-ea-p (thing)
 785   (typecase thing
 786     (ea (eq (ea-size thing) :word))
 787     (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
 788     (t nil)))
 789
 790 (defun dword-reg-p (thing)
 791   (and (tn-p thing)
 792        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
 793        (member (sc-name (tn-sc thing)) *dword-sc-names*)
 794        t))
 795
 796 (defun dword-ea-p (thing)
 797   (typecase thing
 798     (ea (eq (ea-size thing) :dword))
 799     (tn
 800      (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
 801     (t nil)))
 802
 803 (defun register-p (thing)
 804   (and (tn-p thing)
 805        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
 806
 807 (defun accumulator-p (thing)
 808   (and (register-p thing)
 809        (= (tn-offset thing) 0)))
 810 \f
 811 ;;;; utilities
 812
 813 (def!constant +operand-size-prefix-byte+ #b01100110)
 814
 815 (defun maybe-emit-operand-size-prefix (segment size)
 816   (unless (or (eq size :byte) (eq size +default-operand-size+))
 817     (emit-byte segment +operand-size-prefix-byte+)))
 818
 819 (defun operand-size (thing)
 820   (typecase thing
 821     (tn
 822      ;; FIXME: might as well be COND instead of having to use #. readmacro
 823      ;; to hack up the code
 824      (case (sc-name (tn-sc thing))
 825        (#.*dword-sc-names*
 826         :dword)
 827        (#.*word-sc-names*
 828         :word)
 829        (#.*byte-sc-names*
 830         :byte)
 831        ;; added by jrd: float-registers is a separate size (?)
 832        (#.*float-sc-names*
 833         :float)
 834        (#.*double-sc-names*
 835         :double)
 836        (t
 837         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
 838     (ea
 839      (ea-size thing))
 840     (t
 841      nil)))
 842
 843 (defun matching-operand-size (dst src)
 844   (let ((dst-size (operand-size dst))
 845         (src-size (operand-size src)))
 846     (if dst-size
 847         (if src-size
 848             (if (eq dst-size src-size)
 849                 dst-size
 850                 (error "size mismatch: ~S is a ~S and ~S is a ~S."
 851                        dst dst-size src src-size))
 852             dst-size)
 853         (if src-size
 854             src-size
 855             (error "can't tell the size of either ~S or ~S" dst src)))))
 856
 857 (defun emit-sized-immediate (segment size value)
 858   (ecase size
 859     (:byte
 860      (emit-byte segment value))
 861     (:word
 862      (emit-word segment value))
 863     (:dword
 864      (emit-dword segment value))))
 865 \f
 866 ;;;; general data transfer
 867
 868 (define-instruction mov (segment dst src)
 869   ;; immediate to register
 870   (:printer reg ((op #b1011) (imm nil :type 'imm-data))
 871             '(:name :tab reg ", " imm))
 872   ;; absolute mem to/from accumulator
 873   (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
 874             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
 875   ;; register to/from register/memory
 876   (:printer reg-reg/mem-dir ((op #b100010)))
 877   ;; immediate to register/memory
 878   (:printer reg/mem-imm ((op '(#b1100011 #b000))))
 879
 880   (:emitter
 881    (let ((size (matching-operand-size dst src)))
 882      (maybe-emit-operand-size-prefix segment size)
 883      (cond ((register-p dst)
 884             (cond ((integerp src)
 885                    (emit-byte-with-reg segment
 886                                        (if (eq size :byte)
 887                                            #b10110
 888                                            #b10111)
 889                                        (reg-tn-encoding dst))
 890                    (emit-sized-immediate segment size src))
 891                   ((and (fixup-p src) (accumulator-p dst))
 892                    (emit-byte segment
 893                               (if (eq size :byte)
 894                                   #b10100000
 895                                   #b10100001))
 896                    (emit-absolute-fixup segment src))
 897                   (t
 898                    (emit-byte segment
 899                               (if (eq size :byte)
 900                                   #b10001010
 901                                   #b10001011))
 902                    (emit-ea segment src (reg-tn-encoding dst) t))))
 903            ((and (fixup-p dst) (accumulator-p src))
 904             (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
 905             (emit-absolute-fixup segment dst))
 906            ((integerp src)
 907             (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
 908             (emit-ea segment dst #b000)
 909             (emit-sized-immediate segment size src))
 910            ((register-p src)
 911             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
 912             (emit-ea segment dst (reg-tn-encoding src)))
 913            ((fixup-p src)
 914             (aver (eq size :dword))
 915             (emit-byte segment #b11000111)
 916             (emit-ea segment dst #b000)
 917             (emit-absolute-fixup segment src))
 918            (t
 919             (error "bogus arguments to MOV: ~S ~S" dst src))))))
 920
 921 (defun emit-move-with-extension (segment dst src opcode)
 922   (aver (register-p dst))
 923   (let ((dst-size (operand-size dst))
 924         (src-size (operand-size src)))
 925     (ecase dst-size
 926       (:word
 927        (aver (eq src-size :byte))
 928        (maybe-emit-operand-size-prefix segment :word)
 929        (emit-byte segment #b00001111)
 930        (emit-byte segment opcode)
 931        (emit-ea segment src (reg-tn-encoding dst)))
 932       (:dword
 933        (ecase src-size
 934          (:byte
 935           (maybe-emit-operand-size-prefix segment :dword)
 936           (emit-byte segment #b00001111)
 937           (emit-byte segment opcode)
 938           (emit-ea segment src (reg-tn-encoding dst)))
 939          (:word
 940           (emit-byte segment #b00001111)
 941           (emit-byte segment (logior opcode 1))
 942           (emit-ea segment src (reg-tn-encoding dst))))))))
 943
 944 (define-instruction movsx (segment dst src)
 945   (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
 946   (:emitter (emit-move-with-extension segment dst src #b10111110)))
 947
 948 (define-instruction movzx (segment dst src)
 949   (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
 950   (:emitter (emit-move-with-extension segment dst src #b10110110)))
 951
 952 (define-instruction push (segment src)
 953   ;; register
 954   (:printer reg-no-width ((op #b01010)))
 955   ;; register/memory
 956   (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
 957   ;; immediate
 958   (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
 959             '(:name :tab imm))
 960   (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
 961             '(:name :tab imm))
 962   ;; ### segment registers?
 963
 964   (:emitter
 965    (cond ((integerp src)
 966           (cond ((<= -128 src 127)
 967                  (emit-byte segment #b01101010)
 968                  (emit-byte segment src))
 969                 (t
 970                  (emit-byte segment #b01101000)
 971                  (emit-dword segment src))))
 972          ((fixup-p src)
 973           ;; Interpret the fixup as an immediate dword to push.
 974           (emit-byte segment #b01101000)
 975           (emit-absolute-fixup segment src))
 976          (t
 977           (let ((size (operand-size src)))
 978             (aver (not (eq size :byte)))
 979             (maybe-emit-operand-size-prefix segment size)
 980             (cond ((register-p src)
 981                    (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
 982                   (t
 983                    (emit-byte segment #b11111111)
 984                    (emit-ea segment src #b110 t))))))))
 985
 986 (define-instruction pusha (segment)
 987   (:printer byte ((op #b01100000)))
 988   (:emitter
 989    (emit-byte segment #b01100000)))
 990
 991 (define-instruction pop (segment dst)
 992   (:printer reg-no-width ((op #b01011)))
 993   (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
 994   (:emitter
 995    (let ((size (operand-size dst)))
 996      (aver (not (eq size :byte)))
 997      (maybe-emit-operand-size-prefix segment size)
 998      (cond ((register-p dst)
 999             (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1000            (t
1001             (emit-byte segment #b10001111)
1002             (emit-ea segment dst #b000))))))
1003
1004 (define-instruction popa (segment)
1005   (:printer byte ((op #b01100001)))
1006   (:emitter
1007    (emit-byte segment #b01100001)))
1008
1009 (define-instruction xchg (segment operand1 operand2)
1010   ;; Register with accumulator.
1011   (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1012   ;; Register/Memory with Register.
1013   (:printer reg-reg/mem ((op #b1000011)))
1014   (:emitter
1015    (let ((size (matching-operand-size operand1 operand2)))
1016      (maybe-emit-operand-size-prefix segment size)
1017      (labels ((xchg-acc-with-something (acc something)
1018                 (if (and (not (eq size :byte)) (register-p something))
1019                     (emit-byte-with-reg segment
1020                                         #b10010
1021                                         (reg-tn-encoding something))
1022                     (xchg-reg-with-something acc something)))
1023               (xchg-reg-with-something (reg something)
1024                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1025                 (emit-ea segment something (reg-tn-encoding reg))))
1026        (cond ((accumulator-p operand1)
1027               (xchg-acc-with-something operand1 operand2))
1028              ((accumulator-p operand2)
1029               (xchg-acc-with-something operand2 operand1))
1030              ((register-p operand1)
1031               (xchg-reg-with-something operand1 operand2))
1032              ((register-p operand2)
1033               (xchg-reg-with-something operand2 operand1))
1034              (t
1035               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1036
1037 (define-instruction lea (segment dst src)
1038   (:printer reg-reg/mem ((op #b1000110) (width 1)))
1039   (:emitter
1040    (aver (dword-reg-p dst))
1041    (emit-byte segment #b10001101)
1042    (emit-ea segment src (reg-tn-encoding dst))))
1043
1044 (define-instruction cmpxchg (segment dst src)
1045   ;; Register/Memory with Register.
1046   (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1047   (:emitter
1048    (aver (register-p src))
1049    (let ((size (matching-operand-size src dst)))
1050      (maybe-emit-operand-size-prefix segment size)
1051      (emit-byte segment #b00001111)
1052      (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1053      (emit-ea segment dst (reg-tn-encoding src)))))
1054
1055 \f
1056
1057 (define-instruction fs-segment-prefix (segment)
1058   (:emitter
1059    (emit-byte segment #x64)))
1060
1061 ;;;; flag control instructions
1062
1063 ;;; CLC -- Clear Carry Flag.
1064 (define-instruction clc (segment)
1065   (:printer byte ((op #b11111000)))
1066   (:emitter
1067    (emit-byte segment #b11111000)))
1068
1069 ;;; CLD -- Clear Direction Flag.
1070 (define-instruction cld (segment)
1071   (:printer byte ((op #b11111100)))
1072   (:emitter
1073    (emit-byte segment #b11111100)))
1074
1075 ;;; CLI -- Clear Iterrupt Enable Flag.
1076 (define-instruction cli (segment)
1077   (:printer byte ((op #b11111010)))
1078   (:emitter
1079    (emit-byte segment #b11111010)))
1080
1081 ;;; CMC -- Complement Carry Flag.
1082 (define-instruction cmc (segment)
1083   (:printer byte ((op #b11110101)))
1084   (:emitter
1085    (emit-byte segment #b11110101)))
1086
1087 ;;; LAHF -- Load AH into flags.
1088 (define-instruction lahf (segment)
1089   (:printer byte ((op #b10011111)))
1090   (:emitter
1091    (emit-byte segment #b10011111)))
1092
1093 ;;; POPF -- Pop flags.
1094 (define-instruction popf (segment)
1095   (:printer byte ((op #b10011101)))
1096   (:emitter
1097    (emit-byte segment #b10011101)))
1098
1099 ;;; PUSHF -- push flags.
1100 (define-instruction pushf (segment)
1101   (:printer byte ((op #b10011100)))
1102   (:emitter
1103    (emit-byte segment #b10011100)))
1104
1105 ;;; SAHF -- Store AH into flags.
1106 (define-instruction sahf (segment)
1107   (:printer byte ((op #b10011110)))
1108   (:emitter
1109    (emit-byte segment #b10011110)))
1110
1111 ;;; STC -- Set Carry Flag.
1112 (define-instruction stc (segment)
1113   (:printer byte ((op #b11111001)))
1114   (:emitter
1115    (emit-byte segment #b11111001)))
1116
1117 ;;; STD -- Set Direction Flag.
1118 (define-instruction std (segment)
1119   (:printer byte ((op #b11111101)))
1120   (:emitter
1121    (emit-byte segment #b11111101)))
1122
1123 ;;; STI -- Set Interrupt Enable Flag.
1124 (define-instruction sti (segment)
1125   (:printer byte ((op #b11111011)))
1126   (:emitter
1127    (emit-byte segment #b11111011)))
1128 \f
1129 ;;;; arithmetic
1130
1131 (defun emit-random-arith-inst (name segment dst src opcode
1132                                     &optional allow-constants)
1133   (let ((size (matching-operand-size dst src)))
1134     (maybe-emit-operand-size-prefix segment size)
1135     (cond
1136      ((integerp src)
1137       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1138              (emit-byte segment #b10000011)
1139              (emit-ea segment dst opcode allow-constants)
1140              (emit-byte segment src))
1141             ((accumulator-p dst)
1142              (emit-byte segment
1143                         (dpb opcode
1144                              (byte 3 3)
1145                              (if (eq size :byte)
1146                                  #b00000100
1147                                  #b00000101)))
1148              (emit-sized-immediate segment size src))
1149             (t
1150              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1151              (emit-ea segment dst opcode allow-constants)
1152              (emit-sized-immediate segment size src))))
1153      ((register-p src)
1154       (emit-byte segment
1155                  (dpb opcode
1156                       (byte 3 3)
1157                       (if (eq size :byte) #b00000000 #b00000001)))
1158       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1159      ((register-p dst)
1160       (emit-byte segment
1161                  (dpb opcode
1162                       (byte 3 3)
1163                       (if (eq size :byte) #b00000010 #b00000011)))
1164       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1165      (t
1166       (error "bogus operands to ~A" name)))))
1167
1168 (eval-when (:compile-toplevel :execute)
1169   (defun arith-inst-printer-list (subop)
1170     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1171       (reg/mem-imm ((op (#b1000000 ,subop))))
1172       (reg/mem-imm ((op (#b1000001 ,subop))
1173                     (imm nil :type signed-imm-byte)))
1174       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1175   )
1176
1177 (define-instruction add (segment dst src)
1178   (:printer-list (arith-inst-printer-list #b000))
1179   (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1180
1181 (define-instruction adc (segment dst src)
1182   (:printer-list (arith-inst-printer-list #b010))
1183   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1184
1185 (define-instruction sub (segment dst src)
1186   (:printer-list (arith-inst-printer-list #b101))
1187   (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1188
1189 (define-instruction sbb (segment dst src)
1190   (:printer-list (arith-inst-printer-list #b011))
1191   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1192
1193 (define-instruction cmp (segment dst src)
1194   (:printer-list (arith-inst-printer-list #b111))
1195   (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1196
1197 (define-instruction inc (segment dst)
1198   ;; Register.
1199   (:printer reg-no-width ((op #b01000)))
1200   ;; Register/Memory
1201   (:printer reg/mem ((op '(#b1111111 #b000))))
1202   (:emitter
1203    (let ((size (operand-size dst)))
1204      (maybe-emit-operand-size-prefix segment size)
1205      (cond ((and (not (eq size :byte)) (register-p dst))
1206             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1207            (t
1208             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1209             (emit-ea segment dst #b000))))))
1210
1211 (define-instruction dec (segment dst)
1212   ;; Register.
1213   (:printer reg-no-width ((op #b01001)))
1214   ;; Register/Memory
1215   (:printer reg/mem ((op '(#b1111111 #b001))))
1216   (:emitter
1217    (let ((size (operand-size dst)))
1218      (maybe-emit-operand-size-prefix segment size)
1219      (cond ((and (not (eq size :byte)) (register-p dst))
1220             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1221            (t
1222             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1223             (emit-ea segment dst #b001))))))
1224
1225 (define-instruction neg (segment dst)
1226   (:printer reg/mem ((op '(#b1111011 #b011))))
1227   (:emitter
1228    (let ((size (operand-size dst)))
1229      (maybe-emit-operand-size-prefix segment size)
1230      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1231      (emit-ea segment dst #b011))))
1232
1233 (define-instruction aaa (segment)
1234   (:printer byte ((op #b00110111)))
1235   (:emitter
1236    (emit-byte segment #b00110111)))
1237
1238 (define-instruction aas (segment)
1239   (:printer byte ((op #b00111111)))
1240   (:emitter
1241    (emit-byte segment #b00111111)))
1242
1243 (define-instruction daa (segment)
1244   (:printer byte ((op #b00100111)))
1245   (:emitter
1246    (emit-byte segment #b00100111)))
1247
1248 (define-instruction das (segment)
1249   (:printer byte ((op #b00101111)))
1250   (:emitter
1251    (emit-byte segment #b00101111)))
1252
1253 (define-instruction mul (segment dst src)
1254   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1255   (:emitter
1256    (let ((size (matching-operand-size dst src)))
1257      (aver (accumulator-p dst))
1258      (maybe-emit-operand-size-prefix segment size)
1259      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1260      (emit-ea segment src #b100))))
1261
1262 (define-instruction imul (segment dst &optional src1 src2)
1263   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1264   (:printer ext-reg-reg/mem ((op #b1010111)))
1265   (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
1266             '(:name :tab reg ", " reg/mem ", " imm))
1267   (:printer reg-reg/mem ((op #b0110101) (width 1)
1268                          (imm nil :type 'signed-imm-byte))
1269             '(:name :tab reg ", " reg/mem ", " imm))
1270   (:emitter
1271    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1272             (let* ((size (matching-operand-size reg r/m))
1273                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1274               (maybe-emit-operand-size-prefix segment size)
1275               (emit-byte segment (if sx #b01101011 #b01101001))
1276               (emit-ea segment r/m (reg-tn-encoding reg))
1277               (if sx
1278                   (emit-byte segment immed)
1279                   (emit-sized-immediate segment size immed)))))
1280      (cond (src2
1281             (r/m-with-immed-to-reg dst src1 src2))
1282            (src1
1283             (if (integerp src1)
1284                 (r/m-with-immed-to-reg dst dst src1)
1285                 (let ((size (matching-operand-size dst src1)))
1286                   (maybe-emit-operand-size-prefix segment size)
1287                   (emit-byte segment #b00001111)
1288                   (emit-byte segment #b10101111)
1289                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1290            (t
1291             (let ((size (operand-size dst)))
1292               (maybe-emit-operand-size-prefix segment size)
1293               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1294               (emit-ea segment dst #b101)))))))
1295
1296 (define-instruction div (segment dst src)
1297   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1298   (:emitter
1299    (let ((size (matching-operand-size dst src)))
1300      (aver (accumulator-p dst))
1301      (maybe-emit-operand-size-prefix segment size)
1302      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1303      (emit-ea segment src #b110))))
1304
1305 (define-instruction idiv (segment dst src)
1306   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1307   (:emitter
1308    (let ((size (matching-operand-size dst src)))
1309      (aver (accumulator-p dst))
1310      (maybe-emit-operand-size-prefix segment size)
1311      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1312      (emit-ea segment src #b111))))
1313
1314 (define-instruction aad (segment)
1315   (:printer two-bytes ((op '(#b11010101 #b00001010))))
1316   (:emitter
1317    (emit-byte segment #b11010101)
1318    (emit-byte segment #b00001010)))
1319
1320 (define-instruction aam (segment)
1321   (:printer two-bytes ((op '(#b11010100 #b00001010))))
1322   (:emitter
1323    (emit-byte segment #b11010100)
1324    (emit-byte segment #b00001010)))
1325
1326 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1327 (define-instruction cbw (segment)
1328   (:emitter
1329    (maybe-emit-operand-size-prefix segment :word)
1330    (emit-byte segment #b10011000)))
1331
1332 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1333 (define-instruction cwde (segment)
1334   (:emitter
1335    (maybe-emit-operand-size-prefix segment :dword)
1336    (emit-byte segment #b10011000)))
1337
1338 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1339 (define-instruction cwd (segment)
1340   (:emitter
1341    (maybe-emit-operand-size-prefix segment :word)
1342    (emit-byte segment #b10011001)))
1343
1344 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1345 (define-instruction cdq (segment)
1346   (:printer byte ((op #b10011001)))
1347   (:emitter
1348    (maybe-emit-operand-size-prefix segment :dword)
1349    (emit-byte segment #b10011001)))
1350
1351 (define-instruction xadd (segment dst src)
1352   ;; Register/Memory with Register.
1353   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1354   (:emitter
1355    (aver (register-p src))
1356    (let ((size (matching-operand-size src dst)))
1357      (maybe-emit-operand-size-prefix segment size)
1358      (emit-byte segment #b00001111)
1359      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1360      (emit-ea segment dst (reg-tn-encoding src)))))
1361
1362 \f
1363 ;;;; logic
1364
1365 (defun emit-shift-inst (segment dst amount opcode)
1366   (let ((size (operand-size dst)))
1367     (maybe-emit-operand-size-prefix segment size)
1368     (multiple-value-bind (major-opcode immed)
1369         (case amount
1370           (:cl (values #b11010010 nil))
1371           (1 (values #b11010000 nil))
1372           (t (values #b11000000 t)))
1373       (emit-byte segment
1374                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
1375       (emit-ea segment dst opcode)
1376       (when immed
1377         (emit-byte segment amount)))))
1378
1379 (eval-when (:compile-toplevel :execute)
1380   (defun shift-inst-printer-list (subop)
1381     `((reg/mem ((op (#b1101000 ,subop)))
1382                (:name :tab reg/mem ", 1"))
1383       (reg/mem ((op (#b1101001 ,subop)))
1384                (:name :tab reg/mem ", " 'cl))
1385       (reg/mem-imm ((op (#b1100000 ,subop))
1386                     (imm nil :type signed-imm-byte))))))
1387
1388 (define-instruction rol (segment dst amount)
1389   (:printer-list
1390    (shift-inst-printer-list #b000))
1391   (:emitter
1392    (emit-shift-inst segment dst amount #b000)))
1393
1394 (define-instruction ror (segment dst amount)
1395   (:printer-list
1396    (shift-inst-printer-list #b001))
1397   (:emitter
1398    (emit-shift-inst segment dst amount #b001)))
1399
1400 (define-instruction rcl (segment dst amount)
1401   (:printer-list
1402    (shift-inst-printer-list #b010))
1403   (:emitter
1404    (emit-shift-inst segment dst amount #b010)))
1405
1406 (define-instruction rcr (segment dst amount)
1407   (:printer-list
1408    (shift-inst-printer-list #b011))
1409   (:emitter
1410    (emit-shift-inst segment dst amount #b011)))
1411
1412 (define-instruction shl (segment dst amount)
1413   (:printer-list
1414    (shift-inst-printer-list #b100))
1415   (:emitter
1416    (emit-shift-inst segment dst amount #b100)))
1417
1418 (define-instruction shr (segment dst amount)
1419   (:printer-list
1420    (shift-inst-printer-list #b101))
1421   (:emitter
1422    (emit-shift-inst segment dst amount #b101)))
1423
1424 (define-instruction sar (segment dst amount)
1425   (:printer-list
1426    (shift-inst-printer-list #b111))
1427   (:emitter
1428    (emit-shift-inst segment dst amount #b111)))
1429
1430 (defun emit-double-shift (segment opcode dst src amt)
1431   (let ((size (matching-operand-size dst src)))
1432     (when (eq size :byte)
1433       (error "Double shifts can only be used with words."))
1434     (maybe-emit-operand-size-prefix segment size)
1435     (emit-byte segment #b00001111)
1436     (emit-byte segment (dpb opcode (byte 1 3)
1437                             (if (eq amt :cl) #b10100101 #b10100100)))
1438     #+nil
1439     (emit-ea segment dst src)
1440     (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
1441     (unless (eq amt :cl)
1442       (emit-byte segment amt))))
1443
1444 (eval-when (:compile-toplevel :execute)
1445   (defun double-shift-inst-printer-list (op)
1446     `(#+nil
1447       (ext-reg-reg/mem-imm ((op ,(logior op #b100))
1448                             (imm nil :type signed-imm-byte)))
1449       (ext-reg-reg/mem ((op ,(logior op #b101)))
1450          (:name :tab reg/mem ", " 'cl)))))
1451
1452 (define-instruction shld (segment dst src amt)
1453   (:declare (type (or (member :cl) (mod 32)) amt))
1454   (:printer-list (double-shift-inst-printer-list #b10100000))
1455   (:emitter
1456    (emit-double-shift segment #b0 dst src amt)))
1457
1458 (define-instruction shrd (segment dst src amt)
1459   (:declare (type (or (member :cl) (mod 32)) amt))
1460   (:printer-list (double-shift-inst-printer-list #b10101000))
1461   (:emitter
1462    (emit-double-shift segment #b1 dst src amt)))
1463
1464 (define-instruction and (segment dst src)
1465   (:printer-list
1466    (arith-inst-printer-list #b100))
1467   (:emitter
1468    (emit-random-arith-inst "AND" segment dst src #b100)))
1469
1470 (define-instruction test (segment this that)
1471   (:printer accum-imm ((op #b1010100)))
1472   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1473   (:printer reg-reg/mem ((op #b1000010)))
1474   (:emitter
1475    (let ((size (matching-operand-size this that)))
1476      (maybe-emit-operand-size-prefix segment size)
1477      (flet ((test-immed-and-something (immed something)
1478               (cond ((accumulator-p something)
1479                      (emit-byte segment
1480                                 (if (eq size :byte) #b10101000 #b10101001))
1481                      (emit-sized-immediate segment size immed))
1482                     (t
1483                      (emit-byte segment
1484                                 (if (eq size :byte) #b11110110 #b11110111))
1485                      (emit-ea segment something #b000)
1486                      (emit-sized-immediate segment size immed))))
1487             (test-reg-and-something (reg something)
1488               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1489               (emit-ea segment something (reg-tn-encoding reg))))
1490        (cond ((integerp that)
1491               (test-immed-and-something that this))
1492              ((integerp this)
1493               (test-immed-and-something this that))
1494              ((register-p this)
1495               (test-reg-and-something this that))
1496              ((register-p that)
1497               (test-reg-and-something that this))
1498              (t
1499               (error "bogus operands for TEST: ~S and ~S" this that)))))))
1500
1501 (define-instruction or (segment dst src)
1502   (:printer-list
1503    (arith-inst-printer-list #b001))
1504   (:emitter
1505    (emit-random-arith-inst "OR" segment dst src #b001)))
1506
1507 (define-instruction xor (segment dst src)
1508   (:printer-list
1509    (arith-inst-printer-list #b110))
1510   (:emitter
1511    (emit-random-arith-inst "XOR" segment dst src #b110)))
1512
1513 (define-instruction not (segment dst)
1514   (:printer reg/mem ((op '(#b1111011 #b010))))
1515   (:emitter
1516    (let ((size (operand-size dst)))
1517      (maybe-emit-operand-size-prefix segment size)
1518      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1519      (emit-ea segment dst #b010))))
1520 \f
1521 ;;;; string manipulation
1522
1523 (define-instruction cmps (segment size)
1524   (:printer string-op ((op #b1010011)))
1525   (:emitter
1526    (maybe-emit-operand-size-prefix segment size)
1527    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1528
1529 (define-instruction ins (segment acc)
1530   (:printer string-op ((op #b0110110)))
1531   (:emitter
1532    (let ((size (operand-size acc)))
1533      (aver (accumulator-p acc))
1534      (maybe-emit-operand-size-prefix segment size)
1535      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1536
1537 (define-instruction lods (segment acc)
1538   (:printer string-op ((op #b1010110)))
1539   (:emitter
1540    (let ((size (operand-size acc)))
1541      (aver (accumulator-p acc))
1542      (maybe-emit-operand-size-prefix segment size)
1543      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1544
1545 (define-instruction movs (segment size)
1546   (:printer string-op ((op #b1010010)))
1547   (:emitter
1548    (maybe-emit-operand-size-prefix segment size)
1549    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1550
1551 (define-instruction outs (segment acc)
1552   (:printer string-op ((op #b0110111)))
1553   (:emitter
1554    (let ((size (operand-size acc)))
1555      (aver (accumulator-p acc))
1556      (maybe-emit-operand-size-prefix segment size)
1557      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1558
1559 (define-instruction scas (segment acc)
1560   (:printer string-op ((op #b1010111)))
1561   (:emitter
1562    (let ((size (operand-size acc)))
1563      (aver (accumulator-p acc))
1564      (maybe-emit-operand-size-prefix segment size)
1565      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1566
1567 (define-instruction stos (segment acc)
1568   (:printer string-op ((op #b1010101)))
1569   (:emitter
1570    (let ((size (operand-size acc)))
1571      (aver (accumulator-p acc))
1572      (maybe-emit-operand-size-prefix segment size)
1573      (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1574
1575 (define-instruction xlat (segment)
1576   (:printer byte ((op #b11010111)))
1577   (:emitter
1578    (emit-byte segment #b11010111)))
1579
1580 (define-instruction rep (segment)
1581   (:emitter
1582    (emit-byte segment #b11110010)))
1583
1584 (define-instruction repe (segment)
1585   (:printer byte ((op #b11110011)))
1586   (:emitter
1587    (emit-byte segment #b11110011)))
1588
1589 (define-instruction repne (segment)
1590   (:printer byte ((op #b11110010)))
1591   (:emitter
1592    (emit-byte segment #b11110010)))
1593
1594 \f
1595 ;;;; bit manipulation
1596
1597 (define-instruction bsf (segment dst src)
1598   (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1599   (:emitter
1600    (let ((size (matching-operand-size dst src)))
1601      (when (eq size :byte)
1602        (error "can't scan bytes: ~S" src))
1603      (maybe-emit-operand-size-prefix segment size)
1604      (emit-byte segment #b00001111)
1605      (emit-byte segment #b10111100)
1606      (emit-ea segment src (reg-tn-encoding dst)))))
1607
1608 (define-instruction bsr (segment dst src)
1609   (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1610   (:emitter
1611    (let ((size (matching-operand-size dst src)))
1612      (when (eq size :byte)
1613        (error "can't scan bytes: ~S" src))
1614      (maybe-emit-operand-size-prefix segment size)
1615      (emit-byte segment #b00001111)
1616      (emit-byte segment #b10111101)
1617      (emit-ea segment src (reg-tn-encoding dst)))))
1618
1619 (defun emit-bit-test-and-mumble (segment src index opcode)
1620   (let ((size (operand-size src)))
1621     (when (eq size :byte)
1622       (error "can't scan bytes: ~S" src))
1623     (maybe-emit-operand-size-prefix segment size)
1624     (emit-byte segment #b00001111)
1625     (cond ((integerp index)
1626            (emit-byte segment #b10111010)
1627            (emit-ea segment src opcode)
1628            (emit-byte segment index))
1629           (t
1630            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1631            (emit-ea segment src (reg-tn-encoding index))))))
1632
1633 (eval-when (:compile-toplevel :execute)
1634   (defun bit-test-inst-printer-list (subop)
1635     `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1636                         (reg/mem nil :type word-reg/mem)
1637                         (imm nil :type imm-data)
1638                         (width 0)))
1639       (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1640                         (width 1))
1641                        (:name :tab reg/mem ", " reg)))))
1642
1643 (define-instruction bt (segment src index)
1644   (:printer-list (bit-test-inst-printer-list #b100))
1645   (:emitter
1646    (emit-bit-test-and-mumble segment src index #b100)))
1647
1648 (define-instruction btc (segment src index)
1649   (:printer-list (bit-test-inst-printer-list #b111))
1650   (:emitter
1651    (emit-bit-test-and-mumble segment src index #b111)))
1652
1653 (define-instruction btr (segment src index)
1654   (:printer-list (bit-test-inst-printer-list #b110))
1655   (:emitter
1656    (emit-bit-test-and-mumble segment src index #b110)))
1657
1658 (define-instruction bts (segment src index)
1659   (:printer-list (bit-test-inst-printer-list #b101))
1660   (:emitter
1661    (emit-bit-test-and-mumble segment src index #b101)))
1662
1663 \f
1664 ;;;; control transfer
1665
1666 (define-instruction call (segment where)
1667   (:printer near-jump ((op #b11101000)))
1668   (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1669   (:emitter
1670    (typecase where
1671      (label
1672       (emit-byte segment #b11101000)
1673       (emit-back-patch segment
1674                        4
1675                        (lambda (segment posn)
1676                          (emit-dword segment
1677                                      (- (label-position where)
1678                                         (+ posn 4))))))
1679      (fixup
1680       (emit-byte segment #b11101000)
1681       (emit-relative-fixup segment where))
1682      (t
1683       (emit-byte segment #b11111111)
1684       (emit-ea segment where #b010)))))
1685
1686 (defun emit-byte-displacement-backpatch (segment target)
1687   (emit-back-patch segment
1688                    1
1689                    (lambda (segment posn)
1690                      (let ((disp (- (label-position target) (1+ posn))))
1691                        (aver (<= -128 disp 127))
1692                        (emit-byte segment disp)))))
1693
1694 (define-instruction jmp (segment cond &optional where)
1695   ;; conditional jumps
1696   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1697   (:printer near-cond-jump () '('j cc :tab label))
1698   ;; unconditional jumps
1699   (:printer short-jump ((op #b1011)))
1700   (:printer near-jump ((op #b11101001)) )
1701   (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1702   (:emitter
1703    (cond (where
1704           (emit-chooser
1705            segment 6 2
1706            (lambda (segment posn delta-if-after)
1707              (let ((disp (- (label-position where posn delta-if-after)
1708                             (+ posn 2))))
1709                (when (<= -128 disp 127)
1710                  (emit-byte segment
1711                             (dpb (conditional-opcode cond)
1712                                  (byte 4 0)
1713                                  #b01110000))
1714                  (emit-byte-displacement-backpatch segment where)
1715                  t)))
1716            (lambda (segment posn)
1717              (let ((disp (- (label-position where) (+ posn 6))))
1718                (emit-byte segment #b00001111)
1719                (emit-byte segment
1720                           (dpb (conditional-opcode cond)
1721                                (byte 4 0)
1722                                #b10000000))
1723                (emit-dword segment disp)))))
1724          ((label-p (setq where cond))
1725           (emit-chooser
1726            segment 5 0
1727            (lambda (segment posn delta-if-after)
1728              (let ((disp (- (label-position where posn delta-if-after)
1729                             (+ posn 2))))
1730                (when (<= -128 disp 127)
1731                  (emit-byte segment #b11101011)
1732                  (emit-byte-displacement-backpatch segment where)
1733                  t)))
1734            (lambda (segment posn)
1735              (let ((disp (- (label-position where) (+ posn 5))))
1736                (emit-byte segment #b11101001)
1737                (emit-dword segment disp)))))
1738          ((fixup-p where)
1739           (emit-byte segment #b11101001)
1740           (emit-relative-fixup segment where))
1741          (t
1742           (unless (or (ea-p where) (tn-p where))
1743                   (error "don't know what to do with ~A" where))
1744           (emit-byte segment #b11111111)
1745           (emit-ea segment where #b100)))))
1746
1747 (define-instruction jmp-short (segment label)
1748   (:emitter
1749    (emit-byte segment #b11101011)
1750    (emit-byte-displacement-backpatch segment label)))
1751
1752 (define-instruction ret (segment &optional stack-delta)
1753   (:printer byte ((op #b11000011)))
1754   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1755             '(:name :tab imm))
1756   (:emitter
1757    (cond (stack-delta
1758           (emit-byte segment #b11000010)
1759           (emit-word segment stack-delta))
1760          (t
1761           (emit-byte segment #b11000011)))))
1762
1763 (define-instruction jecxz (segment target)
1764   (:printer short-jump ((op #b0011)))
1765   (:emitter
1766    (emit-byte segment #b11100011)
1767    (emit-byte-displacement-backpatch segment target)))
1768
1769 (define-instruction loop (segment target)
1770   (:printer short-jump ((op #b0010)))
1771   (:emitter
1772    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
1773    (emit-byte-displacement-backpatch segment target)))
1774
1775 (define-instruction loopz (segment target)
1776   (:printer short-jump ((op #b0001)))
1777   (:emitter
1778    (emit-byte segment #b11100001)
1779    (emit-byte-displacement-backpatch segment target)))
1780
1781 (define-instruction loopnz (segment target)
1782   (:printer short-jump ((op #b0000)))
1783   (:emitter
1784    (emit-byte segment #b11100000)
1785    (emit-byte-displacement-backpatch segment target)))
1786 \f
1787 ;;;; conditional byte set
1788
1789 (define-instruction set (segment dst cond)
1790   (:printer cond-set ())
1791   (:emitter
1792    (emit-byte segment #b00001111)
1793    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
1794    (emit-ea segment dst #b000)))
1795 \f
1796 ;;;; enter/leave
1797
1798 (define-instruction enter (segment disp &optional (level 0))
1799   (:declare (type (unsigned-byte 16) disp)
1800             (type (unsigned-byte 8) level))
1801   (:printer enter-format ((op #b11001000)))
1802   (:emitter
1803    (emit-byte segment #b11001000)
1804    (emit-word segment disp)
1805    (emit-byte segment level)))
1806
1807 (define-instruction leave (segment)
1808   (:printer byte ((op #b11001001)))
1809   (:emitter
1810    (emit-byte segment #b11001001)))
1811 \f
1812 ;;;; interrupt instructions
1813
1814 (defun snarf-error-junk (sap offset &optional length-only)
1815   (let* ((length (sb!sys:sap-ref-8 sap offset))
1816          (vector (make-array length :element-type '(unsigned-byte 8))))
1817     (declare (type sb!sys:system-area-pointer sap)
1818              (type (unsigned-byte 8) length)
1819              (type (simple-array (unsigned-byte 8) (*)) vector))
1820     (cond (length-only
1821            (values 0 (1+ length) nil nil))
1822           (t
1823            (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
1824                                             vector (* n-word-bits
1825                                                       vector-data-offset)
1826                                             (* length n-byte-bits))
1827            (collect ((sc-offsets)
1828                      (lengths))
1829              (lengths 1)                ; the length byte
1830              (let* ((index 0)
1831                     (error-number (sb!c:read-var-integer vector index)))
1832                (lengths index)
1833                (loop
1834                  (when (>= index length)
1835                    (return))
1836                  (let ((old-index index))
1837                    (sc-offsets (sb!c:read-var-integer vector index))
1838                    (lengths (- index old-index))))
1839                (values error-number
1840                        (1+ length)
1841                        (sc-offsets)
1842                        (lengths))))))))
1843
1844 #|
1845 (defmacro break-cases (breaknum &body cases)
1846   (let ((bn-temp (gensym)))
1847     (collect ((clauses))
1848       (dolist (case cases)
1849         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
1850       `(let ((,bn-temp ,breaknum))
1851          (cond ,@(clauses))))))
1852 |#
1853
1854 (defun break-control (chunk inst stream dstate)
1855   (declare (ignore inst))
1856   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1857     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
1858     ;; map has it undefined; and it should be easier to look in the target
1859     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
1860     ;; from first principles whether it's defined in some way that genesis
1861     ;; can't grok.
1862     (case (byte-imm-code chunk dstate)
1863       (#.error-trap
1864        (nt "error trap")
1865        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1866       (#.cerror-trap
1867        (nt "cerror trap")
1868        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1869       (#.breakpoint-trap
1870        (nt "breakpoint trap"))
1871       (#.pending-interrupt-trap
1872        (nt "pending interrupt trap"))
1873       (#.halt-trap
1874        (nt "halt trap"))
1875       (#.fun-end-breakpoint-trap
1876        (nt "function end breakpoint trap")))))
1877
1878 (define-instruction break (segment code)
1879   (:declare (type (unsigned-byte 8) code))
1880   (:printer byte-imm ((op #b11001100)) '(:name :tab code)
1881             :control #'break-control)
1882   (:emitter
1883    (emit-byte segment #b11001100)
1884    (emit-byte segment code)))
1885
1886 (define-instruction int (segment number)
1887   (:declare (type (unsigned-byte 8) number))
1888   (:printer byte-imm ((op #b11001101)))
1889   (:emitter
1890    (etypecase number
1891      ((member 3)
1892       (emit-byte segment #b11001100))
1893      ((unsigned-byte 8)
1894       (emit-byte segment #b11001101)
1895       (emit-byte segment number)))))
1896
1897 (define-instruction into (segment)
1898   (:printer byte ((op #b11001110)))
1899   (:emitter
1900    (emit-byte segment #b11001110)))
1901
1902 (define-instruction bound (segment reg bounds)
1903   (:emitter
1904    (let ((size (matching-operand-size reg bounds)))
1905      (when (eq size :byte)
1906        (error "can't bounds-test bytes: ~S" reg))
1907      (maybe-emit-operand-size-prefix segment size)
1908      (emit-byte segment #b01100010)
1909      (emit-ea segment bounds (reg-tn-encoding reg)))))
1910
1911 (define-instruction iret (segment)
1912   (:printer byte ((op #b11001111)))
1913   (:emitter
1914    (emit-byte segment #b11001111)))
1915 \f
1916 ;;;; processor control
1917
1918 (define-instruction hlt (segment)
1919   (:printer byte ((op #b11110100)))
1920   (:emitter
1921    (emit-byte segment #b11110100)))
1922
1923 (define-instruction nop (segment)
1924   (:printer byte ((op #b10010000)))
1925   (:emitter
1926    (emit-byte segment #b10010000)))
1927
1928 (define-instruction wait (segment)
1929   (:printer byte ((op #b10011011)))
1930   (:emitter
1931    (emit-byte segment #b10011011)))
1932
1933 (define-instruction lock (segment)
1934   (:printer byte ((op #b11110000)))
1935   (:emitter
1936    (emit-byte segment #b11110000)))
1937 \f
1938 ;;;; miscellaneous hackery
1939
1940 (define-instruction byte (segment byte)
1941   (:emitter
1942    (emit-byte segment byte)))
1943
1944 (define-instruction word (segment word)
1945   (:emitter
1946    (emit-word segment word)))
1947
1948 (define-instruction dword (segment dword)
1949   (:emitter
1950    (emit-dword segment dword)))
1951
1952 (defun emit-header-data (segment type)
1953   (emit-back-patch segment
1954                    4
1955                    (lambda (segment posn)
1956                      (emit-dword segment
1957                                  (logior type
1958                                          (ash (+ posn
1959                                                  (component-header-length))
1960                                               (- n-widetag-bits
1961                                                  word-shift)))))))
1962
1963 (define-instruction simple-fun-header-word (segment)
1964   (:emitter
1965    (emit-header-data segment simple-fun-header-widetag)))
1966
1967 (define-instruction lra-header-word (segment)
1968   (:emitter
1969    (emit-header-data segment return-pc-header-widetag)))
1970 \f
1971 ;;;; fp instructions
1972 ;;;;
1973 ;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
1974 ;;;;
1975 ;;;; Note: We treat the single-precision and double-precision variants
1976 ;;;; as separate instructions.
1977
1978 ;;; Load single to st(0).
1979 (define-instruction fld (segment source)
1980   (:printer floating-point ((op '(#b001 #b000))))
1981   (:emitter
1982     (emit-byte segment #b11011001)
1983     (emit-fp-op segment source #b000)))
1984
1985 ;;; Load double to st(0).
1986 (define-instruction fldd (segment source)
1987   (:printer floating-point ((op '(#b101 #b000))))
1988   (:printer floating-point-fp ((op '(#b001 #b000))))
1989   (:emitter
1990    (if (fp-reg-tn-p source)
1991        (emit-byte segment #b11011001)
1992      (emit-byte segment #b11011101))
1993     (emit-fp-op segment source #b000)))
1994
1995 ;;; Load long to st(0).
1996 (define-instruction fldl (segment source)
1997   (:printer floating-point ((op '(#b011 #b101))))
1998   (:emitter
1999     (emit-byte segment #b11011011)
2000     (emit-fp-op segment source #b101)))
2001
2002 ;;; Store single from st(0).
2003 (define-instruction fst (segment dest)
2004   (:printer floating-point ((op '(#b001 #b010))))
2005   (:emitter
2006     (cond ((fp-reg-tn-p dest)
2007            (emit-byte segment #b11011101)
2008            (emit-fp-op segment dest #b010))
2009           (t
2010            (emit-byte segment #b11011001)
2011            (emit-fp-op segment dest #b010)))))
2012
2013 ;;; Store double from st(0).
2014 (define-instruction fstd (segment dest)
2015   (:printer floating-point ((op '(#b101 #b010))))
2016   (:printer floating-point-fp ((op '(#b101 #b010))))
2017   (:emitter
2018    (cond ((fp-reg-tn-p dest)
2019           (emit-byte segment #b11011101)
2020           (emit-fp-op segment dest #b010))
2021          (t
2022           (emit-byte segment #b11011101)
2023           (emit-fp-op segment dest #b010)))))
2024
2025 ;;; Arithmetic ops are all done with at least one operand at top of
2026 ;;; stack. The other operand is is another register or a 32/64 bit
2027 ;;; memory loc.
2028
2029 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2030 ;;; that these conflict with the Gdb conventions for binops. To reduce
2031 ;;; the confusion I've added comments showing the mathamatical
2032 ;;; operation and the two syntaxes. By the ASM386 convention the
2033 ;;; instruction syntax is:
2034 ;;;
2035 ;;;      Fop Source
2036 ;;; or   Fop Destination, Source
2037 ;;;
2038 ;;; If only one operand is given then it is the source and the
2039 ;;; destination is ST(0). There are reversed forms of the fsub and
2040 ;;; fdiv instructions inducated by an 'R' suffix.
2041 ;;;
2042 ;;; The mathematical operation for the non-reverse form is always:
2043 ;;;     destination = destination op source
2044 ;;;
2045 ;;; For the reversed form it is:
2046 ;;;     destination = source op destination
2047 ;;;
2048 ;;; The instructions below only accept one operand at present which is
2049 ;;; usually the source. I've hack in extra instructions to implement
2050 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2051 ;;; the operand is the destination with the source being ST(0).
2052
2053 ;;; Add single:
2054 ;;;   st(0) = st(0) + memory or st(i).
2055 (define-instruction fadd (segment source)
2056   (:printer floating-point ((op '(#b000 #b000))))
2057   (:emitter
2058     (emit-byte segment #b11011000)
2059     (emit-fp-op segment source #b000)))
2060
2061 ;;; Add double:
2062 ;;;   st(0) = st(0) + memory or st(i).
2063 (define-instruction faddd (segment source)
2064   (:printer floating-point ((op '(#b100 #b000))))
2065   (:printer floating-point-fp ((op '(#b000 #b000))))
2066   (:emitter
2067    (if (fp-reg-tn-p source)
2068        (emit-byte segment #b11011000)
2069      (emit-byte segment #b11011100))
2070    (emit-fp-op segment source #b000)))
2071
2072 ;;; Add double destination st(i):
2073 ;;;   st(i) = st(0) + st(i).
2074 (define-instruction fadd-sti (segment destination)
2075   (:printer floating-point-fp ((op '(#b100 #b000))))
2076   (:emitter
2077    (aver (fp-reg-tn-p destination))
2078    (emit-byte segment #b11011100)
2079    (emit-fp-op segment destination #b000)))
2080 ;;; with pop
2081 (define-instruction faddp-sti (segment destination)
2082   (:printer floating-point-fp ((op '(#b110 #b000))))
2083   (:emitter
2084    (aver (fp-reg-tn-p destination))
2085    (emit-byte segment #b11011110)
2086    (emit-fp-op segment destination #b000)))
2087
2088 ;;; Subtract single:
2089 ;;;   st(0) = st(0) - memory or st(i).
2090 (define-instruction fsub (segment source)
2091   (:printer floating-point ((op '(#b000 #b100))))
2092   (:emitter
2093     (emit-byte segment #b11011000)
2094     (emit-fp-op segment source #b100)))
2095
2096 ;;; Subtract single, reverse:
2097 ;;;   st(0) = memory or st(i) - st(0).
2098 (define-instruction fsubr (segment source)
2099   (:printer floating-point ((op '(#b000 #b101))))
2100   (:emitter
2101     (emit-byte segment #b11011000)
2102     (emit-fp-op segment source #b101)))
2103
2104 ;;; Subtract double:
2105 ;;;   st(0) = st(0) - memory or st(i).
2106 (define-instruction fsubd (segment source)
2107   (:printer floating-point ((op '(#b100 #b100))))
2108   (:printer floating-point-fp ((op '(#b000 #b100))))
2109   (:emitter
2110    (if (fp-reg-tn-p source)
2111        (emit-byte segment #b11011000)
2112      (emit-byte segment #b11011100))
2113    (emit-fp-op segment source #b100)))
2114
2115 ;;; Subtract double, reverse:
2116 ;;;   st(0) = memory or st(i) - st(0).
2117 (define-instruction fsubrd (segment source)
2118   (:printer floating-point ((op '(#b100 #b101))))
2119   (:printer floating-point-fp ((op '(#b000 #b101))))
2120   (:emitter
2121    (if (fp-reg-tn-p source)
2122        (emit-byte segment #b11011000)
2123      (emit-byte segment #b11011100))
2124    (emit-fp-op segment source #b101)))
2125
2126 ;;; Subtract double, destination st(i):
2127 ;;;   st(i) = st(i) - st(0).
2128 ;;;
2129 ;;; ASM386 syntax: FSUB ST(i), ST
2130 ;;; Gdb    syntax: fsubr %st,%st(i)
2131 (define-instruction fsub-sti (segment destination)
2132   (:printer floating-point-fp ((op '(#b100 #b101))))
2133   (:emitter
2134    (aver (fp-reg-tn-p destination))
2135    (emit-byte segment #b11011100)
2136    (emit-fp-op segment destination #b101)))
2137 ;;; with a pop
2138 (define-instruction fsubp-sti (segment destination)
2139   (:printer floating-point-fp ((op '(#b110 #b101))))
2140   (:emitter
2141    (aver (fp-reg-tn-p destination))
2142    (emit-byte segment #b11011110)
2143    (emit-fp-op segment destination #b101)))
2144
2145 ;;; Subtract double, reverse, destination st(i):
2146 ;;;   st(i) = st(0) - st(i).
2147 ;;;
2148 ;;; ASM386 syntax: FSUBR ST(i), ST
2149 ;;; Gdb    syntax: fsub %st,%st(i)
2150 (define-instruction fsubr-sti (segment destination)
2151   (:printer floating-point-fp ((op '(#b100 #b100))))
2152   (:emitter
2153    (aver (fp-reg-tn-p destination))
2154    (emit-byte segment #b11011100)
2155    (emit-fp-op segment destination #b100)))
2156 ;;; with a pop
2157 (define-instruction fsubrp-sti (segment destination)
2158   (:printer floating-point-fp ((op '(#b110 #b100))))
2159   (:emitter
2160    (aver (fp-reg-tn-p destination))
2161    (emit-byte segment #b11011110)
2162    (emit-fp-op segment destination #b100)))
2163
2164 ;;; Multiply single:
2165 ;;;   st(0) = st(0) * memory or st(i).
2166 (define-instruction fmul (segment source)
2167   (:printer floating-point ((op '(#b000 #b001))))
2168   (:emitter
2169     (emit-byte segment #b11011000)
2170     (emit-fp-op segment source #b001)))
2171
2172 ;;; Multiply double:
2173 ;;;   st(0) = st(0) * memory or st(i).
2174 (define-instruction fmuld (segment source)
2175   (:printer floating-point ((op '(#b100 #b001))))
2176   (:printer floating-point-fp ((op '(#b000 #b001))))
2177   (:emitter
2178    (if (fp-reg-tn-p source)
2179        (emit-byte segment #b11011000)
2180      (emit-byte segment #b11011100))
2181    (emit-fp-op segment source #b001)))
2182
2183 ;;; Multiply double, destination st(i):
2184 ;;;   st(i) = st(i) * st(0).
2185 (define-instruction fmul-sti (segment destination)
2186   (:printer floating-point-fp ((op '(#b100 #b001))))
2187   (:emitter
2188    (aver (fp-reg-tn-p destination))
2189    (emit-byte segment #b11011100)
2190    (emit-fp-op segment destination #b001)))
2191
2192 ;;; Divide single:
2193 ;;;   st(0) = st(0) / memory or st(i).
2194 (define-instruction fdiv (segment source)
2195   (:printer floating-point ((op '(#b000 #b110))))
2196   (:emitter
2197     (emit-byte segment #b11011000)
2198     (emit-fp-op segment source #b110)))
2199
2200 ;;; Divide single, reverse:
2201 ;;;   st(0) = memory or st(i) / st(0).
2202 (define-instruction fdivr (segment source)
2203   (:printer floating-point ((op '(#b000 #b111))))
2204   (:emitter
2205     (emit-byte segment #b11011000)
2206     (emit-fp-op segment source #b111)))
2207
2208 ;;; Divide double:
2209 ;;;   st(0) = st(0) / memory or st(i).
2210 (define-instruction fdivd (segment source)
2211   (:printer floating-point ((op '(#b100 #b110))))
2212   (:printer floating-point-fp ((op '(#b000 #b110))))
2213   (:emitter
2214    (if (fp-reg-tn-p source)
2215        (emit-byte segment #b11011000)
2216      (emit-byte segment #b11011100))
2217    (emit-fp-op segment source #b110)))
2218
2219 ;;; Divide double, reverse:
2220 ;;;   st(0) = memory or st(i) / st(0).
2221 (define-instruction fdivrd (segment source)
2222   (:printer floating-point ((op '(#b100 #b111))))
2223   (:printer floating-point-fp ((op '(#b000 #b111))))
2224   (:emitter
2225    (if (fp-reg-tn-p source)
2226        (emit-byte segment #b11011000)
2227      (emit-byte segment #b11011100))
2228    (emit-fp-op segment source #b111)))
2229
2230 ;;; Divide double, destination st(i):
2231 ;;;   st(i) = st(i) / st(0).
2232 ;;;
2233 ;;; ASM386 syntax: FDIV ST(i), ST
2234 ;;; Gdb    syntax: fdivr %st,%st(i)
2235 (define-instruction fdiv-sti (segment destination)
2236   (:printer floating-point-fp ((op '(#b100 #b111))))
2237   (:emitter
2238    (aver (fp-reg-tn-p destination))
2239    (emit-byte segment #b11011100)
2240    (emit-fp-op segment destination #b111)))
2241
2242 ;;; Divide double, reverse, destination st(i):
2243 ;;;   st(i) = st(0) / st(i).
2244 ;;;
2245 ;;; ASM386 syntax: FDIVR ST(i), ST
2246 ;;; Gdb    syntax: fdiv %st,%st(i)
2247 (define-instruction fdivr-sti (segment destination)
2248   (:printer floating-point-fp ((op '(#b100 #b110))))
2249   (:emitter
2250    (aver (fp-reg-tn-p destination))
2251    (emit-byte segment #b11011100)
2252    (emit-fp-op segment destination #b110)))
2253
2254 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2255 (define-instruction fxch (segment source)
2256   (:printer floating-point-fp ((op '(#b001 #b001))))
2257   (:emitter
2258     (unless (and (tn-p source)
2259                  (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2260       (cl:break))
2261     (emit-byte segment #b11011001)
2262     (emit-fp-op segment source #b001)))
2263
2264 ;;; Push 32-bit integer to st0.
2265 (define-instruction fild (segment source)
2266   (:printer floating-point ((op '(#b011 #b000))))
2267   (:emitter
2268    (emit-byte segment #b11011011)
2269    (emit-fp-op segment source #b000)))
2270
2271 ;;; Push 64-bit integer to st0.
2272 (define-instruction fildl (segment source)
2273   (:printer floating-point ((op '(#b111 #b101))))
2274   (:emitter
2275    (emit-byte segment #b11011111)
2276    (emit-fp-op segment source #b101)))
2277
2278 ;;; Store 32-bit integer.
2279 (define-instruction fist (segment dest)
2280   (:printer floating-point ((op '(#b011 #b010))))
2281   (:emitter
2282    (emit-byte segment #b11011011)
2283    (emit-fp-op segment dest #b010)))
2284
2285 ;;; Store and pop 32-bit integer.
2286 (define-instruction fistp (segment dest)
2287   (:printer floating-point ((op '(#b011 #b011))))
2288   (:emitter
2289    (emit-byte segment #b11011011)
2290    (emit-fp-op segment dest #b011)))
2291
2292 ;;; Store and pop 64-bit integer.
2293 (define-instruction fistpl (segment dest)
2294   (:printer floating-point ((op '(#b111 #b111))))
2295   (:emitter
2296    (emit-byte segment #b11011111)
2297    (emit-fp-op segment dest #b111)))
2298
2299 ;;; Store single from st(0) and pop.
2300 (define-instruction fstp (segment dest)
2301   (:printer floating-point ((op '(#b001 #b011))))
2302   (:emitter
2303    (cond ((fp-reg-tn-p dest)
2304           (emit-byte segment #b11011101)
2305           (emit-fp-op segment dest #b011))
2306          (t
2307           (emit-byte segment #b11011001)
2308           (emit-fp-op segment dest #b011)))))
2309
2310 ;;; Store double from st(0) and pop.
2311 (define-instruction fstpd (segment dest)
2312   (:printer floating-point ((op '(#b101 #b011))))
2313   (:printer floating-point-fp ((op '(#b101 #b011))))
2314   (:emitter
2315    (cond ((fp-reg-tn-p dest)
2316           (emit-byte segment #b11011101)
2317           (emit-fp-op segment dest #b011))
2318          (t
2319           (emit-byte segment #b11011101)
2320           (emit-fp-op segment dest #b011)))))
2321
2322 ;;; Store long from st(0) and pop.
2323 (define-instruction fstpl (segment dest)
2324   (:printer floating-point ((op '(#b011 #b111))))
2325   (:emitter
2326     (emit-byte segment #b11011011)
2327     (emit-fp-op segment dest #b111)))
2328
2329 ;;; Decrement stack-top pointer.
2330 (define-instruction fdecstp (segment)
2331   (:printer floating-point-no ((op #b10110)))
2332   (:emitter
2333    (emit-byte segment #b11011001)
2334    (emit-byte segment #b11110110)))
2335
2336 ;;; Increment stack-top pointer.
2337 (define-instruction fincstp (segment)
2338   (:printer floating-point-no ((op #b10111)))
2339   (:emitter
2340    (emit-byte segment #b11011001)
2341    (emit-byte segment #b11110111)))
2342
2343 ;;; Free fp register.
2344 (define-instruction ffree (segment dest)
2345   (:printer floating-point-fp ((op '(#b101 #b000))))
2346   (:emitter
2347    (emit-byte segment #b11011101)
2348    (emit-fp-op segment dest #b000)))
2349
2350 (define-instruction fabs (segment)
2351   (:printer floating-point-no ((op #b00001)))
2352   (:emitter
2353    (emit-byte segment #b11011001)
2354    (emit-byte segment #b11100001)))
2355
2356 (define-instruction fchs (segment)
2357   (:printer floating-point-no ((op #b00000)))
2358   (:emitter
2359    (emit-byte segment #b11011001)
2360    (emit-byte segment #b11100000)))
2361
2362 (define-instruction frndint(segment)
2363   (:printer floating-point-no ((op #b11100)))
2364   (:emitter
2365    (emit-byte segment #b11011001)
2366    (emit-byte segment #b11111100)))
2367
2368 ;;; Initialize NPX.
2369 (define-instruction fninit(segment)
2370   (:printer floating-point-5 ((op #b00011)))
2371   (:emitter
2372    (emit-byte segment #b11011011)
2373    (emit-byte segment #b11100011)))
2374
2375 ;;; Store Status Word to AX.
2376 (define-instruction fnstsw(segment)
2377   (:printer floating-point-st ((op #b00000)))
2378   (:emitter
2379    (emit-byte segment #b11011111)
2380    (emit-byte segment #b11100000)))
2381
2382 ;;; Load Control Word.
2383 ;;;
2384 ;;; src must be a memory location
2385 (define-instruction fldcw(segment src)
2386   (:printer floating-point ((op '(#b001 #b101))))
2387   (:emitter
2388    (emit-byte segment #b11011001)
2389    (emit-fp-op segment src #b101)))
2390
2391 ;;; Store Control Word.
2392 (define-instruction fnstcw(segment dst)
2393   (:printer floating-point ((op '(#b001 #b111))))
2394   (:emitter
2395    (emit-byte segment #b11011001)
2396    (emit-fp-op segment dst #b111)))
2397
2398 ;;; Store FP Environment.
2399 (define-instruction fstenv(segment dst)
2400   (:printer floating-point ((op '(#b001 #b110))))
2401   (:emitter
2402    (emit-byte segment #b11011001)
2403    (emit-fp-op segment dst #b110)))
2404
2405 ;;; Restore FP Environment.
2406 (define-instruction fldenv(segment src)
2407   (:printer floating-point ((op '(#b001 #b100))))
2408   (:emitter
2409    (emit-byte segment #b11011001)
2410    (emit-fp-op segment src #b100)))
2411
2412 ;;; Save FP State.
2413 (define-instruction fsave(segment dst)
2414   (:printer floating-point ((op '(#b101 #b110))))
2415   (:emitter
2416    (emit-byte segment #b11011101)
2417    (emit-fp-op segment dst #b110)))
2418
2419 ;;; Restore FP State.
2420 (define-instruction frstor(segment src)
2421   (:printer floating-point ((op '(#b101 #b100))))
2422   (:emitter
2423    (emit-byte segment #b11011101)
2424    (emit-fp-op segment src #b100)))
2425
2426 ;;; Clear exceptions.
2427 (define-instruction fnclex(segment)
2428   (:printer floating-point-5 ((op #b00010)))
2429   (:emitter
2430    (emit-byte segment #b11011011)
2431    (emit-byte segment #b11100010)))
2432
2433 ;;; comparison
2434 (define-instruction fcom (segment src)
2435   (:printer floating-point ((op '(#b000 #b010))))
2436   (:emitter
2437    (emit-byte segment #b11011000)
2438    (emit-fp-op segment src #b010)))
2439
2440 (define-instruction fcomd (segment src)
2441   (:printer floating-point ((op '(#b100 #b010))))
2442   (:printer floating-point-fp ((op '(#b000 #b010))))
2443   (:emitter
2444    (if (fp-reg-tn-p src)
2445        (emit-byte segment #b11011000)
2446      (emit-byte segment #b11011100))
2447    (emit-fp-op segment src #b010)))
2448
2449 ;;; Compare ST1 to ST0, popping the stack twice.
2450 (define-instruction fcompp (segment)
2451   (:printer floating-point-3 ((op '(#b110 #b011001))))
2452   (:emitter
2453    (emit-byte segment #b11011110)
2454    (emit-byte segment #b11011001)))
2455
2456 ;;; unordered comparison
2457 (define-instruction fucom (segment src)
2458   ;; XX Printer conflicts with frstor
2459   ;; (:printer floating-point ((op '(#b101 #b100))))
2460   (:emitter
2461    (aver (fp-reg-tn-p src))
2462    (emit-byte segment #b11011101)
2463    (emit-fp-op segment src #b100)))
2464
2465 (define-instruction ftst (segment)
2466   (:printer floating-point-no ((op #b00100)))
2467   (:emitter
2468    (emit-byte segment #b11011001)
2469    (emit-byte segment #b11100100)))
2470
2471 ;;;; 80387 specials
2472
2473 (define-instruction fsqrt(segment)
2474   (:printer floating-point-no ((op #b11010)))
2475   (:emitter
2476    (emit-byte segment #b11011001)
2477    (emit-byte segment #b11111010)))
2478
2479 (define-instruction fscale(segment)
2480   (:printer floating-point-no ((op #b11101)))
2481   (:emitter
2482    (emit-byte segment #b11011001)
2483    (emit-byte segment #b11111101)))
2484
2485 (define-instruction fxtract(segment)
2486   (:printer floating-point-no ((op #b10100)))
2487   (:emitter
2488    (emit-byte segment #b11011001)
2489    (emit-byte segment #b11110100)))
2490
2491 (define-instruction fsin(segment)
2492   (:printer floating-point-no ((op #b11110)))
2493   (:emitter
2494    (emit-byte segment #b11011001)
2495    (emit-byte segment #b11111110)))
2496
2497 (define-instruction fcos(segment)
2498   (:printer floating-point-no ((op #b11111)))
2499   (:emitter
2500    (emit-byte segment #b11011001)
2501    (emit-byte segment #b11111111)))
2502
2503 (define-instruction fprem1(segment)
2504   (:printer floating-point-no ((op #b10101)))
2505   (:emitter
2506    (emit-byte segment #b11011001)
2507    (emit-byte segment #b11110101)))
2508
2509 (define-instruction fprem(segment)
2510   (:printer floating-point-no ((op #b11000)))
2511   (:emitter
2512    (emit-byte segment #b11011001)
2513    (emit-byte segment #b11111000)))
2514
2515 (define-instruction fxam (segment)
2516   (:printer floating-point-no ((op #b00101)))
2517   (:emitter
2518    (emit-byte segment #b11011001)
2519    (emit-byte segment #b11100101)))
2520
2521 ;;; These do push/pop to stack and need special handling
2522 ;;; in any VOPs that use them. See the book.
2523
2524 ;;; st0 <- st1*log2(st0)
2525 (define-instruction fyl2x(segment)      ; pops stack
2526   (:printer floating-point-no ((op #b10001)))
2527   (:emitter
2528    (emit-byte segment #b11011001)
2529    (emit-byte segment #b11110001)))
2530
2531 (define-instruction fyl2xp1(segment)
2532   (:printer floating-point-no ((op #b11001)))
2533   (:emitter
2534    (emit-byte segment #b11011001)
2535    (emit-byte segment #b11111001)))
2536
2537 (define-instruction f2xm1(segment)
2538   (:printer floating-point-no ((op #b10000)))
2539   (:emitter
2540    (emit-byte segment #b11011001)
2541    (emit-byte segment #b11110000)))
2542
2543 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
2544   (:printer floating-point-no ((op #b10010)))
2545   (:emitter
2546    (emit-byte segment #b11011001)
2547    (emit-byte segment #b11110010)))
2548
2549 (define-instruction fpatan(segment)     ; POPS STACK
2550   (:printer floating-point-no ((op #b10011)))
2551   (:emitter
2552    (emit-byte segment #b11011001)
2553    (emit-byte segment #b11110011)))
2554
2555 ;;;; loading constants
2556
2557 (define-instruction fldz(segment)
2558   (:printer floating-point-no ((op #b01110)))
2559   (:emitter
2560    (emit-byte segment #b11011001)
2561    (emit-byte segment #b11101110)))
2562
2563 (define-instruction fld1(segment)
2564   (:printer floating-point-no ((op #b01000)))
2565   (:emitter
2566    (emit-byte segment #b11011001)
2567    (emit-byte segment #b11101000)))
2568
2569 (define-instruction fldpi(segment)
2570   (:printer floating-point-no ((op #b01011)))
2571   (:emitter
2572    (emit-byte segment #b11011001)
2573    (emit-byte segment #b11101011)))
2574
2575 (define-instruction fldl2t(segment)
2576   (:printer floating-point-no ((op #b01001)))
2577   (:emitter
2578    (emit-byte segment #b11011001)
2579    (emit-byte segment #b11101001)))
2580
2581 (define-instruction fldl2e(segment)
2582   (:printer floating-point-no ((op #b01010)))
2583   (:emitter
2584    (emit-byte segment #b11011001)
2585    (emit-byte segment #b11101010)))
2586
2587 (define-instruction fldlg2(segment)
2588   (:printer floating-point-no ((op #b01100)))
2589   (:emitter
2590    (emit-byte segment #b11011001)
2591    (emit-byte segment #b11101100)))
2592
2593 (define-instruction fldln2(segment)
2594   (:printer floating-point-no ((op #b01101)))
2595   (:emitter
2596    (emit-byte segment #b11011001)
2597    (emit-byte segment #b11101101)))