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