src/compiler/x86-64/insts.lisp

   1 ;;;; that part of the description of the x86-64 instruction set
   2 ;;;; 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-R15 are handled separately.
  23 (deftype reg () '(unsigned-byte 3))
  24
  25 ;;; This includes legacy registers and R8-R15.
  26 (deftype full-reg () '(unsigned-byte 4))
  27
  28 ;;; Default word size for the chip: if the operand size /= :dword
  29 ;;; we need to output #x66 (or REX) prefix
  30 (def!constant +default-operand-size+ :dword)
  31
  32 ;;; The default address size for the chip. It could be overwritten
  33 ;;; to :dword with a #x67 prefix, but this is never needed by SBCL
  34 ;;; and thus not supported by this assembler/disassembler.
  35 (def!constant +default-address-size+ :qword)
  36 \f
  37 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  38
  39 (defun offset-next (value dstate)
  40   (declare (type integer value)
  41            (type sb!disassem:disassem-state dstate))
  42   (+ (sb!disassem:dstate-next-addr dstate) value))
  43
  44 (defparameter *byte-reg-names*
  45   #(al cl dl bl spl bpl sil dil r8b r9b r10b r11b r12b r13b r14b r15b))
  46 (defparameter *high-byte-reg-names*
  47   #(ah ch dh bh))
  48 (defparameter *word-reg-names*
  49   #(ax cx dx bx sp bp si di r8w r9w r10w r11w r12w r13w r14w r15w))
  50 (defparameter *dword-reg-names*
  51   #(eax ecx edx ebx esp ebp esi edi r8d r9d r10d r11d r12d r13d r14d r15d))
  52 (defparameter *qword-reg-names*
  53   #(rax rcx rdx rbx rsp rbp rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
  54
  55 ;;; The printers for registers, memory references and immediates need to
  56 ;;; take into account the width bit in the instruction, whether a #x66
  57 ;;; or a REX prefix was issued, and the contents of the REX prefix.
  58 ;;; This is implemented using prefilters to put flags into the slot
  59 ;;; INST-PROPERTIES of the DSTATE.  These flags are the following
  60 ;;; symbols:
  61 ;;;
  62 ;;; OPERAND-SIZE-8   The width bit was zero
  63 ;;; OPERAND-SIZE-16  The "operand size override" prefix (#x66) was found
  64 ;;; REX              A REX prefix was found
  65 ;;; REX-W            A REX prefix with the "operand width" bit set was
  66 ;;;                  found
  67 ;;; REX-R            A REX prefix with the "register" bit set was found
  68 ;;; REX-X            A REX prefix with the "index" bit set was found
  69 ;;; REX-B            A REX prefix with the "base" bit set was found
  70
  71 ;;; Return the operand size depending on the prefixes and width bit as
  72 ;;; stored in DSTATE.
  73 (defun inst-operand-size (dstate)
  74   (declare (type sb!disassem:disassem-state dstate))
  75   (cond ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-8)
  76          :byte)
  77         ((sb!disassem:dstate-get-inst-prop dstate 'rex-w)
  78          :qword)
  79         ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
  80          :word)
  81         (t
  82          +default-operand-size+)))
  83
  84 ;;; The same as INST-OPERAND-SIZE, but for those instructions (e.g.
  85 ;;; PUSH, JMP) that have a default operand size of :qword. It can only
  86 ;;; be overwritten to :word.
  87 (defun inst-operand-size-default-qword (dstate)
  88   (declare (type sb!disassem:disassem-state dstate))
  89   (if (sb!disassem:dstate-get-inst-prop dstate 'operand-size-16)
  90       :word
  91       :qword))
  92
  93 ;;; Print to STREAM the name of the general purpose register encoded by
  94 ;;; VALUE and of size WIDTH. For robustness, the high byte registers
  95 ;;; (AH, BH, CH, DH) are correctly detected, too, although the compiler
  96 ;;; does not use them.
  97 (defun print-reg-with-width (value width stream dstate)
  98   (declare (type full-reg value)
  99            (type stream stream)
 100            (type sb!disassem:disassem-state dstate))
 101   (princ (if (and (eq width :byte)
 102                   (<= 4 value 7)
 103                   (not (sb!disassem:dstate-get-inst-prop dstate 'rex)))
 104              (aref *high-byte-reg-names* (- value 4))
 105              (aref (ecase width
 106                      (:byte *byte-reg-names*)
 107                      (:word *word-reg-names*)
 108                      (:dword *dword-reg-names*)
 109                      (:qword *qword-reg-names*))
 110                    value))
 111          stream)
 112   ;; XXX plus should do some source-var notes
 113   )
 114
 115 (defun print-reg (value stream dstate)
 116   (declare (type full-reg value)
 117            (type stream stream)
 118            (type sb!disassem:disassem-state dstate))
 119   (print-reg-with-width value
 120                         (inst-operand-size dstate)
 121                         stream
 122                         dstate))
 123
 124 (defun print-reg-default-qword (value stream dstate)
 125   (declare (type full-reg value)
 126            (type stream stream)
 127            (type sb!disassem:disassem-state dstate))
 128   (print-reg-with-width value
 129                         (inst-operand-size-default-qword dstate)
 130                         stream
 131                         dstate))
 132
 133 (defun print-byte-reg (value stream dstate)
 134   (declare (type full-reg value)
 135            (type stream stream)
 136            (type sb!disassem:disassem-state dstate))
 137   (print-reg-with-width value :byte stream dstate))
 138
 139 (defun print-addr-reg (value stream dstate)
 140   (declare (type full-reg value)
 141            (type stream stream)
 142            (type sb!disassem:disassem-state dstate))
 143   (print-reg-with-width value +default-address-size+ stream dstate))
 144
 145 ;;; Print a register or a memory reference of the given WIDTH.
 146 ;;; If SIZED-P is true, add an explicit size indicator for memory
 147 ;;; references.
 148 (defun print-reg/mem-with-width (value width sized-p stream dstate)
 149   (declare (type (or list full-reg) value)
 150            (type (member :byte :word :dword :qword) width)
 151            (type boolean sized-p)
 152            (type stream stream)
 153            (type sb!disassem:disassem-state dstate))
 154   (if (typep value 'full-reg)
 155       (print-reg-with-width value width stream dstate)
 156     (print-mem-access value (and sized-p width) stream dstate)))
 157
 158 ;;; Print a register or a memory reference. The width is determined by
 159 ;;; calling INST-OPERAND-SIZE.
 160 (defun print-reg/mem (value stream dstate)
 161   (declare (type (or list full-reg) value)
 162            (type stream stream)
 163            (type sb!disassem:disassem-state dstate))
 164   (print-reg/mem-with-width
 165    value (inst-operand-size dstate) nil stream dstate))
 166
 167 ;; Same as print-reg/mem, but prints an explicit size indicator for
 168 ;; memory references.
 169 (defun print-sized-reg/mem (value stream dstate)
 170   (declare (type (or list full-reg) value)
 171            (type stream stream)
 172            (type sb!disassem:disassem-state dstate))
 173   (print-reg/mem-with-width
 174    value (inst-operand-size dstate) t stream dstate))
 175
 176 ;;; Same as print-sized-reg/mem, but with a default operand size of
 177 ;;; :qword.
 178 (defun print-sized-reg/mem-default-qword (value stream dstate)
 179   (declare (type (or list full-reg) value)
 180            (type stream stream)
 181            (type sb!disassem:disassem-state dstate))
 182   (print-reg/mem-with-width
 183    value (inst-operand-size-default-qword dstate) t stream dstate))
 184
 185 (defun print-sized-byte-reg/mem (value stream dstate)
 186   (declare (type (or list full-reg) value)
 187            (type stream stream)
 188            (type sb!disassem:disassem-state dstate))
 189   (print-reg/mem-with-width value :byte t stream dstate))
 190
 191 (defun print-sized-word-reg/mem (value stream dstate)
 192   (declare (type (or list full-reg) value)
 193            (type stream stream)
 194            (type sb!disassem:disassem-state dstate))
 195   (print-reg/mem-with-width value :word t stream dstate))
 196
 197 (defun print-sized-dword-reg/mem (value stream dstate)
 198   (declare (type (or list full-reg) value)
 199            (type stream stream)
 200            (type sb!disassem:disassem-state dstate))
 201   (print-reg/mem-with-width value :dword t stream dstate))
 202
 203 (defun print-label (value stream dstate)
 204   (declare (ignore dstate))
 205   (sb!disassem:princ16 value stream))
 206
 207 ;;; This prefilter is used solely for its side effects, namely to put
 208 ;;; the bits found in the REX prefix into the DSTATE for use by other
 209 ;;; prefilters and by printers.
 210 (defun prefilter-wrxb (value dstate)
 211   (declare (type (unsigned-byte 4) value)
 212            (type sb!disassem:disassem-state dstate))
 213   (sb!disassem:dstate-put-inst-prop dstate 'rex)
 214   (when (plusp (logand value #b1000))
 215     (sb!disassem:dstate-put-inst-prop dstate 'rex-w))
 216   (when (plusp (logand value #b0100))
 217     (sb!disassem:dstate-put-inst-prop dstate 'rex-r))
 218   (when (plusp (logand value #b0010))
 219     (sb!disassem:dstate-put-inst-prop dstate 'rex-x))
 220   (when (plusp (logand value #b0001))
 221     (sb!disassem:dstate-put-inst-prop dstate 'rex-b))
 222   value)
 223
 224 ;;; This prefilter is used solely for its side effect, namely to put
 225 ;;; the property OPERAND-SIZE-8 into the DSTATE if VALUE is 0.
 226 (defun prefilter-width (value dstate)
 227   (declare (type bit value)
 228            (type sb!disassem:disassem-state dstate))
 229   (when (zerop value)
 230     (sb!disassem:dstate-put-inst-prop dstate 'operand-size-8))
 231   value)
 232
 233 ;;; A register field that can be extended by REX.R.
 234 (defun prefilter-reg-r (value dstate)
 235   (declare (type reg value)
 236            (type sb!disassem:disassem-state dstate))
 237   (if (sb!disassem::dstate-get-inst-prop dstate 'rex-r)
 238       (+ value 8)
 239       value))
 240
 241 ;;; A register field that can be extended by REX.B.
 242 (defun prefilter-reg-b (value dstate)
 243   (declare (type reg value)
 244            (type sb!disassem:disassem-state dstate))
 245   (if (sb!disassem::dstate-get-inst-prop dstate 'rex-b)
 246       (+ value 8)
 247       value))
 248
 249 ;;; Returns either an integer, meaning a register, or a list of
 250 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
 251 ;;; may be missing or nil to indicate that it's not used or has the
 252 ;;; obvious default value (e.g., 1 for the index-scale). VALUE is a list
 253 ;;; of the mod and r/m field of the ModRM byte of the instruction.
 254 ;;; Depending on VALUE a SIB byte and/or an offset may be read. The
 255 ;;; REX.B bit from DSTATE is used to extend the sole register or the
 256 ;;; BASE-REG to a full register, the REX.X bit does the same for the
 257 ;;; INDEX-REG.
 258 (defun prefilter-reg/mem (value dstate)
 259   (declare (type list value)
 260            (type sb!disassem:disassem-state dstate))
 261   (let ((mod (first value))
 262         (r/m (second value)))
 263     (declare (type (unsigned-byte 2) mod)
 264              (type (unsigned-byte 3) r/m))
 265     (let ((full-reg (if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
 266                         (+ r/m 8)
 267                         r/m)))
 268       (declare (type full-reg full-reg))
 269       (cond ((= mod #b11)
 270              ;; registers
 271              full-reg)
 272             ((= r/m #b100)
 273              ;; sib byte
 274              (let ((sib (sb!disassem:read-suffix 8 dstate)))
 275                (declare (type (unsigned-byte 8) sib))
 276                (let ((base-reg (ldb (byte 3 0) sib))
 277                      (index-reg (ldb (byte 3 3) sib))
 278                      (index-scale (ldb (byte 2 6) sib)))
 279                  (declare (type (unsigned-byte 3) base-reg index-reg)
 280                           (type (unsigned-byte 2) index-scale))
 281                  (let* ((offset
 282                          (case mod
 283                                (#b00
 284                                 (if (= base-reg #b101)
 285                                     (sb!disassem:read-signed-suffix 32 dstate)
 286                                   nil))
 287                                (#b01
 288                                 (sb!disassem:read-signed-suffix 8 dstate))
 289                                (#b10
 290                                 (sb!disassem:read-signed-suffix 32 dstate)))))
 291                    (list (unless (and (= mod #b00) (= base-reg #b101))
 292                            (if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
 293                                (+ base-reg 8)
 294                                base-reg))
 295                          offset
 296                          (unless (= index-reg #b100)
 297                            (if (sb!disassem:dstate-get-inst-prop dstate 'rex-x)
 298                                (+ index-reg 8)
 299                                index-reg))
 300                          (ash 1 index-scale))))))
 301             ((and (= mod #b00) (= r/m #b101))
 302              (list 'rip (sb!disassem:read-signed-suffix 32 dstate)) )
 303             ((= mod #b00)
 304              (list full-reg))
 305             ((= mod #b01)
 306            (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
 307           (t                            ; (= mod #b10)
 308            (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
 309
 310 (defun read-address (value dstate)
 311   (declare (ignore value))              ; always nil anyway
 312   (sb!disassem:read-suffix (width-bits (inst-operand-size dstate)) dstate))
 313
 314 (defun width-bits (width)
 315   (ecase width
 316     (:byte 8)
 317     (:word 16)
 318     (:dword 32)
 319     (:qword 64)
 320     (:float 32)
 321     (:double 64)))
 322
 323 ) ; EVAL-WHEN
 324 \f
 325 ;;;; disassembler argument types
 326
 327 ;;; Used to capture the lower four bits of the REX prefix.
 328 (sb!disassem:define-arg-type wrxb
 329   :prefilter #'prefilter-wrxb)
 330
 331 (sb!disassem:define-arg-type width
 332   :prefilter #'prefilter-width
 333   :printer (lambda (value stream dstate)
 334              (declare (ignore value))
 335              (princ (schar (symbol-name (inst-operand-size dstate)) 0)
 336                     stream)))
 337
 338 (sb!disassem:define-arg-type displacement
 339   :sign-extend t
 340   :use-label #'offset-next
 341   :printer (lambda (value stream dstate)
 342              (sb!disassem:maybe-note-assembler-routine value nil dstate)
 343              (print-label value stream dstate)))
 344
 345 (sb!disassem:define-arg-type accum
 346   :printer (lambda (value stream dstate)
 347              (declare (ignore value)
 348                       (type stream stream)
 349                       (type sb!disassem:disassem-state dstate))
 350              (print-reg 0 stream dstate)))
 351
 352 (sb!disassem:define-arg-type reg
 353   :prefilter #'prefilter-reg-r
 354   :printer #'print-reg)
 355
 356 (sb!disassem:define-arg-type reg-b
 357   :prefilter #'prefilter-reg-b
 358   :printer #'print-reg)
 359
 360 (sb!disassem:define-arg-type reg-b-default-qword
 361   :prefilter #'prefilter-reg-b
 362   :printer #'print-reg-default-qword)
 363
 364 (sb!disassem:define-arg-type imm-addr
 365   :prefilter #'read-address
 366   :printer #'print-label)
 367
 368 ;;; Normally, immediate values for an operand size of :qword are of size
 369 ;;; :dword and are sign-extended to 64 bits. For an exception, see the
 370 ;;; argument type definition following this one.
 371 (sb!disassem:define-arg-type signed-imm-data
 372   :prefilter (lambda (value dstate)
 373                (declare (ignore value)) ; always nil anyway
 374                (let ((width (width-bits (inst-operand-size dstate))))
 375                  (when (= width 64)
 376                    (setf width 32))
 377                  (sb!disassem:read-signed-suffix width dstate))))
 378
 379 ;;; Used by the variant of the MOV instruction with opcode B8 which can
 380 ;;; move immediates of all sizes (i.e. including :qword) into a
 381 ;;; register.
 382 (sb!disassem:define-arg-type signed-imm-data-upto-qword
 383   :prefilter (lambda (value dstate)
 384                (declare (ignore value)) ; always nil anyway
 385                (sb!disassem:read-signed-suffix
 386                 (width-bits (inst-operand-size dstate))
 387                 dstate)))
 388
 389 ;;; Used by those instructions that have a default operand size of
 390 ;;; :qword. Nevertheless the immediate is at most of size :dword.
 391 ;;; The only instruction of this kind having a variant with an immediate
 392 ;;; argument is PUSH.
 393 (sb!disassem:define-arg-type signed-imm-data-default-qword
 394   :prefilter (lambda (value dstate)
 395                (declare (ignore value)) ; always nil anyway
 396                (let ((width (width-bits
 397                              (inst-operand-size-default-qword dstate))))
 398                  (when (= width 64)
 399                    (setf width 32))
 400                  (sb!disassem:read-signed-suffix width dstate))))
 401
 402 (sb!disassem:define-arg-type signed-imm-byte
 403   :prefilter (lambda (value dstate)
 404                (declare (ignore value)) ; always nil anyway
 405                (sb!disassem:read-signed-suffix 8 dstate)))
 406
 407 (sb!disassem:define-arg-type imm-byte
 408   :prefilter (lambda (value dstate)
 409                (declare (ignore value)) ; always nil anyway
 410                (sb!disassem:read-suffix 8 dstate)))
 411
 412 ;;; needed for the ret imm16 instruction
 413 (sb!disassem:define-arg-type imm-word-16
 414   :prefilter (lambda (value dstate)
 415                (declare (ignore value)) ; always nil anyway
 416                (sb!disassem:read-suffix 16 dstate)))
 417
 418 (sb!disassem:define-arg-type reg/mem
 419   :prefilter #'prefilter-reg/mem
 420   :printer #'print-reg/mem)
 421 (sb!disassem:define-arg-type sized-reg/mem
 422   ;; Same as reg/mem, but prints an explicit size indicator for
 423   ;; memory references.
 424   :prefilter #'prefilter-reg/mem
 425   :printer #'print-sized-reg/mem)
 426
 427 ;;; Arguments of type reg/mem with a fixed size.
 428 (sb!disassem:define-arg-type sized-byte-reg/mem
 429   :prefilter #'prefilter-reg/mem
 430   :printer #'print-sized-byte-reg/mem)
 431 (sb!disassem:define-arg-type sized-word-reg/mem
 432   :prefilter #'prefilter-reg/mem
 433   :printer #'print-sized-word-reg/mem)
 434 (sb!disassem:define-arg-type sized-dword-reg/mem
 435   :prefilter #'prefilter-reg/mem
 436   :printer #'print-sized-dword-reg/mem)
 437
 438 ;;; Same as sized-reg/mem, but with a default operand size of :qword.
 439 (sb!disassem:define-arg-type sized-reg/mem-default-qword
 440   :prefilter #'prefilter-reg/mem
 441   :printer #'print-sized-reg/mem-default-qword)
 442
 443 ;;; added by jrd
 444 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 445 (defun print-fp-reg (value stream dstate)
 446   (declare (ignore dstate))
 447   (format stream "FR~D" value))
 448 (defun prefilter-fp-reg (value dstate)
 449   ;; just return it
 450   (declare (ignore dstate))
 451   value)
 452 ) ; EVAL-WHEN
 453 (sb!disassem:define-arg-type fp-reg
 454                              :prefilter #'prefilter-fp-reg
 455                              :printer #'print-fp-reg)
 456
 457 (eval-when (:compile-toplevel :load-toplevel :execute)
 458 (defparameter *conditions*
 459   '((:o . 0)
 460     (:no . 1)
 461     (:b . 2) (:nae . 2) (:c . 2)
 462     (:nb . 3) (:ae . 3) (:nc . 3)
 463     (:eq . 4) (:e . 4) (:z . 4)
 464     (:ne . 5) (:nz . 5)
 465     (:be . 6) (:na . 6)
 466     (:nbe . 7) (:a . 7)
 467     (:s . 8)
 468     (:ns . 9)
 469     (:p . 10) (:pe . 10)
 470     (:np . 11) (:po . 11)
 471     (:l . 12) (:nge . 12)
 472     (:nl . 13) (:ge . 13)
 473     (:le . 14) (:ng . 14)
 474     (:nle . 15) (:g . 15)))
 475 (defparameter *condition-name-vec*
 476   (let ((vec (make-array 16 :initial-element nil)))
 477     (dolist (cond *conditions*)
 478       (when (null (aref vec (cdr cond)))
 479         (setf (aref vec (cdr cond)) (car cond))))
 480     vec))
 481 ) ; EVAL-WHEN
 482
 483 ;;; Set assembler parameters. (In CMU CL, this was done with
 484 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
 485 (eval-when (:compile-toplevel :load-toplevel :execute)
 486   (setf sb!assem:*assem-scheduler-p* nil))
 487
 488 (sb!disassem:define-arg-type condition-code
 489   :printer *condition-name-vec*)
 490
 491 (defun conditional-opcode (condition)
 492   (cdr (assoc condition *conditions* :test #'eq)))
 493 \f
 494 ;;;; disassembler instruction formats
 495
 496 (eval-when (:compile-toplevel :execute)
 497   (defun swap-if (direction field1 separator field2)
 498     `(:if (,direction :constant 0)
 499           (,field1 ,separator ,field2)
 500           (,field2 ,separator ,field1))))
 501
 502 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
 503   (op    :field (byte 8 0))
 504   ;; optional fields
 505   (accum :type 'accum)
 506   (imm))
 507
 508 ;;; A one-byte instruction with a #x66 prefix, used to indicate an
 509 ;;; operand size of :word.
 510 (sb!disassem:define-instruction-format (x66-byte 16
 511                                         :default-printer '(:name))
 512   (x66   :field (byte 8 0) :value #x66)
 513   (op    :field (byte 8 8)))
 514
 515 ;;; A one-byte instruction with a REX prefix, used to indicate an
 516 ;;; operand size of :qword. REX.W must be 1, the other three bits are
 517 ;;; ignored.
 518 (sb!disassem:define-instruction-format (rex-byte 16
 519                                         :default-printer '(:name))
 520   (rex   :field (byte 5 3) :value #b01001)
 521   (op    :field (byte 8 8)))
 522
 523 (sb!disassem:define-instruction-format (simple 8)
 524   (op    :field (byte 7 1))
 525   (width :field (byte 1 0) :type 'width)
 526   ;; optional fields
 527   (accum :type 'accum)
 528   (imm))
 529
 530 (sb!disassem:define-instruction-format (rex-simple 16)
 531   (rex     :field (byte 4 4)    :value #b0100)
 532   (wrxb    :field (byte 4 0)    :type 'wrxb)
 533   (op    :field (byte 7 9))
 534   (width :field (byte 1 8) :type 'width)
 535   ;; optional fields
 536   (accum :type 'accum)
 537   (imm))
 538
 539 ;;; Same as simple, but with direction bit
 540 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
 541   (op :field (byte 6 2))
 542   (dir :field (byte 1 1)))
 543
 544 ;;; Same as simple, but with the immediate value occurring by default,
 545 ;;; and with an appropiate printer.
 546 (sb!disassem:define-instruction-format (accum-imm 8
 547                                      :include 'simple
 548                                      :default-printer '(:name
 549                                                         :tab accum ", " imm))
 550   (imm :type 'signed-imm-data))
 551
 552 (sb!disassem:define-instruction-format (rex-accum-imm 16
 553                                      :include 'rex-simple
 554                                      :default-printer '(:name
 555                                                         :tab accum ", " imm))
 556   (imm :type 'signed-imm-data))
 557
 558 (sb!disassem:define-instruction-format (reg-no-width 8
 559                                      :default-printer '(:name :tab reg))
 560   (op    :field (byte 5 3))
 561   (reg   :field (byte 3 0) :type 'reg-b)
 562   ;; optional fields
 563   (accum :type 'accum)
 564   (imm))
 565
 566 (sb!disassem:define-instruction-format (rex-reg-no-width 16
 567                                      :default-printer '(:name :tab reg))
 568   (rex     :field (byte 4 4)    :value #b0100)
 569   (wrxb    :field (byte 4 0)    :type 'wrxb)
 570   (op      :field (byte 5 11))
 571   (reg     :field (byte 3 8)    :type 'reg-b)
 572   ;; optional fields
 573   (accum :type 'accum)
 574   (imm))
 575
 576 ;;; Same as reg-no-width, but with a default operand size of :qword.
 577 (sb!disassem:define-instruction-format (reg-no-width-default-qword 8
 578                                         :include 'reg-no-width
 579                                         :default-printer '(:name :tab reg))
 580   (reg   :type 'reg-b-default-qword))
 581
 582 ;;; Same as rex-reg-no-width, but with a default operand size of :qword.
 583 (sb!disassem:define-instruction-format (rex-reg-no-width-default-qword 16
 584                                         :include 'rex-reg-no-width
 585                                         :default-printer '(:name :tab reg))
 586   (reg     :type 'reg-b-default-qword))
 587
 588 (sb!disassem:define-instruction-format (modrm-reg-no-width 24
 589                                      :default-printer '(:name :tab reg))
 590   (rex     :field (byte 4 4)    :value #b0100)
 591   (wrxb    :field (byte 4 0)    :type 'wrxb)
 592   (ff   :field (byte 8 8)  :value #b11111111)
 593   (mod   :field (byte 2 22))
 594   (modrm-reg :field (byte 3 19))
 595   (reg     :field (byte 3 16)   :type 'reg-b)
 596   ;; optional fields
 597   (accum :type 'accum)
 598   (imm))
 599
 600 ;;; Adds a width field to reg-no-width. Note that we can't use
 601 ;;; :INCLUDE 'REG-NO-WIDTH here to save typing because that would put
 602 ;;; the WIDTH field last, but the prefilter for WIDTH must run before
 603 ;;; the one for IMM to be able to determine the correct size of IMM.
 604 (sb!disassem:define-instruction-format (reg 8
 605                                         :default-printer '(:name :tab reg))
 606   (op    :field (byte 4 4))
 607   (width :field (byte 1 3) :type 'width)
 608   (reg   :field (byte 3 0) :type 'reg-b)
 609   ;; optional fields
 610   (accum :type 'accum)
 611   (imm))
 612
 613 (sb!disassem:define-instruction-format (rex-reg 16
 614                                         :default-printer '(:name :tab reg))
 615   (rex     :field (byte 4 4)    :value #b0100)
 616   (wrxb    :field (byte 4 0)    :type 'wrxb)
 617   (width   :field (byte 1 11)   :type 'width)
 618   (op      :field (byte 4 12))
 619   (reg     :field (byte 3 8)    :type 'reg-b)
 620   ;; optional fields
 621   (accum   :type 'accum)
 622   (imm))
 623
 624 (sb!disassem:define-instruction-format (two-bytes 16
 625                                         :default-printer '(:name))
 626   (op :fields (list (byte 8 0) (byte 8 8))))
 627
 628 (sb!disassem:define-instruction-format (reg-reg/mem 16
 629                                         :default-printer
 630                                         `(:name :tab reg ", " reg/mem))
 631   (op      :field (byte 7 1))
 632   (width   :field (byte 1 0)    :type 'width)
 633   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 634                                 :type 'reg/mem)
 635   (reg     :field (byte 3 11)   :type 'reg)
 636   ;; optional fields
 637   (imm))
 638
 639 (sb!disassem:define-instruction-format (rex-reg-reg/mem 24
 640                                         :default-printer
 641                                         `(:name :tab reg ", " reg/mem))
 642   (rex     :field (byte 4 4)    :value #b0100)
 643   (wrxb    :field (byte 4 0)    :type 'wrxb)
 644   (width   :field (byte 1 8)    :type 'width)
 645   (op      :field (byte 7 9))
 646   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 647                                 :type 'reg/mem)
 648   (reg     :field (byte 3 19)   :type 'reg)
 649   ;; optional fields
 650   (imm))
 651
 652 ;;; same as reg-reg/mem, but with direction bit
 653 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
 654                                         :include 'reg-reg/mem
 655                                         :default-printer
 656                                         `(:name
 657                                           :tab
 658                                           ,(swap-if 'dir 'reg/mem ", " 'reg)))
 659   (op  :field (byte 6 2))
 660   (dir :field (byte 1 1)))
 661
 662 (sb!disassem:define-instruction-format (rex-reg-reg/mem-dir 24
 663                                         :include 'rex-reg-reg/mem
 664                                         :default-printer
 665                                         `(:name
 666                                           :tab
 667                                           ,(swap-if 'dir 'reg/mem ", " 'reg)))
 668   (op  :field (byte 6 10))
 669   (dir :field (byte 1 9)))
 670
 671 ;;; Same as reg-reg/mem, but uses the reg field as a second op code.
 672 (sb!disassem:define-instruction-format (reg/mem 16
 673                                         :default-printer '(:name :tab reg/mem))
 674   (op      :fields (list (byte 7 1) (byte 3 11)))
 675   (width   :field (byte 1 0)    :type 'width)
 676   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 677                                 :type 'sized-reg/mem)
 678   ;; optional fields
 679   (imm))
 680
 681 (sb!disassem:define-instruction-format (rex-reg/mem 24
 682                                         :default-printer '(:name :tab reg/mem))
 683   (rex     :field (byte 4 4)    :value #b0100)
 684   (wrxb    :field (byte 4 0)    :type 'wrxb)
 685   (op      :fields (list (byte 7 9) (byte 3 19)))
 686   (width   :field (byte 1 8)    :type 'width)
 687   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 688                                 :type 'sized-reg/mem)
 689   ;; optional fields
 690   (imm))
 691
 692 ;;; Same as reg/mem, but without a width field and with a default
 693 ;;; operand size of :qword.
 694 (sb!disassem:define-instruction-format (reg/mem-default-qword 16
 695                                         :default-printer '(:name :tab reg/mem))
 696   (op      :fields (list (byte 8 0) (byte 3 11)))
 697   (reg/mem :fields (list (byte 2 14) (byte 3 8))
 698                                 :type 'sized-reg/mem-default-qword))
 699
 700 (sb!disassem:define-instruction-format (rex-reg/mem-default-qword 24
 701                                         :default-printer '(:name :tab reg/mem))
 702   (rex     :field (byte 4 4)    :value #b0100)
 703   (wrxb    :field (byte 4 0)    :type 'wrxb)
 704   (op      :fields (list (byte 8 8) (byte 3 19)))
 705   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 706                                 :type 'sized-reg/mem-default-qword))
 707
 708 ;;; Same as reg/mem, but with the immediate value occurring by default,
 709 ;;; and with an appropiate printer.
 710 (sb!disassem:define-instruction-format (reg/mem-imm 16
 711                                         :include 'reg/mem
 712                                         :default-printer
 713                                         '(:name :tab reg/mem ", " imm))
 714   (reg/mem :type 'sized-reg/mem)
 715   (imm     :type 'signed-imm-data))
 716
 717 (sb!disassem:define-instruction-format (rex-reg/mem-imm 24
 718                                         :include 'rex-reg/mem
 719                                         :default-printer
 720                                         '(:name :tab reg/mem ", " imm))
 721   (reg/mem :type 'sized-reg/mem)
 722   (imm     :type 'signed-imm-data))
 723
 724 ;;; Same as reg/mem, but with using the accumulator in the default printer
 725 (sb!disassem:define-instruction-format
 726     (accum-reg/mem 16
 727      :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
 728   (reg/mem :type 'reg/mem)              ; don't need a size
 729   (accum :type 'accum))
 730
 731 (sb!disassem:define-instruction-format (rex-accum-reg/mem 24
 732                                         :include 'rex-reg/mem
 733                                         :default-printer
 734                                         '(:name :tab accum ", " reg/mem))
 735   (reg/mem :type 'reg/mem)              ; don't need a size
 736   (accum   :type 'accum))
 737
 738 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
 739 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
 740                                         :default-printer
 741                                         `(:name :tab reg ", " reg/mem))
 742   (prefix  :field (byte 8 0)    :value #b00001111)
 743   (op      :field (byte 7 9))
 744   (width   :field (byte 1 8)    :type 'width)
 745   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 746                                 :type 'reg/mem)
 747   (reg     :field (byte 3 19)   :type 'reg)
 748   ;; optional fields
 749   (imm))
 750
 751 (sb!disassem:define-instruction-format (ext-reg-reg/mem-no-width 24
 752                                         :default-printer
 753                                         `(:name :tab reg ", " reg/mem))
 754   (prefix  :field (byte 8 0)    :value #b00001111)
 755   (op      :field (byte 8 8))
 756   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 757                                 :type 'reg/mem)
 758   (reg     :field (byte 3 19)   :type 'reg))
 759
 760 (sb!disassem:define-instruction-format (rex-ext-reg-reg/mem-no-width 32
 761                                         :default-printer
 762                                         `(:name :tab reg ", " reg/mem))
 763   (rex     :field (byte 4 4)    :value #b0100)
 764   (wrxb    :field (byte 4 0)    :type 'wrxb)
 765   (prefix  :field (byte 8 8)    :value #b00001111)
 766   (op      :field (byte 8 16))
 767   (reg/mem :fields (list (byte 2 30) (byte 3 24))
 768                                 :type 'reg/mem)
 769   (reg     :field (byte 3 27)   :type 'reg))
 770
 771 ;;; Same as reg-reg/mem, but with a prefix of #xf2 0f
 772 (sb!disassem:define-instruction-format (xmm-ext-reg-reg/mem 32
 773                                         :default-printer
 774                                         `(:name :tab reg ", " reg/mem))
 775   (prefix  :field (byte 8 0)    :value #xf2)
 776   (prefix2  :field (byte 8 8)   :value #x0f)
 777   (op      :field (byte 7 17))
 778   (width   :field (byte 1 16)   :type 'width)
 779   (reg/mem :fields (list (byte 2 30) (byte 3 24))
 780                                 :type 'reg/mem)
 781   (reg     :field (byte 3 27)   :type 'reg)
 782   ;; optional fields
 783   (imm))
 784
 785 ;;; reg-no-width with #x0f prefix
 786 (sb!disassem:define-instruction-format (ext-reg-no-width 16
 787                                         :default-printer '(:name :tab reg))
 788   (prefix  :field (byte 8 0)    :value #b00001111)
 789   (op    :field (byte 5 11))
 790   (reg   :field (byte 3 8) :type 'reg-b))
 791
 792 ;;; Same as reg/mem, but with a prefix of #b00001111
 793 (sb!disassem:define-instruction-format (ext-reg/mem 24
 794                                         :default-printer '(:name :tab reg/mem))
 795   (prefix  :field (byte 8 0)    :value #b00001111)
 796   (op      :fields (list (byte 7 9) (byte 3 19)))
 797   (width   :field (byte 1 8)    :type 'width)
 798   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 799                                 :type 'sized-reg/mem)
 800   ;; optional fields
 801   (imm))
 802
 803 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
 804                                         :include 'ext-reg/mem
 805                                         :default-printer
 806                                         '(:name :tab reg/mem ", " imm))
 807   (imm :type 'signed-imm-data))
 808 \f
 809 ;;;; This section was added by jrd, for fp instructions.
 810
 811 ;;; regular fp inst to/from registers/memory
 812 (sb!disassem:define-instruction-format (floating-point 16
 813                                         :default-printer
 814                                         `(:name :tab reg/mem))
 815   (prefix :field (byte 5 3) :value #b11011)
 816   (op     :fields (list (byte 3 0) (byte 3 11)))
 817   (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
 818
 819 ;;; fp insn to/from fp reg
 820 (sb!disassem:define-instruction-format (floating-point-fp 16
 821                                         :default-printer `(:name :tab fp-reg))
 822   (prefix :field (byte 5 3) :value #b11011)
 823   (suffix :field (byte 2 14) :value #b11)
 824   (op     :fields (list (byte 3 0) (byte 3 11)))
 825   (fp-reg :field (byte 3 8) :type 'fp-reg))
 826
 827 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
 828 (sb!disassem:define-instruction-format
 829  (floating-point-fp-d 16
 830    :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
 831   (prefix :field (byte 5 3) :value #b11011)
 832   (suffix :field (byte 2 14) :value #b11)
 833   (op     :fields (list (byte 2 0) (byte 3 11)))
 834   (d      :field (byte 1 2))
 835   (fp-reg :field (byte 3 8) :type 'fp-reg))
 836
 837
 838 ;;; (added by (?) pfw)
 839 ;;; fp no operand isns
 840 (sb!disassem:define-instruction-format (floating-point-no 16
 841                                       :default-printer '(:name))
 842   (prefix :field (byte 8  0) :value #b11011001)
 843   (suffix :field (byte 3 13) :value #b111)
 844   (op     :field (byte 5  8)))
 845
 846 (sb!disassem:define-instruction-format (floating-point-3 16
 847                                       :default-printer '(:name))
 848   (prefix :field (byte 5 3) :value #b11011)
 849   (suffix :field (byte 2 14) :value #b11)
 850   (op     :fields (list (byte 3 0) (byte 6 8))))
 851
 852 (sb!disassem:define-instruction-format (floating-point-5 16
 853                                       :default-printer '(:name))
 854   (prefix :field (byte 8  0) :value #b11011011)
 855   (suffix :field (byte 3 13) :value #b111)
 856   (op     :field (byte 5  8)))
 857
 858 (sb!disassem:define-instruction-format (floating-point-st 16
 859                                       :default-printer '(:name))
 860   (prefix :field (byte 8  0) :value #b11011111)
 861   (suffix :field (byte 3 13) :value #b111)
 862   (op     :field (byte 5  8)))
 863
 864 (sb!disassem:define-instruction-format (string-op 8
 865                                      :include 'simple
 866                                      :default-printer '(:name width)))
 867
 868 (sb!disassem:define-instruction-format (rex-string-op 16
 869                                      :include 'rex-simple
 870                                      :default-printer '(:name width)))
 871
 872 (sb!disassem:define-instruction-format (short-cond-jump 16)
 873   (op    :field (byte 4 4))
 874   (cc    :field (byte 4 0) :type 'condition-code)
 875   (label :field (byte 8 8) :type 'displacement))
 876
 877 (sb!disassem:define-instruction-format (short-jump 16
 878                                      :default-printer '(:name :tab label))
 879   (const :field (byte 4 4) :value #b1110)
 880   (op    :field (byte 4 0))
 881   (label :field (byte 8 8) :type 'displacement))
 882
 883 (sb!disassem:define-instruction-format (near-cond-jump 16)
 884   (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
 885   (cc    :field (byte 4 8) :type 'condition-code)
 886   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 887   ;; long, so we fake it by using a prefilter to read the offset.
 888   (label :type 'displacement
 889          :prefilter (lambda (value dstate)
 890                       (declare (ignore value)) ; always nil anyway
 891                       (sb!disassem:read-signed-suffix 32 dstate))))
 892
 893 (sb!disassem:define-instruction-format (near-jump 8
 894                                      :default-printer '(:name :tab label))
 895   (op    :field (byte 8 0))
 896   ;; The disassembler currently doesn't let you have an instruction > 32 bits
 897   ;; long, so we fake it by using a prefilter to read the address.
 898   (label :type 'displacement
 899          :prefilter (lambda (value dstate)
 900                       (declare (ignore value)) ; always nil anyway
 901                       (sb!disassem:read-signed-suffix 32 dstate))))
 902
 903
 904 (sb!disassem:define-instruction-format (cond-set 24
 905                                      :default-printer '('set cc :tab reg/mem))
 906   (prefix :field (byte 8 0) :value #b00001111)
 907   (op    :field (byte 4 12) :value #b1001)
 908   (cc    :field (byte 4 8) :type 'condition-code)
 909   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 910            :type 'sized-byte-reg/mem)
 911   (reg     :field (byte 3 19)   :value #b000))
 912
 913 (sb!disassem:define-instruction-format (cond-move 24
 914                                      :default-printer
 915                                         '('cmov cc :tab reg ", " reg/mem))
 916   (prefix  :field (byte 8 0)    :value #b00001111)
 917   (op      :field (byte 4 12)   :value #b0100)
 918   (cc      :field (byte 4 8)    :type 'condition-code)
 919   (reg/mem :fields (list (byte 2 22) (byte 3 16))
 920                                 :type 'reg/mem)
 921   (reg     :field (byte 3 19)   :type 'reg))
 922
 923 (sb!disassem:define-instruction-format (rex-cond-move 32
 924                                      :default-printer
 925                                         '('cmov cc :tab reg ", " reg/mem))
 926   (rex     :field (byte 4 4)   :value #b0100)
 927   (wrxb    :field (byte 4 0)    :type 'wrxb)
 928   (prefix  :field (byte 8 8)    :value #b00001111)
 929   (op      :field (byte 4 20)   :value #b0100)
 930   (cc      :field (byte 4 16)    :type 'condition-code)
 931   (reg/mem :fields (list (byte 2 30) (byte 3 24))
 932                                 :type 'reg/mem)
 933   (reg     :field (byte 3 27)   :type 'reg))
 934
 935 (sb!disassem:define-instruction-format (enter-format 32
 936                                      :default-printer '(:name
 937                                                         :tab disp
 938                                                         (:unless (:constant 0)
 939                                                           ", " level)))
 940   (op :field (byte 8 0))
 941   (disp :field (byte 16 8))
 942   (level :field (byte 8 24)))
 943
 944 ;;; Single byte instruction with an immediate byte argument.
 945 (sb!disassem:define-instruction-format (byte-imm 16
 946                                      :default-printer '(:name :tab code))
 947  (op :field (byte 8 0))
 948  (code :field (byte 8 8)))
 949 \f
 950 ;;;; primitive emitters
 951
 952 (define-bitfield-emitter emit-word 16
 953   (byte 16 0))
 954
 955 (define-bitfield-emitter emit-dword 32
 956   (byte 32 0))
 957
 958 (define-bitfield-emitter emit-qword 64
 959   (byte 64 0))
 960
 961 (define-bitfield-emitter emit-byte-with-reg 8
 962   (byte 5 3) (byte 3 0))
 963
 964 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
 965   (byte 2 6) (byte 3 3) (byte 3 0))
 966
 967 (define-bitfield-emitter emit-sib-byte 8
 968   (byte 2 6) (byte 3 3) (byte 3 0))
 969
 970 (define-bitfield-emitter emit-rex-byte 8
 971   (byte 4 4) (byte 1 3) (byte 1 2) (byte 1 1) (byte 1 0))
 972
 973
 974 \f
 975 ;;;; fixup emitters
 976
 977 (defun emit-absolute-fixup (segment fixup &optional quad-p)
 978   (note-fixup segment (if quad-p :absolute64 :absolute) fixup)
 979   (let ((offset (fixup-offset fixup)))
 980     (if (label-p offset)
 981         (emit-back-patch segment
 982                          (if quad-p 8 4)
 983                          (lambda (segment posn)
 984                            (declare (ignore posn))
 985                            (let ((val  (- (+ (component-header-length)
 986                                              (or (label-position offset)
 987                                                  0))
 988                                           other-pointer-lowtag)))
 989                              (if quad-p
 990                                  (emit-qword segment val )
 991                                  (emit-dword segment val )))))
 992         (if quad-p
 993             (emit-qword segment (or offset 0))
 994             (emit-dword segment (or offset 0))))))
 995
 996 (defun emit-relative-fixup (segment fixup)
 997   (note-fixup segment :relative fixup)
 998   (emit-dword segment (or (fixup-offset fixup) 0)))
 999
1000 \f
1001 ;;;; the effective-address (ea) structure
1002
1003 (defun reg-tn-encoding (tn)
1004   (declare (type tn tn))
1005   (aver (member  (sb-name (sc-sb (tn-sc tn))) '(registers float-registers)))
1006   ;; ea only has space for three bits of register number: regs r8
1007   ;; and up are selected by a REX prefix byte which caller is responsible
1008   ;; for having emitted where necessary already
1009   (cond ((fp-reg-tn-p tn)
1010          (mod (tn-offset tn) 8))
1011         (t
1012          (let ((offset (mod (tn-offset tn) 16)))
1013            (logior (ash (logand offset 1) 2)
1014                    (ash offset -1))))))
1015
1016 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
1017                (:copier nil))
1018   ;; note that we can represent an EA with a QWORD size, but EMIT-EA
1019   ;; can't actually emit it on its own: caller also needs to emit REX
1020   ;; prefix
1021   (size nil :type (member :byte :word :dword :qword))
1022   (base nil :type (or tn null))
1023   (index nil :type (or tn null))
1024   (scale 1 :type (member 1 2 4 8))
1025   (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
1026 (def!method print-object ((ea ea) stream)
1027   (cond ((or *print-escape* *print-readably*)
1028          (print-unreadable-object (ea stream :type t)
1029            (format stream
1030                    "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
1031                    (ea-size ea)
1032                    (ea-base ea)
1033                    (ea-index ea)
1034                    (let ((scale (ea-scale ea)))
1035                      (if (= scale 1) nil scale))
1036                    (ea-disp ea))))
1037         (t
1038          (format stream "~A PTR [" (symbol-name (ea-size ea)))
1039          (when (ea-base ea)
1040            (write-string (sb!c::location-print-name (ea-base ea)) stream)
1041            (when (ea-index ea)
1042              (write-string "+" stream)))
1043          (when (ea-index ea)
1044            (write-string (sb!c::location-print-name (ea-index ea)) stream))
1045          (unless (= (ea-scale ea) 1)
1046            (format stream "*~A" (ea-scale ea)))
1047          (typecase (ea-disp ea)
1048            (null)
1049            (integer
1050             (format stream "~@D" (ea-disp ea)))
1051            (t
1052             (format stream "+~A" (ea-disp ea))))
1053          (write-char #\] stream))))
1054
1055 (defun emit-constant-tn-rip (segment constant-tn reg)
1056   ;; AMD64 doesn't currently have a code object register to use as a
1057   ;; base register for constant access. Instead we use RIP-relative
1058   ;; addressing. The offset from the SIMPLE-FUN-HEADER to the instruction
1059   ;; is passed to the backpatch callback. In addition we need the offset
1060   ;; from the start of the function header to the slot in the CODE-HEADER
1061   ;; that stores the constant. Since we don't know where the code header
1062   ;; starts, instead count backwards from the function header.
1063   (let* ((2comp (component-info *component-being-compiled*))
1064          (constants (ir2-component-constants 2comp))
1065          (len (length constants))
1066          ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
1067          ;; If there are an even amount of constants, there will be
1068          ;; an extra qword of padding before the function header, which
1069          ;; needs to be adjusted for. XXX: This will break if new slots
1070          ;; are added to the code header.
1071          (offset (* (- (+ len (if (evenp len)
1072                                   1
1073                                   2))
1074                        (tn-offset constant-tn))
1075                     n-word-bytes)))
1076     ;; RIP-relative addressing
1077     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
1078     (emit-back-patch segment
1079                      4
1080                      (lambda (segment posn)
1081                        ;; The addressing is relative to end of instruction,
1082                        ;; i.e. the end of this dword. Hence the + 4.
1083                        (emit-dword segment (+ 4 (- (+ offset posn)))))))
1084   (values))
1085
1086 (defun emit-label-rip (segment fixup reg)
1087   (let ((label (fixup-offset fixup)))
1088     ;; RIP-relative addressing
1089     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
1090     (emit-back-patch segment
1091                      4
1092                      (lambda (segment posn)
1093                        (emit-dword segment (- (label-position label)
1094                                               (+ posn 4))))))
1095   (values))
1096
1097 (defun emit-ea (segment thing reg &optional allow-constants)
1098   (etypecase thing
1099     (tn
1100      ;; this would be eleganter if we had a function that would create
1101      ;; an ea given a tn
1102      (ecase (sb-name (sc-sb (tn-sc thing)))
1103        ((registers float-registers)
1104         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
1105        (stack
1106         ;; Convert stack tns into an index off RBP.
1107         (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
1108           (cond ((< -128 disp 127)
1109                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
1110                  (emit-byte segment disp))
1111                 (t
1112                  (emit-mod-reg-r/m-byte segment #b10 reg #b101)
1113                  (emit-dword segment disp)))))
1114        (constant
1115         (unless allow-constants
1116           ;; Why?
1117           (error
1118            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
1119         (emit-constant-tn-rip segment thing reg))))
1120     (ea
1121      (let* ((base (ea-base thing))
1122             (index (ea-index thing))
1123             (scale (ea-scale thing))
1124             (disp (ea-disp thing))
1125             (mod (cond ((or (null base)
1126                             (and (eql disp 0)
1127                                  (not (= (reg-tn-encoding base) #b101))))
1128                         #b00)
1129                        ((and (fixnump disp) (<= -128 disp 127))
1130                         #b01)
1131                        (t
1132                         #b10)))
1133             (r/m (cond (index #b100)
1134                        ((null base) #b101)
1135                        (t (reg-tn-encoding base)))))
1136        (when (and (= mod 0) (= r/m #b101))
1137          ;; this is rip-relative in amd64, so we'll use a sib instead
1138          (setf r/m #b100 scale 1))
1139        (emit-mod-reg-r/m-byte segment mod reg r/m)
1140        (when (= r/m #b100)
1141          (let ((ss (1- (integer-length scale)))
1142                (index (if (null index)
1143                           #b100
1144                           (let ((index (reg-tn-encoding index)))
1145                             (if (= index #b100)
1146                                 (error "can't index off of ESP")
1147                                 index))))
1148                (base (if (null base)
1149                          #b101
1150                          (reg-tn-encoding base))))
1151            (emit-sib-byte segment ss index base)))
1152        (cond ((= mod #b01)
1153               (emit-byte segment disp))
1154              ((or (= mod #b10) (null base))
1155               (if (fixup-p disp)
1156                   (emit-absolute-fixup segment disp)
1157                   (emit-dword segment disp))))))
1158     (fixup
1159      (typecase (fixup-offset thing)
1160        (label
1161         (emit-label-rip segment thing reg))
1162        (t
1163         (emit-mod-reg-r/m-byte segment #b00 reg #b100)
1164         (emit-sib-byte segment 0 #b100 #b101)
1165         (emit-absolute-fixup segment thing))))))
1166
1167 (defun fp-reg-tn-p (thing)
1168   (and (tn-p thing)
1169        (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
1170
1171 ;;; like the above, but for fp-instructions--jrd
1172 (defun emit-fp-op (segment thing op)
1173   (if (fp-reg-tn-p thing)
1174       (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
1175                                                  (byte 3 0)
1176                                                  #b11000000)))
1177     (emit-ea segment thing op)))
1178
1179 (defun byte-reg-p (thing)
1180   (and (tn-p thing)
1181        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
1182        (member (sc-name (tn-sc thing)) *byte-sc-names*)
1183        t))
1184
1185 (defun byte-ea-p (thing)
1186   (typecase thing
1187     (ea (eq (ea-size thing) :byte))
1188     (tn
1189      (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
1190     (t nil)))
1191
1192 (defun word-reg-p (thing)
1193   (and (tn-p thing)
1194        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
1195        (member (sc-name (tn-sc thing)) *word-sc-names*)
1196        t))
1197
1198 (defun word-ea-p (thing)
1199   (typecase thing
1200     (ea (eq (ea-size thing) :word))
1201     (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
1202     (t nil)))
1203
1204 (defun dword-reg-p (thing)
1205   (and (tn-p thing)
1206        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
1207        (member (sc-name (tn-sc thing)) *dword-sc-names*)
1208        t))
1209
1210 (defun dword-ea-p (thing)
1211   (typecase thing
1212     (ea (eq (ea-size thing) :dword))
1213     (tn
1214      (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
1215     (t nil)))
1216
1217 (defun qword-reg-p (thing)
1218   (and (tn-p thing)
1219        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
1220        (member (sc-name (tn-sc thing)) *qword-sc-names*)
1221        t))
1222
1223 (defun qword-ea-p (thing)
1224   (typecase thing
1225     (ea (eq (ea-size thing) :qword))
1226     (tn
1227      (and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
1228     (t nil)))
1229
1230 (defun register-p (thing)
1231   (and (tn-p thing)
1232        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
1233
1234 (defun accumulator-p (thing)
1235   (and (register-p thing)
1236        (= (tn-offset thing) 0)))
1237
1238 \f
1239 ;;;; utilities
1240
1241 (def!constant +operand-size-prefix-byte+ #b01100110)
1242
1243 (defun maybe-emit-operand-size-prefix (segment size)
1244   (unless (or (eq size :byte)
1245               (eq size :qword)          ; REX prefix handles this
1246               (eq size +default-operand-size+))
1247     (emit-byte segment +operand-size-prefix-byte+)))
1248
1249 ;;; A REX prefix must be emitted if at least one of the following
1250 ;;; conditions is true:
1251 ;;  1. The operand size is :QWORD and the default operand size of the
1252 ;;     instruction is not :QWORD.
1253 ;;; 2. The instruction references an extended register.
1254 ;;; 3. The instruction references one of the byte registers SIL, DIL,
1255 ;;;    SPL or BPL.
1256
1257 ;;; Emit a REX prefix if necessary. OPERAND-SIZE is used to determine
1258 ;;; whether to set REX.W. Callers pass it explicitly as :DO-NOT-SET if
1259 ;;; this should not happen, for example because the instruction's
1260 ;;; default operand size is qword. R, X and B are NIL or TNs specifying
1261 ;;; registers the encodings of which are extended with the REX.R, REX.X
1262 ;;; and REX.B bit, respectively. To determine whether one of the byte
1263 ;;; registers is used that can only be accessed using a REX prefix, we
1264 ;;; need only to test R and B, because X is only used for the index
1265 ;;; register of an effective address and therefore never byte-sized.
1266 ;;; For R we can avoid to calculate the size of the TN because it is
1267 ;;; always OPERAND-SIZE. The size of B must be calculated here because
1268 ;;; B can be address-sized (if it is the base register of an effective
1269 ;;; address), of OPERAND-SIZE (if the instruction operates on two
1270 ;;; registers) or of some different size (in the instructions that
1271 ;;; combine arguments of different sizes: MOVZX, MOVSX, MOVSXD).
1272 ;;; We don't distinguish between general purpose and floating point
1273 ;;; registers for this cause because only general purpose registers can
1274 ;;; be byte-sized at all.
1275 (defun maybe-emit-rex-prefix (segment operand-size r x b)
1276   (declare (type (member nil :byte :word :dword :qword :float :double
1277                          :do-not-set)
1278                  operand-size)
1279            (type (or null tn) r x b))
1280   (labels ((if-hi (r)
1281              (if (and r (> (tn-offset r)
1282                            ;; offset of r8 is 16, offset of xmm8 is 8
1283                            (if (fp-reg-tn-p r)
1284                                7
1285                                15)))
1286                  1
1287                  0))
1288            (reg-4-7-p (r)
1289              ;; Assuming R is a TN describing a general purpose
1290              ;; register, return true if it references register
1291              ;; 4 upto 7.
1292              (<= 8 (tn-offset r) 15)))
1293     (let ((rex-w (if (eq operand-size :qword) 1 0))
1294           (rex-r (if-hi r))
1295           (rex-x (if-hi x))
1296           (rex-b (if-hi b)))
1297       (when (or (not (zerop (logior rex-w rex-r rex-x rex-b)))
1298                 (and r
1299                      (eq operand-size :byte)
1300                      (reg-4-7-p r))
1301                 (and b
1302                      (eq (operand-size b) :byte)
1303                      (reg-4-7-p b)))
1304         (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
1305
1306 ;;; Emit a REX prefix if necessary. The operand size is determined from
1307 ;;; THING or can be overwritten by OPERAND-SIZE. This and REG are always
1308 ;;; passed to MAYBE-EMIT-REX-PREFIX. Additionally, if THING is an EA we
1309 ;;; pass its index and base registers, if it is a register TN, we pass
1310 ;;; only itself.
1311 ;;; In contrast to EMIT-EA above, neither stack TNs nor fixups need to
1312 ;;; be treated specially here: If THING is a stack TN, neither it nor
1313 ;;; any of its components are passed to MAYBE-EMIT-REX-PREFIX which
1314 ;;; works correctly because stack references always use RBP as the base
1315 ;;; register and never use an index register so no extended registers
1316 ;;; need to be accessed. Fixups are assembled using an addressing mode
1317 ;;; of displacement-only or RIP-plus-displacement (see EMIT-EA), so may
1318 ;;; not reference an extended register. The displacement-only addressing
1319 ;;; mode requires that REX.X is 0, which is ensured here.
1320 (defun maybe-emit-rex-for-ea (segment thing reg &key operand-size)
1321   (declare (type (or ea tn fixup) thing)
1322            (type (or null tn) reg)
1323            (type (member nil :byte :word :dword :qword :float :double
1324                          :do-not-set)
1325                  operand-size))
1326   (let ((ea-p (ea-p thing)))
1327     (maybe-emit-rex-prefix segment
1328                            (or operand-size (operand-size thing))
1329                            reg
1330                            (and ea-p (ea-index thing))
1331                            (cond (ea-p (ea-base thing))
1332                                  ((and (tn-p thing)
1333                                        (member (sb-name (sc-sb (tn-sc thing)))
1334                                                '(float-registers registers)))
1335                                   thing)
1336                                  (t nil)))))
1337
1338 (defun operand-size (thing)
1339   (typecase thing
1340     (tn
1341      ;; FIXME: might as well be COND instead of having to use #. readmacro
1342      ;; to hack up the code
1343      (case (sc-name (tn-sc thing))
1344        (#.*qword-sc-names*
1345         :qword)
1346        (#.*dword-sc-names*
1347         :dword)
1348        (#.*word-sc-names*
1349         :word)
1350        (#.*byte-sc-names*
1351         :byte)
1352        ;; added by jrd: float-registers is a separate size (?)
1353        (#.*float-sc-names*
1354         :float)
1355        (#.*double-sc-names*
1356         :double)
1357        (t
1358         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
1359     (ea
1360      (ea-size thing))
1361     (fixup
1362      ;; GNA.  Guess who spelt "flavor" correctly first time round?
1363      ;; There's a strong argument in my mind to change all uses of
1364      ;; "flavor" to "kind": and similarly with some misguided uses of
1365      ;; "type" here and there.  -- CSR, 2005-01-06.
1366      (case (fixup-flavor thing)
1367        ((:foreign-dataref) :qword)))
1368     (t
1369      nil)))
1370
1371 (defun matching-operand-size (dst src)
1372   (let ((dst-size (operand-size dst))
1373         (src-size (operand-size src)))
1374     (if dst-size
1375         (if src-size
1376             (if (eq dst-size src-size)
1377                 dst-size
1378                 (error "size mismatch: ~S is a ~S and ~S is a ~S."
1379                        dst dst-size src src-size))
1380             dst-size)
1381         (if src-size
1382             src-size
1383             (error "can't tell the size of either ~S or ~S" dst src)))))
1384
1385 (defun emit-sized-immediate (segment size value &optional quad-p)
1386   (ecase size
1387     (:byte
1388      (emit-byte segment value))
1389     (:word
1390      (emit-word segment value))
1391     ((:dword :qword)
1392      ;; except in a very few cases (MOV instructions A1,A3,B8) we expect
1393      ;; dword data bytes even when 64 bit work is being done.  So, mostly
1394      ;; we treat quad constants as dwords.
1395      (if (and quad-p (eq size :qword))
1396          (emit-qword segment value)
1397          (emit-dword segment value)))))
1398 \f
1399 ;;;; general data transfer
1400
1401 (define-instruction mov (segment dst src)
1402   ;; immediate to register
1403   (:printer reg ((op #b1011) (imm nil :type 'signed-imm-data))
1404             '(:name :tab reg ", " imm))
1405   (:printer rex-reg ((op #b1011) (imm nil :type 'signed-imm-data-upto-qword))
1406             '(:name :tab reg ", " imm))
1407   ;; absolute mem to/from accumulator
1408   (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
1409             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
1410   ;; register to/from register/memory
1411   (:printer reg-reg/mem-dir ((op #b100010)))
1412   (:printer rex-reg-reg/mem-dir ((op #b100010)))
1413   ;; immediate to register/memory
1414   (:printer reg/mem-imm ((op '(#b1100011 #b000))))
1415   (:printer rex-reg/mem-imm ((op '(#b1100011 #b000))))
1416
1417   (:emitter
1418    (let ((size (matching-operand-size dst src)))
1419      (maybe-emit-operand-size-prefix segment size)
1420      (cond ((register-p dst)
1421             (cond ((integerp src)
1422                    (maybe-emit-rex-prefix segment size nil nil dst)
1423                    (cond ((and (eq size :qword)
1424                                (typep src '(signed-byte 31)))
1425                           ;; When loading small immediates to a qword register
1426                           ;; using B8 wastes 3 bytes compared to C7.
1427                           (emit-byte segment #b11000111)
1428                           (emit-mod-reg-r/m-byte segment #b11
1429                                                  #b000
1430                                                  (reg-tn-encoding dst))
1431                           (emit-sized-immediate segment :dword src nil))
1432                          (t
1433                           (emit-byte-with-reg segment
1434                                               (if (eq size :byte)
1435                                                   #b10110
1436                                                   #b10111)
1437                                               (reg-tn-encoding dst))
1438                           (emit-sized-immediate segment size src
1439                                                 (eq size :qword)))))
1440                   (t
1441                    (maybe-emit-rex-for-ea segment src dst)
1442                    (emit-byte segment
1443                               (if (eq size :byte)
1444                                   #b10001010
1445                                   #b10001011))
1446                    (emit-ea segment src (reg-tn-encoding dst) t))))
1447            ((integerp src)
1448             ;; C7 only deals with 32 bit immediates even if register is
1449             ;; 64 bit: only b8-bf use 64 bit immediates
1450             (maybe-emit-rex-for-ea segment dst nil)
1451             (cond ((typep src '(or (signed-byte 32) (unsigned-byte 32)))
1452                    (emit-byte segment
1453                               (if (eq size :byte) #b11000110 #b11000111))
1454                    (emit-ea segment dst #b000)
1455                    (emit-sized-immediate segment
1456                                          (case size (:qword :dword) (t size))
1457                                          src))
1458                   (t
1459                    (aver nil))))
1460            ((register-p src)
1461             (maybe-emit-rex-for-ea segment dst src)
1462             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
1463             (emit-ea segment dst (reg-tn-encoding src)))
1464            ((fixup-p src)
1465             ;; Generally we can't MOV a fixupped value into an EA, since
1466             ;; MOV on non-registers can only take a 32-bit immediate arg.
1467             ;; Make an exception for :FOREIGN fixups (pretty much just
1468             ;; the runtime asm, since other foreign calls go through the
1469             ;; the linkage table) and for linkage table references, since
1470             ;; these should always end up in low memory.
1471             (aver (or (eq (fixup-flavor src) :foreign)
1472                       (eq (fixup-flavor src) :foreign-dataref)
1473                       (eq (ea-size dst) :dword)))
1474             (maybe-emit-rex-for-ea segment dst nil)
1475             (emit-byte segment #b11000111)
1476             (emit-ea segment dst #b000)
1477             (emit-absolute-fixup segment src))
1478            (t
1479             (error "bogus arguments to MOV: ~S ~S" dst src))))))
1480
1481 (defun emit-move-with-extension (segment dst src signed-p)
1482   (aver (register-p dst))
1483   (let ((dst-size (operand-size dst))
1484         (src-size (operand-size src))
1485         (opcode (if signed-p  #b10111110 #b10110110)))
1486     (ecase dst-size
1487       (:word
1488        (aver (eq src-size :byte))
1489        (maybe-emit-operand-size-prefix segment :word)
1490        ;; REX prefix is needed if SRC is SIL, DIL, SPL or BPL.
1491        (maybe-emit-rex-for-ea segment src dst :operand-size :word)
1492        (emit-byte segment #b00001111)
1493        (emit-byte segment opcode)
1494        (emit-ea segment src (reg-tn-encoding dst)))
1495       ((:dword :qword)
1496        (ecase src-size
1497          (:byte
1498           (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
1499           (emit-byte segment #b00001111)
1500           (emit-byte segment opcode)
1501           (emit-ea segment src (reg-tn-encoding dst)))
1502          (:word
1503           (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
1504           (emit-byte segment #b00001111)
1505           (emit-byte segment (logior opcode 1))
1506           (emit-ea segment src (reg-tn-encoding dst)))
1507          (:dword
1508           (aver (eq dst-size :qword))
1509           ;; dst is in reg, src is in modrm
1510           (let ((ea-p (ea-p src)))
1511             (maybe-emit-rex-prefix segment (if signed-p :qword :dword) dst
1512                                    (and ea-p (ea-index src))
1513                                    (cond (ea-p (ea-base src))
1514                                          ((tn-p src) src)
1515                                          (t nil)))
1516             (emit-byte segment #x63)    ;movsxd
1517             ;;(emit-byte segment opcode)
1518             (emit-ea segment src (reg-tn-encoding dst)))))))))
1519
1520 (define-instruction movsx (segment dst src)
1521   (:printer ext-reg-reg/mem-no-width
1522             ((op #b10111110) (reg/mem nil :type 'sized-byte-reg/mem)))
1523   (:printer rex-ext-reg-reg/mem-no-width
1524             ((op #b10111110) (reg/mem nil :type 'sized-byte-reg/mem)))
1525   (:printer ext-reg-reg/mem-no-width
1526             ((op #b10111111) (reg/mem nil :type 'sized-word-reg/mem)))
1527   (:printer rex-ext-reg-reg/mem-no-width
1528             ((op #b10111111) (reg/mem nil :type 'sized-word-reg/mem)))
1529   (:emitter (emit-move-with-extension segment dst src :signed)))
1530
1531 (define-instruction movzx (segment dst src)
1532   (:printer ext-reg-reg/mem-no-width
1533             ((op #b10110110) (reg/mem nil :type 'sized-byte-reg/mem)))
1534   (:printer rex-ext-reg-reg/mem-no-width
1535             ((op #b10110110) (reg/mem nil :type 'sized-byte-reg/mem)))
1536   (:printer ext-reg-reg/mem-no-width
1537             ((op #b10110111) (reg/mem nil :type 'sized-word-reg/mem)))
1538   (:printer rex-ext-reg-reg/mem-no-width
1539             ((op #b10110111) (reg/mem nil :type 'sized-word-reg/mem)))
1540   (:emitter (emit-move-with-extension segment dst src nil)))
1541
1542 ;;; The regular use of MOVSXD is with an operand size of :qword. This
1543 ;;; sign-extends the dword source into the qword destination register.
1544 ;;; If the operand size is :dword the instruction zero-extends the dword
1545 ;;; source into the qword destination register, i.e. it does the same as
1546 ;;; a dword MOV into a register.
1547 (define-instruction movsxd (segment dst src)
1548   (:printer reg-reg/mem ((op #b0110001) (width 1)
1549                          (reg/mem nil :type 'sized-dword-reg/mem)))
1550   (:printer rex-reg-reg/mem ((op #b0110001) (width 1)
1551                              (reg/mem nil :type 'sized-dword-reg/mem)))
1552   (:emitter (emit-move-with-extension segment dst src :signed)))
1553
1554 ;;; this is not a real amd64 instruction, of course
1555 (define-instruction movzxd (segment dst src)
1556   ; (:printer reg-reg/mem ((op #x63) (reg nil :type 'reg)))
1557   (:emitter (emit-move-with-extension segment dst src nil)))
1558
1559 (define-instruction push (segment src)
1560   ;; register
1561   (:printer reg-no-width-default-qword ((op #b01010)))
1562   (:printer rex-reg-no-width-default-qword ((op #b01010)))
1563   ;; register/memory
1564   (:printer reg/mem-default-qword ((op '(#b11111111 #b110))))
1565   (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b110))))
1566   ;; immediate
1567   (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1568             '(:name :tab imm))
1569   (:printer byte ((op #b01101000)
1570                   (imm nil :type 'signed-imm-data-default-qword))
1571             '(:name :tab imm))
1572   ;; ### segment registers?
1573
1574   (:emitter
1575    (cond ((integerp src)
1576           (cond ((<= -128 src 127)
1577                  (emit-byte segment #b01101010)
1578                  (emit-byte segment src))
1579                 (t
1580                  ;; A REX-prefix is not needed because the operand size
1581                  ;; defaults to 64 bits. The size of the immediate is 32
1582                  ;; bits and it is sign-extended.
1583                  (emit-byte segment #b01101000)
1584                  (emit-dword segment src))))
1585          (t
1586           (let ((size (operand-size src)))
1587             (aver (not (eq size :byte)))
1588             (maybe-emit-operand-size-prefix segment size)
1589             (maybe-emit-rex-for-ea segment src nil :operand-size :do-not-set)
1590             (cond ((register-p src)
1591                    (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1592                   (t
1593                    (emit-byte segment #b11111111)
1594                    (emit-ea segment src #b110 t))))))))
1595
1596 (define-instruction pop (segment dst)
1597   (:printer reg-no-width-default-qword ((op #b01011)))
1598   (:printer rex-reg-no-width-default-qword ((op #b01011)))
1599   (:printer reg/mem-default-qword ((op '(#b10001111 #b000))))
1600   (:printer rex-reg/mem-default-qword ((op '(#b10001111 #b000))))
1601   (:emitter
1602    (let ((size (operand-size dst)))
1603      (aver (not (eq size :byte)))
1604      (maybe-emit-operand-size-prefix segment size)
1605      (maybe-emit-rex-for-ea segment dst nil :operand-size :do-not-set)
1606      (cond ((register-p dst)
1607             (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1608            (t
1609             (emit-byte segment #b10001111)
1610             (emit-ea segment dst #b000))))))
1611
1612 (define-instruction xchg (segment operand1 operand2)
1613   ;; Register with accumulator.
1614   (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1615   ;; Register/Memory with Register.
1616   (:printer reg-reg/mem ((op #b1000011)))
1617   (:printer rex-reg-reg/mem ((op #b1000011)))
1618   (:emitter
1619    (let ((size (matching-operand-size operand1 operand2)))
1620      (maybe-emit-operand-size-prefix segment size)
1621      (labels ((xchg-acc-with-something (acc something)
1622                 (if (and (not (eq size :byte)) (register-p something))
1623                     (progn
1624                       (maybe-emit-rex-for-ea segment acc something)
1625                       (emit-byte-with-reg segment
1626                                           #b10010
1627                                           (reg-tn-encoding something)))
1628                     (xchg-reg-with-something acc something)))
1629               (xchg-reg-with-something (reg something)
1630                 (maybe-emit-rex-for-ea segment something reg)
1631                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1632                 (emit-ea segment something (reg-tn-encoding reg))))
1633        (cond ((accumulator-p operand1)
1634               (xchg-acc-with-something operand1 operand2))
1635              ((accumulator-p operand2)
1636               (xchg-acc-with-something operand2 operand1))
1637              ((register-p operand1)
1638               (xchg-reg-with-something operand1 operand2))
1639              ((register-p operand2)
1640               (xchg-reg-with-something operand2 operand1))
1641              (t
1642               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1643
1644 (define-instruction lea (segment dst src)
1645   (:printer rex-reg-reg/mem ((op #b1000110)))
1646   (:printer reg-reg/mem ((op #b1000110) (width 1)))
1647   (:emitter
1648    (aver (or (dword-reg-p dst) (qword-reg-p dst)))
1649    (maybe-emit-rex-for-ea segment src dst
1650                           :operand-size :qword)
1651    (emit-byte segment #b10001101)
1652    (emit-ea segment src (reg-tn-encoding dst))))
1653
1654 (define-instruction cmpxchg (segment dst src)
1655   ;; Register/Memory with Register.
1656   (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1657   (:emitter
1658    (aver (register-p src))
1659    (let ((size (matching-operand-size src dst)))
1660      (maybe-emit-operand-size-prefix segment size)
1661      (maybe-emit-rex-for-ea segment dst src)
1662      (emit-byte segment #b00001111)
1663      (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1664      (emit-ea segment dst (reg-tn-encoding src)))))
1665
1666 \f
1667
1668 (define-instruction fs-segment-prefix (segment)
1669   (:emitter
1670    (emit-byte segment #x64)))
1671
1672 ;;;; flag control instructions
1673
1674 ;;; CLC -- Clear Carry Flag.
1675 (define-instruction clc (segment)
1676   (:printer byte ((op #b11111000)))
1677   (:emitter
1678    (emit-byte segment #b11111000)))
1679
1680 ;;; CLD -- Clear Direction Flag.
1681 (define-instruction cld (segment)
1682   (:printer byte ((op #b11111100)))
1683   (:emitter
1684    (emit-byte segment #b11111100)))
1685
1686 ;;; CLI -- Clear Iterrupt Enable Flag.
1687 (define-instruction cli (segment)
1688   (:printer byte ((op #b11111010)))
1689   (:emitter
1690    (emit-byte segment #b11111010)))
1691
1692 ;;; CMC -- Complement Carry Flag.
1693 (define-instruction cmc (segment)
1694   (:printer byte ((op #b11110101)))
1695   (:emitter
1696    (emit-byte segment #b11110101)))
1697
1698 ;;; LAHF -- Load AH into flags.
1699 (define-instruction lahf (segment)
1700   (:printer byte ((op #b10011111)))
1701   (:emitter
1702    (emit-byte segment #b10011111)))
1703
1704 ;;; POPF -- Pop flags.
1705 (define-instruction popf (segment)
1706   (:printer byte ((op #b10011101)))
1707   (:emitter
1708    (emit-byte segment #b10011101)))
1709
1710 ;;; PUSHF -- push flags.
1711 (define-instruction pushf (segment)
1712   (:printer byte ((op #b10011100)))
1713   (:emitter
1714    (emit-byte segment #b10011100)))
1715
1716 ;;; SAHF -- Store AH into flags.
1717 (define-instruction sahf (segment)
1718   (:printer byte ((op #b10011110)))
1719   (:emitter
1720    (emit-byte segment #b10011110)))
1721
1722 ;;; STC -- Set Carry Flag.
1723 (define-instruction stc (segment)
1724   (:printer byte ((op #b11111001)))
1725   (:emitter
1726    (emit-byte segment #b11111001)))
1727
1728 ;;; STD -- Set Direction Flag.
1729 (define-instruction std (segment)
1730   (:printer byte ((op #b11111101)))
1731   (:emitter
1732    (emit-byte segment #b11111101)))
1733
1734 ;;; STI -- Set Interrupt Enable Flag.
1735 (define-instruction sti (segment)
1736   (:printer byte ((op #b11111011)))
1737   (:emitter
1738    (emit-byte segment #b11111011)))
1739 \f
1740 ;;;; arithmetic
1741
1742 (defun emit-random-arith-inst (name segment dst src opcode
1743                                     &optional allow-constants)
1744   (let ((size (matching-operand-size dst src)))
1745     (maybe-emit-operand-size-prefix segment size)
1746     (cond
1747      ((integerp src)
1748       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1749              (maybe-emit-rex-for-ea segment dst nil)
1750              (emit-byte segment #b10000011)
1751              (emit-ea segment dst opcode allow-constants)
1752              (emit-byte segment src))
1753             ((accumulator-p dst)
1754              (maybe-emit-rex-for-ea segment dst nil)
1755              (emit-byte segment
1756                         (dpb opcode
1757                              (byte 3 3)
1758                              (if (eq size :byte)
1759                                  #b00000100
1760                                  #b00000101)))
1761              (emit-sized-immediate segment size src))
1762             (t
1763              (maybe-emit-rex-for-ea segment dst nil)
1764              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1765              (emit-ea segment dst opcode allow-constants)
1766              (emit-sized-immediate segment size src))))
1767      ((register-p src)
1768       (maybe-emit-rex-for-ea segment dst src)
1769       (emit-byte segment
1770                  (dpb opcode
1771                       (byte 3 3)
1772                       (if (eq size :byte) #b00000000 #b00000001)))
1773       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1774      ((register-p dst)
1775       (maybe-emit-rex-for-ea segment src dst)
1776       (emit-byte segment
1777                  (dpb opcode
1778                       (byte 3 3)
1779                       (if (eq size :byte) #b00000010 #b00000011)))
1780       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1781      (t
1782       (error "bogus operands to ~A" name)))))
1783
1784 (eval-when (:compile-toplevel :execute)
1785   (defun arith-inst-printer-list (subop)
1786     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1787       (rex-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1788       (reg/mem-imm ((op (#b1000000 ,subop))))
1789       (rex-reg/mem-imm ((op (#b1000000 ,subop))))
1790       ;; The redundant encoding #x82 is invalid in 64-bit mode,
1791       ;; therefore we force WIDTH to 1.
1792       (reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
1793                     (imm nil :type signed-imm-byte)))
1794       (rex-reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
1795                         (imm nil :type signed-imm-byte)))
1796       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
1797       (rex-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1798   )
1799
1800 (define-instruction add (segment dst src)
1801   (:printer-list (arith-inst-printer-list #b000))
1802   (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1803
1804 (define-instruction adc (segment dst src)
1805   (:printer-list (arith-inst-printer-list #b010))
1806   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1807
1808 (define-instruction sub (segment dst src)
1809   (:printer-list (arith-inst-printer-list #b101))
1810   (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1811
1812 (define-instruction sbb (segment dst src)
1813   (:printer-list (arith-inst-printer-list #b011))
1814   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1815
1816 (define-instruction cmp (segment dst src)
1817   (:printer-list (arith-inst-printer-list #b111))
1818   (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1819
1820 (define-instruction inc (segment dst)
1821   ;; Register
1822   (:printer modrm-reg-no-width ((modrm-reg #b000)))
1823   ;; Register/Memory
1824   ;; (:printer rex-reg/mem ((op '(#b11111111 #b001))))
1825   (:printer reg/mem ((op '(#b1111111 #b000))))
1826   (:emitter
1827    (let ((size (operand-size dst)))
1828      (maybe-emit-operand-size-prefix segment size)
1829      (cond #+nil ; these opcodes become REX prefixes in x86-64
1830            ((and (not (eq size :byte)) (register-p dst))
1831             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1832            (t
1833             (maybe-emit-rex-for-ea segment dst nil)
1834             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1835             (emit-ea segment dst #b000))))))
1836
1837 (define-instruction dec (segment dst)
1838   ;; Register.
1839   (:printer modrm-reg-no-width ((modrm-reg #b001)))
1840   ;; Register/Memory
1841   (:printer reg/mem ((op '(#b1111111 #b001))))
1842   (:emitter
1843    (let ((size (operand-size dst)))
1844      (maybe-emit-operand-size-prefix segment size)
1845      (cond #+nil
1846            ((and (not (eq size :byte)) (register-p dst))
1847             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1848            (t
1849             (maybe-emit-rex-for-ea segment dst nil)
1850             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1851             (emit-ea segment dst #b001))))))
1852
1853 (define-instruction neg (segment dst)
1854   (:printer reg/mem ((op '(#b1111011 #b011))))
1855   (:printer rex-reg/mem ((op '(#b1111011 #b011))))
1856   (:emitter
1857    (let ((size (operand-size dst)))
1858      (maybe-emit-operand-size-prefix segment size)
1859      (maybe-emit-rex-for-ea segment dst nil)
1860      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1861      (emit-ea segment dst #b011))))
1862
1863 (define-instruction mul (segment dst src)
1864   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1865   (:printer rex-accum-reg/mem ((op '(#b1111011 #b100))))
1866   (:emitter
1867    (let ((size (matching-operand-size dst src)))
1868      (aver (accumulator-p dst))
1869      (maybe-emit-operand-size-prefix segment size)
1870      (maybe-emit-rex-for-ea segment src nil)
1871      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1872      (emit-ea segment src #b100))))
1873
1874 (define-instruction imul (segment dst &optional src1 src2)
1875   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1876   (:printer rex-accum-reg/mem ((op '(#b1111011 #b101))))
1877   (:printer ext-reg-reg/mem-no-width ((op #b10101111)))
1878   (:printer rex-ext-reg-reg/mem-no-width ((op #b10101111)))
1879   (:printer reg-reg/mem ((op #b0110100) (width 1)
1880                          (imm nil :type 'signed-imm-data))
1881             '(:name :tab reg ", " reg/mem ", " imm))
1882   (:printer rex-reg-reg/mem ((op #b0110100) (width 1)
1883                              (imm nil :type 'signed-imm-data))
1884             '(:name :tab reg ", " reg/mem ", " imm))
1885   (:printer reg-reg/mem ((op #b0110101) (width 1)
1886                          (imm nil :type 'signed-imm-byte))
1887             '(:name :tab reg ", " reg/mem ", " imm))
1888   (:printer rex-reg-reg/mem ((op #b0110101) (width 1)
1889                              (imm nil :type 'signed-imm-byte))
1890             '(:name :tab reg ", " reg/mem ", " imm))
1891   (:emitter
1892    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1893             (let* ((size (matching-operand-size reg r/m))
1894                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1895               (maybe-emit-operand-size-prefix segment size)
1896               (maybe-emit-rex-for-ea segment r/m reg)
1897               (emit-byte segment (if sx #b01101011 #b01101001))
1898               (emit-ea segment r/m (reg-tn-encoding reg))
1899               (if sx
1900                   (emit-byte segment immed)
1901                   (emit-sized-immediate segment size immed)))))
1902      (cond (src2
1903             (r/m-with-immed-to-reg dst src1 src2))
1904            (src1
1905             (if (integerp src1)
1906                 (r/m-with-immed-to-reg dst dst src1)
1907                 (let ((size (matching-operand-size dst src1)))
1908                   (maybe-emit-operand-size-prefix segment size)
1909                   (maybe-emit-rex-for-ea segment src1 dst)
1910                   (emit-byte segment #b00001111)
1911                   (emit-byte segment #b10101111)
1912                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1913            (t
1914             (let ((size (operand-size dst)))
1915               (maybe-emit-operand-size-prefix segment size)
1916               (maybe-emit-rex-for-ea segment dst nil)
1917               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1918               (emit-ea segment dst #b101)))))))
1919
1920 (define-instruction div (segment dst src)
1921   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1922   (:printer rex-accum-reg/mem ((op '(#b1111011 #b110))))
1923   (:emitter
1924    (let ((size (matching-operand-size dst src)))
1925      (aver (accumulator-p dst))
1926      (maybe-emit-operand-size-prefix segment size)
1927      (maybe-emit-rex-for-ea segment src nil)
1928      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1929      (emit-ea segment src #b110))))
1930
1931 (define-instruction idiv (segment dst src)
1932   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1933   (:printer rex-accum-reg/mem ((op '(#b1111011 #b111))))
1934   (:emitter
1935    (let ((size (matching-operand-size dst src)))
1936      (aver (accumulator-p dst))
1937      (maybe-emit-operand-size-prefix segment size)
1938      (maybe-emit-rex-for-ea segment src nil)
1939      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1940      (emit-ea segment src #b111))))
1941
1942 (define-instruction bswap (segment dst)
1943   (:printer ext-reg-no-width ((op #b11001)))
1944   (:emitter
1945    (let ((size (operand-size dst)))
1946      (maybe-emit-rex-prefix segment size nil nil dst)
1947      (emit-byte segment #x0f)
1948      (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst)))))
1949
1950 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1951 (define-instruction cbw (segment)
1952   (:printer x66-byte ((op #b10011000)))
1953   (:emitter
1954    (maybe-emit-operand-size-prefix segment :word)
1955    (emit-byte segment #b10011000)))
1956
1957 ;;; CWDE -- Convert Word To Double Word Extended. EAX <- sign_xtnd(AX)
1958 (define-instruction cwde (segment)
1959   (:printer byte ((op #b10011000)))
1960   (:emitter
1961    (maybe-emit-operand-size-prefix segment :dword)
1962    (emit-byte segment #b10011000)))
1963
1964 ;;; CDQE -- Convert Word To Double Word Extended. RAX <- sign_xtnd(EAX)
1965 (define-instruction cdqe (segment)
1966   (:printer rex-byte ((op #b10011000)))
1967   (:emitter
1968    (maybe-emit-rex-prefix segment :qword nil nil nil)
1969    (emit-byte segment #b10011000)))
1970
1971 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1972 (define-instruction cwd (segment)
1973   (:printer x66-byte ((op #b10011001)))
1974   (:emitter
1975    (maybe-emit-operand-size-prefix segment :word)
1976    (emit-byte segment #b10011001)))
1977
1978 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1979 (define-instruction cdq (segment)
1980   (:printer byte ((op #b10011001)))
1981   (:emitter
1982    (maybe-emit-operand-size-prefix segment :dword)
1983    (emit-byte segment #b10011001)))
1984
1985 ;;; CQO -- Convert Quad Word to Octaword. RDX:RAX <- sign_xtnd(RAX)
1986 (define-instruction cqo (segment)
1987   (:printer rex-byte ((op #b10011001)))
1988   (:emitter
1989    (maybe-emit-rex-prefix segment :qword nil nil nil)
1990    (emit-byte segment #b10011001)))
1991
1992 (define-instruction xadd (segment dst src)
1993   ;; Register/Memory with Register.
1994   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1995   (:emitter
1996    (aver (register-p src))
1997    (let ((size (matching-operand-size src dst)))
1998      (maybe-emit-operand-size-prefix segment size)
1999      (maybe-emit-rex-for-ea segment dst src)
2000      (emit-byte segment #b00001111)
2001      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
2002      (emit-ea segment dst (reg-tn-encoding src)))))
2003
2004 \f
2005 ;;;; logic
2006
2007 (defun emit-shift-inst (segment dst amount opcode)
2008   (let ((size (operand-size dst)))
2009     (maybe-emit-operand-size-prefix segment size)
2010     (multiple-value-bind (major-opcode immed)
2011         (case amount
2012           (:cl (values #b11010010 nil))
2013           (1 (values #b11010000 nil))
2014           (t (values #b11000000 t)))
2015       (maybe-emit-rex-for-ea segment dst nil)
2016       (emit-byte segment
2017                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
2018       (emit-ea segment dst opcode)
2019       (when immed
2020         (emit-byte segment amount)))))
2021
2022 (eval-when (:compile-toplevel :execute)
2023   (defun shift-inst-printer-list (subop)
2024     `((reg/mem ((op (#b1101000 ,subop)))
2025                (:name :tab reg/mem ", 1"))
2026       (rex-reg/mem ((op (#b1101000 ,subop)))
2027                    (:name :tab reg/mem ", 1"))
2028       (reg/mem ((op (#b1101001 ,subop)))
2029                (:name :tab reg/mem ", " 'cl))
2030       (rex-reg/mem ((op (#b1101001 ,subop)))
2031                (:name :tab reg/mem ", " 'cl))
2032       (reg/mem-imm ((op (#b1100000 ,subop))
2033                     (imm nil :type imm-byte)))
2034       (rex-reg/mem-imm ((op (#b1100000 ,subop))
2035                     (imm nil :type imm-byte))))))
2036
2037 (define-instruction rol (segment dst amount)
2038   (:printer-list
2039    (shift-inst-printer-list #b000))
2040   (:emitter
2041    (emit-shift-inst segment dst amount #b000)))
2042
2043 (define-instruction ror (segment dst amount)
2044   (:printer-list
2045    (shift-inst-printer-list #b001))
2046   (:emitter
2047    (emit-shift-inst segment dst amount #b001)))
2048
2049 (define-instruction rcl (segment dst amount)
2050   (:printer-list
2051    (shift-inst-printer-list #b010))
2052   (:emitter
2053    (emit-shift-inst segment dst amount #b010)))
2054
2055 (define-instruction rcr (segment dst amount)
2056   (:printer-list
2057    (shift-inst-printer-list #b011))
2058   (:emitter
2059    (emit-shift-inst segment dst amount #b011)))
2060
2061 (define-instruction shl (segment dst amount)
2062   (:printer-list
2063    (shift-inst-printer-list #b100))
2064   (:emitter
2065    (emit-shift-inst segment dst amount #b100)))
2066
2067 (define-instruction shr (segment dst amount)
2068   (:printer-list
2069    (shift-inst-printer-list #b101))
2070   (:emitter
2071    (emit-shift-inst segment dst amount #b101)))
2072
2073 (define-instruction sar (segment dst amount)
2074   (:printer-list
2075    (shift-inst-printer-list #b111))
2076   (:emitter
2077    (emit-shift-inst segment dst amount #b111)))
2078
2079 (defun emit-double-shift (segment opcode dst src amt)
2080   (let ((size (matching-operand-size dst src)))
2081     (when (eq size :byte)
2082       (error "Double shifts can only be used with words."))
2083     (maybe-emit-operand-size-prefix segment size)
2084     (maybe-emit-rex-for-ea segment dst src)
2085     (emit-byte segment #b00001111)
2086     (emit-byte segment (dpb opcode (byte 1 3)
2087                             (if (eq amt :cl) #b10100101 #b10100100)))
2088     (emit-ea segment dst (reg-tn-encoding src))
2089     (unless (eq amt :cl)
2090       (emit-byte segment amt))))
2091
2092 (eval-when (:compile-toplevel :execute)
2093   (defun double-shift-inst-printer-list (op)
2094     `(#+nil
2095       (ext-reg-reg/mem-imm ((op ,(logior op #b100))
2096                             (imm nil :type signed-imm-byte)))
2097       (ext-reg-reg/mem ((op ,(logior op #b101)))
2098          (:name :tab reg/mem ", " 'cl)))))
2099
2100 (define-instruction shld (segment dst src amt)
2101   (:declare (type (or (member :cl) (mod 32)) amt))
2102   (:printer-list (double-shift-inst-printer-list #b10100000))
2103   (:emitter
2104    (emit-double-shift segment #b0 dst src amt)))
2105
2106 (define-instruction shrd (segment dst src amt)
2107   (:declare (type (or (member :cl) (mod 32)) amt))
2108   (:printer-list (double-shift-inst-printer-list #b10101000))
2109   (:emitter
2110    (emit-double-shift segment #b1 dst src amt)))
2111
2112 (define-instruction and (segment dst src)
2113   (:printer-list
2114    (arith-inst-printer-list #b100))
2115   (:emitter
2116    (emit-random-arith-inst "AND" segment dst src #b100)))
2117
2118 (define-instruction test (segment this that)
2119   (:printer accum-imm ((op #b1010100)))
2120   (:printer rex-accum-imm ((op #b1010100)))
2121   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
2122   (:printer rex-reg/mem-imm ((op '(#b1111011 #b000))))
2123   (:printer reg-reg/mem ((op #b1000010)))
2124   (:printer rex-reg-reg/mem ((op #b1000010)))
2125   (:emitter
2126    (let ((size (matching-operand-size this that)))
2127      (maybe-emit-operand-size-prefix segment size)
2128      (flet ((test-immed-and-something (immed something)
2129               (cond ((accumulator-p something)
2130                      (maybe-emit-rex-for-ea segment something nil)
2131                      (emit-byte segment
2132                                 (if (eq size :byte) #b10101000 #b10101001))
2133                      (emit-sized-immediate segment size immed))
2134                     (t
2135                      (maybe-emit-rex-for-ea segment something nil)
2136                      (emit-byte segment
2137                                 (if (eq size :byte) #b11110110 #b11110111))
2138                      (emit-ea segment something #b000)
2139                      (emit-sized-immediate segment size immed))))
2140             (test-reg-and-something (reg something)
2141               (maybe-emit-rex-for-ea segment something reg)
2142               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
2143               (emit-ea segment something (reg-tn-encoding reg))))
2144        (cond ((integerp that)
2145               (test-immed-and-something that this))
2146              ((integerp this)
2147               (test-immed-and-something this that))
2148              ((register-p this)
2149               (test-reg-and-something this that))
2150              ((register-p that)
2151               (test-reg-and-something that this))
2152              (t
2153               (error "bogus operands for TEST: ~S and ~S" this that)))))))
2154
2155 (define-instruction or (segment dst src)
2156   (:printer-list
2157    (arith-inst-printer-list #b001))
2158   (:emitter
2159    (emit-random-arith-inst "OR" segment dst src #b001)))
2160
2161 (define-instruction xor (segment dst src)
2162   (:printer-list
2163    (arith-inst-printer-list #b110))
2164   (:emitter
2165    (emit-random-arith-inst "XOR" segment dst src #b110)))
2166
2167 (define-instruction not (segment dst)
2168   (:printer reg/mem ((op '(#b1111011 #b010))))
2169   (:printer rex-reg/mem ((op '(#b1111011 #b010))))
2170   (:emitter
2171    (let ((size (operand-size dst)))
2172      (maybe-emit-operand-size-prefix segment size)
2173      (maybe-emit-rex-for-ea segment dst nil)
2174      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
2175      (emit-ea segment dst #b010))))
2176 \f
2177 ;;;; string manipulation
2178
2179 (define-instruction cmps (segment size)
2180   (:printer string-op ((op #b1010011)))
2181   (:printer rex-string-op ((op #b1010011)))
2182   (:emitter
2183    (maybe-emit-operand-size-prefix segment size)
2184    (maybe-emit-rex-prefix segment size nil nil nil)
2185    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
2186
2187 (define-instruction ins (segment acc)
2188   (:printer string-op ((op #b0110110)))
2189   (:printer rex-string-op ((op #b0110110)))
2190   (:emitter
2191    (let ((size (operand-size acc)))
2192      (aver (accumulator-p acc))
2193      (maybe-emit-operand-size-prefix segment size)
2194      (maybe-emit-rex-prefix segment size nil nil nil)
2195      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
2196
2197 (define-instruction lods (segment acc)
2198   (:printer string-op ((op #b1010110)))
2199   (:printer rex-string-op ((op #b1010110)))
2200   (:emitter
2201    (let ((size (operand-size acc)))
2202      (aver (accumulator-p acc))
2203      (maybe-emit-operand-size-prefix segment size)
2204      (maybe-emit-rex-prefix segment size nil nil nil)
2205      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
2206
2207 (define-instruction movs (segment size)
2208   (:printer string-op ((op #b1010010)))
2209   (:printer rex-string-op ((op #b1010010)))
2210   (:emitter
2211    (maybe-emit-operand-size-prefix segment size)
2212    (maybe-emit-rex-prefix segment size nil nil nil)
2213    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
2214
2215 (define-instruction outs (segment acc)
2216   (:printer string-op ((op #b0110111)))
2217   (:printer rex-string-op ((op #b0110111)))
2218   (:emitter
2219    (let ((size (operand-size acc)))
2220      (aver (accumulator-p acc))
2221      (maybe-emit-operand-size-prefix segment size)
2222      (maybe-emit-rex-prefix segment size nil nil nil)
2223      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
2224
2225 (define-instruction scas (segment acc)
2226   (:printer string-op ((op #b1010111)))
2227   (:printer rex-string-op ((op #b1010111)))
2228   (:emitter
2229    (let ((size (operand-size acc)))
2230      (aver (accumulator-p acc))
2231      (maybe-emit-operand-size-prefix segment size)
2232      (maybe-emit-rex-prefix segment size nil nil nil)
2233      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
2234
2235 (define-instruction stos (segment acc)
2236   (:printer string-op ((op #b1010101)))
2237   (:printer rex-string-op ((op #b1010101)))
2238   (:emitter
2239    (let ((size (operand-size acc)))
2240      (aver (accumulator-p acc))
2241      (maybe-emit-operand-size-prefix segment size)
2242      (maybe-emit-rex-prefix segment size nil nil nil)
2243      (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
2244
2245 (define-instruction xlat (segment)
2246   (:printer byte ((op #b11010111)))
2247   (:emitter
2248    (emit-byte segment #b11010111)))
2249
2250 (define-instruction rep (segment)
2251   (:emitter
2252    (emit-byte segment #b11110010)))
2253
2254 (define-instruction repe (segment)
2255   (:printer byte ((op #b11110011)))
2256   (:emitter
2257    (emit-byte segment #b11110011)))
2258
2259 (define-instruction repne (segment)
2260   (:printer byte ((op #b11110010)))
2261   (:emitter
2262    (emit-byte segment #b11110010)))
2263
2264 \f
2265 ;;;; bit manipulation
2266
2267 (define-instruction bsf (segment dst src)
2268   (:printer ext-reg-reg/mem-no-width ((op #b10111100)))
2269   (:printer rex-ext-reg-reg/mem-no-width ((op #b10111100)))
2270   (:emitter
2271    (let ((size (matching-operand-size dst src)))
2272      (when (eq size :byte)
2273        (error "can't scan bytes: ~S" src))
2274      (maybe-emit-operand-size-prefix segment size)
2275      (maybe-emit-rex-for-ea segment src dst)
2276      (emit-byte segment #b00001111)
2277      (emit-byte segment #b10111100)
2278      (emit-ea segment src (reg-tn-encoding dst)))))
2279
2280 (define-instruction bsr (segment dst src)
2281   (:printer ext-reg-reg/mem-no-width ((op #b10111101)))
2282   (:printer rex-ext-reg-reg/mem-no-width ((op #b10111101)))
2283   (:emitter
2284    (let ((size (matching-operand-size dst src)))
2285      (when (eq size :byte)
2286        (error "can't scan bytes: ~S" src))
2287      (maybe-emit-operand-size-prefix segment size)
2288      (maybe-emit-rex-for-ea segment src dst)
2289      (emit-byte segment #b00001111)
2290      (emit-byte segment #b10111101)
2291      (emit-ea segment src (reg-tn-encoding dst)))))
2292
2293 (defun emit-bit-test-and-mumble (segment src index opcode)
2294   (let ((size (operand-size src)))
2295     (when (eq size :byte)
2296       (error "can't scan bytes: ~S" src))
2297     (maybe-emit-operand-size-prefix segment size)
2298     (cond ((integerp index)
2299            (maybe-emit-rex-for-ea segment src nil)
2300            (emit-byte segment #b00001111)
2301            (emit-byte segment #b10111010)
2302            (emit-ea segment src opcode)
2303            (emit-byte segment index))
2304           (t
2305            (maybe-emit-rex-for-ea segment src index)
2306            (emit-byte segment #b00001111)
2307            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
2308            (emit-ea segment src (reg-tn-encoding index))))))
2309
2310 (eval-when (:compile-toplevel :execute)
2311   (defun bit-test-inst-printer-list (subop)
2312     `((ext-reg/mem-imm ((op (#b1011101 ,subop))
2313                         (reg/mem nil :type reg/mem)
2314                         (imm nil :type imm-byte)
2315                         (width 0)))
2316       (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
2317                         (width 1))
2318                        (:name :tab reg/mem ", " reg)))))
2319
2320 (define-instruction bt (segment src index)
2321   (:printer-list (bit-test-inst-printer-list #b100))
2322   (:emitter
2323    (emit-bit-test-and-mumble segment src index #b100)))
2324
2325 (define-instruction btc (segment src index)
2326   (:printer-list (bit-test-inst-printer-list #b111))
2327   (:emitter
2328    (emit-bit-test-and-mumble segment src index #b111)))
2329
2330 (define-instruction btr (segment src index)
2331   (:printer-list (bit-test-inst-printer-list #b110))
2332   (:emitter
2333    (emit-bit-test-and-mumble segment src index #b110)))
2334
2335 (define-instruction bts (segment src index)
2336   (:printer-list (bit-test-inst-printer-list #b101))
2337   (:emitter
2338    (emit-bit-test-and-mumble segment src index #b101)))
2339
2340 \f
2341 ;;;; control transfer
2342
2343 (define-instruction call (segment where)
2344   (:printer near-jump ((op #b11101000)))
2345   (:printer reg/mem-default-qword ((op '(#b11111111 #b010))))
2346   (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b010))))
2347   (:emitter
2348    (typecase where
2349      (label
2350       (emit-byte segment #b11101000) ; 32 bit relative
2351       (emit-back-patch segment
2352                        4
2353                        (lambda (segment posn)
2354                          (emit-dword segment
2355                                      (- (label-position where)
2356                                         (+ posn 4))))))
2357      (fixup
2358       (emit-byte segment #b11101000)
2359       (emit-relative-fixup segment where))
2360      (t
2361       (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
2362       (emit-byte segment #b11111111)
2363       (emit-ea segment where #b010)))))
2364
2365 (defun emit-byte-displacement-backpatch (segment target)
2366   (emit-back-patch segment
2367                    1
2368                    (lambda (segment posn)
2369                      (let ((disp (- (label-position target) (1+ posn))))
2370                        (aver (<= -128 disp 127))
2371                        (emit-byte segment disp)))))
2372
2373 (define-instruction jmp (segment cond &optional where)
2374   ;; conditional jumps
2375   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
2376   (:printer near-cond-jump () '('j cc :tab label))
2377   ;; unconditional jumps
2378   (:printer short-jump ((op #b1011)))
2379   (:printer near-jump ((op #b11101001)) )
2380   (:printer reg/mem-default-qword ((op '(#b11111111 #b100))))
2381   (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b100))))
2382   (:emitter
2383    (cond (where
2384           (emit-chooser
2385            segment 6 2
2386            (lambda (segment posn delta-if-after)
2387              (let ((disp (- (label-position where posn delta-if-after)
2388                             (+ posn 2))))
2389                (when (<= -128 disp 127)
2390                  (emit-byte segment
2391                             (dpb (conditional-opcode cond)
2392                                  (byte 4 0)
2393                                  #b01110000))
2394                  (emit-byte-displacement-backpatch segment where)
2395                  t)))
2396            (lambda (segment posn)
2397              (let ((disp (- (label-position where) (+ posn 6))))
2398                (emit-byte segment #b00001111)
2399                (emit-byte segment
2400                           (dpb (conditional-opcode cond)
2401                                (byte 4 0)
2402                                #b10000000))
2403                (emit-dword segment disp)))))
2404          ((label-p (setq where cond))
2405           (emit-chooser
2406            segment 5 0
2407            (lambda (segment posn delta-if-after)
2408              (let ((disp (- (label-position where posn delta-if-after)
2409                             (+ posn 2))))
2410                (when (<= -128 disp 127)
2411                  (emit-byte segment #b11101011)
2412                  (emit-byte-displacement-backpatch segment where)
2413                  t)))
2414            (lambda (segment posn)
2415              (let ((disp (- (label-position where) (+ posn 5))))
2416                (emit-byte segment #b11101001)
2417                (emit-dword segment disp)))))
2418          ((fixup-p where)
2419           (emit-byte segment #b11101001)
2420           (emit-relative-fixup segment where))
2421          (t
2422           (unless (or (ea-p where) (tn-p where))
2423                   (error "don't know what to do with ~A" where))
2424           ;; near jump defaults to 64 bit
2425           ;; w-bit in rex prefix is unnecessary
2426           (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
2427           (emit-byte segment #b11111111)
2428           (emit-ea segment where #b100)))))
2429
2430 (define-instruction jmp-short (segment label)
2431   (:emitter
2432    (emit-byte segment #b11101011)
2433    (emit-byte-displacement-backpatch segment label)))
2434
2435 (define-instruction ret (segment &optional stack-delta)
2436   (:printer byte ((op #b11000011)))
2437   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
2438             '(:name :tab imm))
2439   (:emitter
2440    (cond (stack-delta
2441           (emit-byte segment #b11000010)
2442           (emit-word segment stack-delta))
2443          (t
2444           (emit-byte segment #b11000011)))))
2445
2446 (define-instruction jecxz (segment target)
2447   (:printer short-jump ((op #b0011)))
2448   (:emitter
2449    (emit-byte segment #b11100011)
2450    (emit-byte-displacement-backpatch segment target)))
2451
2452 (define-instruction loop (segment target)
2453   (:printer short-jump ((op #b0010)))
2454   (:emitter
2455    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
2456    (emit-byte-displacement-backpatch segment target)))
2457
2458 (define-instruction loopz (segment target)
2459   (:printer short-jump ((op #b0001)))
2460   (:emitter
2461    (emit-byte segment #b11100001)
2462    (emit-byte-displacement-backpatch segment target)))
2463
2464 (define-instruction loopnz (segment target)
2465   (:printer short-jump ((op #b0000)))
2466   (:emitter
2467    (emit-byte segment #b11100000)
2468    (emit-byte-displacement-backpatch segment target)))
2469 \f
2470 ;;;; conditional move
2471 (define-instruction cmov (segment cond dst src)
2472   (:printer cond-move ())
2473   (:printer rex-cond-move ())
2474   (:emitter
2475    (aver (register-p dst))
2476    (let ((size (matching-operand-size dst src)))
2477      (aver (or (eq size :word) (eq size :dword) (eq size :qword) ))
2478      (maybe-emit-operand-size-prefix segment size))
2479    (maybe-emit-rex-for-ea segment src dst)
2480    (emit-byte segment #b00001111)
2481    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
2482    (emit-ea segment src (reg-tn-encoding dst))))
2483
2484 ;;;; conditional byte set
2485
2486 (define-instruction set (segment dst cond)
2487   (:printer cond-set ())
2488   (:emitter
2489    (maybe-emit-rex-for-ea segment dst nil)
2490    (emit-byte segment #b00001111)
2491    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
2492    (emit-ea segment dst #b000)))
2493 \f
2494 ;;;; enter/leave
2495
2496 (define-instruction enter (segment disp &optional (level 0))
2497   (:declare (type (unsigned-byte 16) disp)
2498             (type (unsigned-byte 8) level))
2499   (:printer enter-format ((op #b11001000)))
2500   (:emitter
2501    (emit-byte segment #b11001000)
2502    (emit-word segment disp)
2503    (emit-byte segment level)))
2504
2505 (define-instruction leave (segment)
2506   (:printer byte ((op #b11001001)))
2507   (:emitter
2508    (emit-byte segment #b11001001)))
2509 \f
2510 ;;;; interrupt instructions
2511
2512 (defun snarf-error-junk (sap offset &optional length-only)
2513   (let* ((length (sb!sys:sap-ref-8 sap offset))
2514          (vector (make-array length :element-type '(unsigned-byte 8))))
2515     (declare (type sb!sys:system-area-pointer sap)
2516              (type (unsigned-byte 8) length)
2517              (type (simple-array (unsigned-byte 8) (*)) vector))
2518     (cond (length-only
2519            (values 0 (1+ length) nil nil))
2520           (t
2521            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
2522                                                 vector 0 length)
2523            (collect ((sc-offsets)
2524                      (lengths))
2525              (lengths 1)                ; the length byte
2526              (let* ((index 0)
2527                     (error-number (sb!c:read-var-integer vector index)))
2528                (lengths index)
2529                (loop
2530                  (when (>= index length)
2531                    (return))
2532                  (let ((old-index index))
2533                    (sc-offsets (sb!c:read-var-integer vector index))
2534                    (lengths (- index old-index))))
2535                (values error-number
2536                        (1+ length)
2537                        (sc-offsets)
2538                        (lengths))))))))
2539
2540 #|
2541 (defmacro break-cases (breaknum &body cases)
2542   (let ((bn-temp (gensym)))
2543     (collect ((clauses))
2544       (dolist (case cases)
2545         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2546       `(let ((,bn-temp ,breaknum))
2547          (cond ,@(clauses))))))
2548 |#
2549
2550 (defun break-control (chunk inst stream dstate)
2551   (declare (ignore inst))
2552   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2553     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2554     ;; map has it undefined; and it should be easier to look in the target
2555     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2556     ;; from first principles whether it's defined in some way that genesis
2557     ;; can't grok.
2558     (case (byte-imm-code chunk dstate)
2559       (#.error-trap
2560        (nt "error trap")
2561        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2562       (#.cerror-trap
2563        (nt "cerror trap")
2564        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2565       (#.breakpoint-trap
2566        (nt "breakpoint trap"))
2567       (#.pending-interrupt-trap
2568        (nt "pending interrupt trap"))
2569       (#.halt-trap
2570        (nt "halt trap"))
2571       (#.fun-end-breakpoint-trap
2572        (nt "function end breakpoint trap")))))
2573
2574 (define-instruction break (segment code)
2575   (:declare (type (unsigned-byte 8) code))
2576   (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2577             :control #'break-control)
2578   (:emitter
2579    (emit-byte segment #b11001100)
2580    (emit-byte segment code)))
2581
2582 (define-instruction int (segment number)
2583   (:declare (type (unsigned-byte 8) number))
2584   (:printer byte-imm ((op #b11001101)))
2585   (:emitter
2586    (etypecase number
2587      ((member 3)
2588       (emit-byte segment #b11001100))
2589      ((unsigned-byte 8)
2590       (emit-byte segment #b11001101)
2591       (emit-byte segment number)))))
2592
2593 (define-instruction into (segment)
2594   (:printer byte ((op #b11001110)))
2595   (:emitter
2596    (emit-byte segment #b11001110)))
2597
2598 (define-instruction bound (segment reg bounds)
2599   (:emitter
2600    (let ((size (matching-operand-size reg bounds)))
2601      (when (eq size :byte)
2602        (error "can't bounds-test bytes: ~S" reg))
2603      (maybe-emit-operand-size-prefix segment size)
2604      (maybe-emit-rex-for-ea segment bounds reg)
2605      (emit-byte segment #b01100010)
2606      (emit-ea segment bounds (reg-tn-encoding reg)))))
2607
2608 (define-instruction iret (segment)
2609   (:printer byte ((op #b11001111)))
2610   (:emitter
2611    (emit-byte segment #b11001111)))
2612 \f
2613 ;;;; processor control
2614
2615 (define-instruction hlt (segment)
2616   (:printer byte ((op #b11110100)))
2617   (:emitter
2618    (emit-byte segment #b11110100)))
2619
2620 (define-instruction nop (segment)
2621   (:printer byte ((op #b10010000)))
2622   (:emitter
2623    (emit-byte segment #b10010000)))
2624
2625 (define-instruction wait (segment)
2626   (:printer byte ((op #b10011011)))
2627   (:emitter
2628    (emit-byte segment #b10011011)))
2629
2630 (define-instruction lock (segment)
2631   (:printer byte ((op #b11110000)))
2632   (:emitter
2633    (emit-byte segment #b11110000)))
2634 \f
2635 ;;;; miscellaneous hackery
2636
2637 (define-instruction byte (segment byte)
2638   (:emitter
2639    (emit-byte segment byte)))
2640
2641 (define-instruction word (segment word)
2642   (:emitter
2643    (emit-word segment word)))
2644
2645 (define-instruction dword (segment dword)
2646   (:emitter
2647    (emit-dword segment dword)))
2648
2649 (defun emit-header-data (segment type)
2650   (emit-back-patch segment
2651                    n-word-bytes
2652                    (lambda (segment posn)
2653                      (emit-qword segment
2654                                  (logior type
2655                                          (ash (+ posn
2656                                                  (component-header-length))
2657                                               (- n-widetag-bits
2658                                                  word-shift)))))))
2659
2660 (define-instruction simple-fun-header-word (segment)
2661   (:emitter
2662    (emit-header-data segment simple-fun-header-widetag)))
2663
2664 (define-instruction lra-header-word (segment)
2665   (:emitter
2666    (emit-header-data segment return-pc-header-widetag)))
2667 \f
2668 ;;;; fp instructions
2669 ;;;;
2670 ;;;; Note: We treat the single-precision and double-precision variants
2671 ;;;; as separate instructions.
2672
2673 ;;; Load single to st(0).
2674 (define-instruction fld (segment source)
2675   (:printer floating-point ((op '(#b001 #b000))))
2676   (:emitter
2677     (and (not (fp-reg-tn-p source))
2678          (maybe-emit-rex-for-ea segment source nil))
2679     (emit-byte segment #b11011001)
2680     (emit-fp-op segment source #b000)))
2681
2682 ;;; Load double to st(0).
2683 (define-instruction fldd (segment source)
2684   (:printer floating-point ((op '(#b101 #b000))))
2685   (:printer floating-point-fp ((op '(#b001 #b000))))
2686   (:emitter
2687    (if (fp-reg-tn-p source)
2688        (emit-byte segment #b11011001)
2689        (progn
2690          (maybe-emit-rex-for-ea segment source nil)
2691          (emit-byte segment #b11011101)))
2692    (emit-fp-op segment source #b000)))
2693
2694 ;;; Load long to st(0).
2695 (define-instruction fldl (segment source)
2696   (:printer floating-point ((op '(#b011 #b101))))
2697   (:emitter
2698     (and (not (fp-reg-tn-p source))
2699          (maybe-emit-rex-for-ea segment source nil))
2700     (emit-byte segment #b11011011)
2701     (emit-fp-op segment source #b101)))
2702
2703 ;;; Store single from st(0).
2704 (define-instruction fst (segment dest)
2705   (:printer floating-point ((op '(#b001 #b010))))
2706   (:emitter
2707     (cond ((fp-reg-tn-p dest)
2708            (emit-byte segment #b11011101)
2709            (emit-fp-op segment dest #b010))
2710           (t
2711            (maybe-emit-rex-for-ea segment dest nil)
2712            (emit-byte segment #b11011001)
2713            (emit-fp-op segment dest #b010)))))
2714
2715 ;;; Store double from st(0).
2716 (define-instruction fstd (segment dest)
2717   (:printer floating-point ((op '(#b101 #b010))))
2718   (:printer floating-point-fp ((op '(#b101 #b010))))
2719   (:emitter
2720    (cond ((fp-reg-tn-p dest)
2721           (emit-byte segment #b11011101)
2722           (emit-fp-op segment dest #b010))
2723          (t
2724           (maybe-emit-rex-for-ea segment dest nil)
2725           (emit-byte segment #b11011101)
2726           (emit-fp-op segment dest #b010)))))
2727
2728 ;;; Arithmetic ops are all done with at least one operand at top of
2729 ;;; stack. The other operand is is another register or a 32/64 bit
2730 ;;; memory loc.
2731
2732 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2733 ;;; that these conflict with the Gdb conventions for binops. To reduce
2734 ;;; the confusion I've added comments showing the mathamatical
2735 ;;; operation and the two syntaxes. By the ASM386 convention the
2736 ;;; instruction syntax is:
2737 ;;;
2738 ;;;      Fop Source
2739 ;;; or   Fop Destination, Source
2740 ;;;
2741 ;;; If only one operand is given then it is the source and the
2742 ;;; destination is ST(0). There are reversed forms of the fsub and
2743 ;;; fdiv instructions inducated by an 'R' suffix.
2744 ;;;
2745 ;;; The mathematical operation for the non-reverse form is always:
2746 ;;;     destination = destination op source
2747 ;;;
2748 ;;; For the reversed form it is:
2749 ;;;     destination = source op destination
2750 ;;;
2751 ;;; The instructions below only accept one operand at present which is
2752 ;;; usually the source. I've hack in extra instructions to implement
2753 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2754 ;;; the operand is the destination with the source being ST(0).
2755
2756 ;;; Add single:
2757 ;;;   st(0) = st(0) + memory or st(i).
2758 (define-instruction fadd (segment source)
2759   (:printer floating-point ((op '(#b000 #b000))))
2760   (:emitter
2761     (and (not (fp-reg-tn-p source))
2762          (maybe-emit-rex-for-ea segment source nil))
2763     (emit-byte segment #b11011000)
2764     (emit-fp-op segment source #b000)))
2765
2766 ;;; Add double:
2767 ;;;   st(0) = st(0) + memory or st(i).
2768 (define-instruction faddd (segment source)
2769   (:printer floating-point ((op '(#b100 #b000))))
2770   (:printer floating-point-fp ((op '(#b000 #b000))))
2771   (:emitter
2772    (and (not (fp-reg-tn-p source))
2773         (maybe-emit-rex-for-ea segment source nil))
2774    (if (fp-reg-tn-p source)
2775        (emit-byte segment #b11011000)
2776      (emit-byte segment #b11011100))
2777    (emit-fp-op segment source #b000)))
2778
2779 ;;; Add double destination st(i):
2780 ;;;   st(i) = st(0) + st(i).
2781 (define-instruction fadd-sti (segment destination)
2782   (:printer floating-point-fp ((op '(#b100 #b000))))
2783   (:emitter
2784    (aver (fp-reg-tn-p destination))
2785    (emit-byte segment #b11011100)
2786    (emit-fp-op segment destination #b000)))
2787 ;;; with pop
2788 (define-instruction faddp-sti (segment destination)
2789   (:printer floating-point-fp ((op '(#b110 #b000))))
2790   (:emitter
2791    (aver (fp-reg-tn-p destination))
2792    (emit-byte segment #b11011110)
2793    (emit-fp-op segment destination #b000)))
2794
2795 ;;; Subtract single:
2796 ;;;   st(0) = st(0) - memory or st(i).
2797 (define-instruction fsub (segment source)
2798   (:printer floating-point ((op '(#b000 #b100))))
2799   (:emitter
2800     (and (not (fp-reg-tn-p source))
2801          (maybe-emit-rex-for-ea segment source nil))
2802     (emit-byte segment #b11011000)
2803     (emit-fp-op segment source #b100)))
2804
2805 ;;; Subtract single, reverse:
2806 ;;;   st(0) = memory or st(i) - st(0).
2807 (define-instruction fsubr (segment source)
2808   (:printer floating-point ((op '(#b000 #b101))))
2809   (:emitter
2810     (and (not (fp-reg-tn-p source))
2811          (maybe-emit-rex-for-ea segment source nil))
2812     (emit-byte segment #b11011000)
2813     (emit-fp-op segment source #b101)))
2814
2815 ;;; Subtract double:
2816 ;;;   st(0) = st(0) - memory or st(i).
2817 (define-instruction fsubd (segment source)
2818   (:printer floating-point ((op '(#b100 #b100))))
2819   (:printer floating-point-fp ((op '(#b000 #b100))))
2820   (:emitter
2821    (if (fp-reg-tn-p source)
2822        (emit-byte segment #b11011000)
2823        (progn
2824          (and (not (fp-reg-tn-p source))
2825               (maybe-emit-rex-for-ea segment source nil))
2826          (emit-byte segment #b11011100)))
2827    (emit-fp-op segment source #b100)))
2828
2829 ;;; Subtract double, reverse:
2830 ;;;   st(0) = memory or st(i) - st(0).
2831 (define-instruction fsubrd (segment source)
2832   (:printer floating-point ((op '(#b100 #b101))))
2833   (:printer floating-point-fp ((op '(#b000 #b101))))
2834   (:emitter
2835    (if (fp-reg-tn-p source)
2836        (emit-byte segment #b11011000)
2837        (progn
2838          (and (not (fp-reg-tn-p source))
2839               (maybe-emit-rex-for-ea segment source nil))
2840          (emit-byte segment #b11011100)))
2841    (emit-fp-op segment source #b101)))
2842
2843 ;;; Subtract double, destination st(i):
2844 ;;;   st(i) = st(i) - st(0).
2845 ;;;
2846 ;;; ASM386 syntax: FSUB ST(i), ST
2847 ;;; Gdb    syntax: fsubr %st,%st(i)
2848 (define-instruction fsub-sti (segment destination)
2849   (:printer floating-point-fp ((op '(#b100 #b101))))
2850   (:emitter
2851    (aver (fp-reg-tn-p destination))
2852    (emit-byte segment #b11011100)
2853    (emit-fp-op segment destination #b101)))
2854 ;;; with a pop
2855 (define-instruction fsubp-sti (segment destination)
2856   (:printer floating-point-fp ((op '(#b110 #b101))))
2857   (:emitter
2858    (aver (fp-reg-tn-p destination))
2859    (emit-byte segment #b11011110)
2860    (emit-fp-op segment destination #b101)))
2861
2862 ;;; Subtract double, reverse, destination st(i):
2863 ;;;   st(i) = st(0) - st(i).
2864 ;;;
2865 ;;; ASM386 syntax: FSUBR ST(i), ST
2866 ;;; Gdb    syntax: fsub %st,%st(i)
2867 (define-instruction fsubr-sti (segment destination)
2868   (:printer floating-point-fp ((op '(#b100 #b100))))
2869   (:emitter
2870    (aver (fp-reg-tn-p destination))
2871    (emit-byte segment #b11011100)
2872    (emit-fp-op segment destination #b100)))
2873 ;;; with a pop
2874 (define-instruction fsubrp-sti (segment destination)
2875   (:printer floating-point-fp ((op '(#b110 #b100))))
2876   (:emitter
2877    (aver (fp-reg-tn-p destination))
2878    (emit-byte segment #b11011110)
2879    (emit-fp-op segment destination #b100)))
2880
2881 ;;; Multiply single:
2882 ;;;   st(0) = st(0) * memory or st(i).
2883 (define-instruction fmul (segment source)
2884   (:printer floating-point ((op '(#b000 #b001))))
2885   (:emitter
2886    (and (not (fp-reg-tn-p source))
2887         (maybe-emit-rex-for-ea segment source nil))
2888    (emit-byte segment #b11011000)
2889    (emit-fp-op segment source #b001)))
2890
2891 ;;; Multiply double:
2892 ;;;   st(0) = st(0) * memory or st(i).
2893 (define-instruction fmuld (segment source)
2894   (:printer floating-point ((op '(#b100 #b001))))
2895   (:printer floating-point-fp ((op '(#b000 #b001))))
2896   (:emitter
2897    (if (fp-reg-tn-p source)
2898        (emit-byte segment #b11011000)
2899        (progn
2900          (and (not (fp-reg-tn-p source))
2901               (maybe-emit-rex-for-ea segment source nil))
2902          (emit-byte segment #b11011100)))
2903    (emit-fp-op segment source #b001)))
2904
2905 ;;; Multiply double, destination st(i):
2906 ;;;   st(i) = st(i) * st(0).
2907 (define-instruction fmul-sti (segment destination)
2908   (:printer floating-point-fp ((op '(#b100 #b001))))
2909   (:emitter
2910    (aver (fp-reg-tn-p destination))
2911    (emit-byte segment #b11011100)
2912    (emit-fp-op segment destination #b001)))
2913
2914 ;;; Divide single:
2915 ;;;   st(0) = st(0) / memory or st(i).
2916 (define-instruction fdiv (segment source)
2917   (:printer floating-point ((op '(#b000 #b110))))
2918   (:emitter
2919    (and (not (fp-reg-tn-p source))
2920         (maybe-emit-rex-for-ea segment source nil))
2921    (emit-byte segment #b11011000)
2922    (emit-fp-op segment source #b110)))
2923
2924 ;;; Divide single, reverse:
2925 ;;;   st(0) = memory or st(i) / st(0).
2926 (define-instruction fdivr (segment source)
2927   (:printer floating-point ((op '(#b000 #b111))))
2928   (:emitter
2929    (and (not (fp-reg-tn-p source))
2930         (maybe-emit-rex-for-ea segment source nil))
2931    (emit-byte segment #b11011000)
2932    (emit-fp-op segment source #b111)))
2933
2934 ;;; Divide double:
2935 ;;;   st(0) = st(0) / memory or st(i).
2936 (define-instruction fdivd (segment source)
2937   (:printer floating-point ((op '(#b100 #b110))))
2938   (:printer floating-point-fp ((op '(#b000 #b110))))
2939   (:emitter
2940    (if (fp-reg-tn-p source)
2941        (emit-byte segment #b11011000)
2942        (progn
2943          (and (not (fp-reg-tn-p source))
2944               (maybe-emit-rex-for-ea segment source nil))
2945          (emit-byte segment #b11011100)))
2946    (emit-fp-op segment source #b110)))
2947
2948 ;;; Divide double, reverse:
2949 ;;;   st(0) = memory or st(i) / st(0).
2950 (define-instruction fdivrd (segment source)
2951   (:printer floating-point ((op '(#b100 #b111))))
2952   (:printer floating-point-fp ((op '(#b000 #b111))))
2953   (:emitter
2954    (if (fp-reg-tn-p source)
2955        (emit-byte segment #b11011000)
2956        (progn
2957          (and (not (fp-reg-tn-p source))
2958               (maybe-emit-rex-for-ea segment source nil))
2959          (emit-byte segment #b11011100)))
2960    (emit-fp-op segment source #b111)))
2961
2962 ;;; Divide double, destination st(i):
2963 ;;;   st(i) = st(i) / st(0).
2964 ;;;
2965 ;;; ASM386 syntax: FDIV ST(i), ST
2966 ;;; Gdb    syntax: fdivr %st,%st(i)
2967 (define-instruction fdiv-sti (segment destination)
2968   (:printer floating-point-fp ((op '(#b100 #b111))))
2969   (:emitter
2970    (aver (fp-reg-tn-p destination))
2971    (emit-byte segment #b11011100)
2972    (emit-fp-op segment destination #b111)))
2973
2974 ;;; Divide double, reverse, destination st(i):
2975 ;;;   st(i) = st(0) / st(i).
2976 ;;;
2977 ;;; ASM386 syntax: FDIVR ST(i), ST
2978 ;;; Gdb    syntax: fdiv %st,%st(i)
2979 (define-instruction fdivr-sti (segment destination)
2980   (:printer floating-point-fp ((op '(#b100 #b110))))
2981   (:emitter
2982    (aver (fp-reg-tn-p destination))
2983    (emit-byte segment #b11011100)
2984    (emit-fp-op segment destination #b110)))
2985
2986 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2987 (define-instruction fxch (segment source)
2988   (:printer floating-point-fp ((op '(#b001 #b001))))
2989   (:emitter
2990     (unless (and (tn-p source)
2991                  (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2992       (cl:break))
2993     (emit-byte segment #b11011001)
2994     (emit-fp-op segment source #b001)))
2995
2996 ;;; Push 32-bit integer to st0.
2997 (define-instruction fild (segment source)
2998   (:printer floating-point ((op '(#b011 #b000))))
2999   (:emitter
3000     (and (not (fp-reg-tn-p source))
3001          (maybe-emit-rex-for-ea segment source nil))
3002     (emit-byte segment #b11011011)
3003     (emit-fp-op segment source #b000)))
3004
3005 ;;; Push 64-bit integer to st0.
3006 (define-instruction fildl (segment source)
3007   (:printer floating-point ((op '(#b111 #b101))))
3008   (:emitter
3009     (and (not (fp-reg-tn-p source))
3010          (maybe-emit-rex-for-ea segment source nil))
3011     (emit-byte segment #b11011111)
3012     (emit-fp-op segment source #b101)))
3013
3014 ;;; Store 32-bit integer.
3015 (define-instruction fist (segment dest)
3016   (:printer floating-point ((op '(#b011 #b010))))
3017   (:emitter
3018    (and (not (fp-reg-tn-p dest))
3019         (maybe-emit-rex-for-ea segment dest nil))
3020    (emit-byte segment #b11011011)
3021    (emit-fp-op segment dest #b010)))
3022
3023 ;;; Store and pop 32-bit integer.
3024 (define-instruction fistp (segment dest)
3025   (:printer floating-point ((op '(#b011 #b011))))
3026   (:emitter
3027    (and (not (fp-reg-tn-p dest))
3028         (maybe-emit-rex-for-ea segment dest nil))
3029    (emit-byte segment #b11011011)
3030    (emit-fp-op segment dest #b011)))
3031
3032 ;;; Store and pop 64-bit integer.
3033 (define-instruction fistpl (segment dest)
3034   (:printer floating-point ((op '(#b111 #b111))))
3035   (:emitter
3036    (and (not (fp-reg-tn-p dest))
3037         (maybe-emit-rex-for-ea segment dest nil))
3038    (emit-byte segment #b11011111)
3039    (emit-fp-op segment dest #b111)))
3040
3041 ;;; Store single from st(0) and pop.
3042 (define-instruction fstp (segment dest)
3043   (:printer floating-point ((op '(#b001 #b011))))
3044   (:emitter
3045    (cond ((fp-reg-tn-p dest)
3046           (emit-byte segment #b11011101)
3047           (emit-fp-op segment dest #b011))
3048          (t
3049           (maybe-emit-rex-for-ea segment dest nil)
3050           (emit-byte segment #b11011001)
3051           (emit-fp-op segment dest #b011)))))
3052
3053 ;;; Store double from st(0) and pop.
3054 (define-instruction fstpd (segment dest)
3055   (:printer floating-point ((op '(#b101 #b011))))
3056   (:printer floating-point-fp ((op '(#b101 #b011))))
3057   (:emitter
3058    (cond ((fp-reg-tn-p dest)
3059           (emit-byte segment #b11011101)
3060           (emit-fp-op segment dest #b011))
3061          (t
3062           (maybe-emit-rex-for-ea segment dest nil)
3063           (emit-byte segment #b11011101)
3064           (emit-fp-op segment dest #b011)))))
3065
3066 ;;; Store long from st(0) and pop.
3067 (define-instruction fstpl (segment dest)
3068   (:printer floating-point ((op '(#b011 #b111))))
3069   (:emitter
3070    (and (not (fp-reg-tn-p dest))
3071         (maybe-emit-rex-for-ea segment dest nil))
3072    (emit-byte segment #b11011011)
3073    (emit-fp-op segment dest #b111)))
3074
3075 ;;; Decrement stack-top pointer.
3076 (define-instruction fdecstp (segment)
3077   (:printer floating-point-no ((op #b10110)))
3078   (:emitter
3079    (emit-byte segment #b11011001)
3080    (emit-byte segment #b11110110)))
3081
3082 ;;; Increment stack-top pointer.
3083 (define-instruction fincstp (segment)
3084   (:printer floating-point-no ((op #b10111)))
3085   (:emitter
3086    (emit-byte segment #b11011001)
3087    (emit-byte segment #b11110111)))
3088
3089 ;;; Free fp register.
3090 (define-instruction ffree (segment dest)
3091   (:printer floating-point-fp ((op '(#b101 #b000))))
3092   (:emitter
3093    (and (not (fp-reg-tn-p dest))
3094         (maybe-emit-rex-for-ea segment dest nil))
3095    (emit-byte segment #b11011101)
3096    (emit-fp-op segment dest #b000)))
3097
3098 (define-instruction fabs (segment)
3099   (:printer floating-point-no ((op #b00001)))
3100   (:emitter
3101    (emit-byte segment #b11011001)
3102    (emit-byte segment #b11100001)))
3103
3104 (define-instruction fchs (segment)
3105   (:printer floating-point-no ((op #b00000)))
3106   (:emitter
3107    (emit-byte segment #b11011001)
3108    (emit-byte segment #b11100000)))
3109
3110 (define-instruction frndint(segment)
3111   (:printer floating-point-no ((op #b11100)))
3112   (:emitter
3113    (emit-byte segment #b11011001)
3114    (emit-byte segment #b11111100)))
3115
3116 ;;; Initialize NPX.
3117 (define-instruction fninit(segment)
3118   (:printer floating-point-5 ((op #b00011)))
3119   (:emitter
3120    (emit-byte segment #b11011011)
3121    (emit-byte segment #b11100011)))
3122
3123 ;;; Store Status Word to AX.
3124 (define-instruction fnstsw(segment)
3125   (:printer floating-point-st ((op #b00000)))
3126   (:emitter
3127    (emit-byte segment #b11011111)
3128    (emit-byte segment #b11100000)))
3129
3130 ;;; Load Control Word.
3131 ;;;
3132 ;;; src must be a memory location
3133 (define-instruction fldcw(segment src)
3134   (:printer floating-point ((op '(#b001 #b101))))
3135   (:emitter
3136    (and (not (fp-reg-tn-p src))
3137         (maybe-emit-rex-for-ea segment src nil))
3138    (emit-byte segment #b11011001)
3139    (emit-fp-op segment src #b101)))
3140
3141 ;;; Store Control Word.
3142 (define-instruction fnstcw(segment dst)
3143   (:printer floating-point ((op '(#b001 #b111))))
3144   (:emitter
3145    (and (not (fp-reg-tn-p dst))
3146         (maybe-emit-rex-for-ea segment dst nil))
3147    (emit-byte segment #b11011001)
3148    (emit-fp-op segment dst #b111)))
3149
3150 ;;; Store FP Environment.
3151 (define-instruction fstenv(segment dst)
3152   (:printer floating-point ((op '(#b001 #b110))))
3153   (:emitter
3154    (and (not (fp-reg-tn-p dst))
3155         (maybe-emit-rex-for-ea segment dst nil))
3156    (emit-byte segment #b11011001)
3157    (emit-fp-op segment dst #b110)))
3158
3159 ;;; Restore FP Environment.
3160 (define-instruction fldenv(segment src)
3161   (:printer floating-point ((op '(#b001 #b100))))
3162   (:emitter
3163    (and (not (fp-reg-tn-p src))
3164         (maybe-emit-rex-for-ea segment src nil))
3165    (emit-byte segment #b11011001)
3166    (emit-fp-op segment src #b100)))
3167
3168 ;;; Save FP State.
3169 (define-instruction fsave(segment dst)
3170   (:printer floating-point ((op '(#b101 #b110))))
3171   (:emitter
3172    (and (not (fp-reg-tn-p dst))
3173         (maybe-emit-rex-for-ea segment dst nil))
3174    (emit-byte segment #b11011101)
3175    (emit-fp-op segment dst #b110)))
3176
3177 ;;; Restore FP State.
3178 (define-instruction frstor(segment src)
3179   (:printer floating-point ((op '(#b101 #b100))))
3180   (:emitter
3181    (and (not (fp-reg-tn-p src))
3182         (maybe-emit-rex-for-ea segment src nil))
3183    (emit-byte segment #b11011101)
3184    (emit-fp-op segment src #b100)))
3185
3186 ;;; Clear exceptions.
3187 (define-instruction fnclex(segment)
3188   (:printer floating-point-5 ((op #b00010)))
3189   (:emitter
3190    (emit-byte segment #b11011011)
3191    (emit-byte segment #b11100010)))
3192
3193 ;;; comparison
3194 (define-instruction fcom (segment src)
3195   (:printer floating-point ((op '(#b000 #b010))))
3196   (:emitter
3197    (and (not (fp-reg-tn-p src))
3198         (maybe-emit-rex-for-ea segment src nil))
3199    (emit-byte segment #b11011000)
3200    (emit-fp-op segment src #b010)))
3201
3202 (define-instruction fcomd (segment src)
3203   (:printer floating-point ((op '(#b100 #b010))))
3204   (:printer floating-point-fp ((op '(#b000 #b010))))
3205   (:emitter
3206    (if (fp-reg-tn-p src)
3207        (emit-byte segment #b11011000)
3208        (progn
3209          (maybe-emit-rex-for-ea segment src nil)
3210          (emit-byte segment #b11011100)))
3211    (emit-fp-op segment src #b010)))
3212
3213 ;;; Compare ST1 to ST0, popping the stack twice.
3214 (define-instruction fcompp (segment)
3215   (:printer floating-point-3 ((op '(#b110 #b011001))))
3216   (:emitter
3217    (emit-byte segment #b11011110)
3218    (emit-byte segment #b11011001)))
3219
3220 ;;; unordered comparison
3221 (define-instruction fucom (segment src)
3222   (:printer floating-point-fp ((op '(#b101 #b100))))
3223   (:emitter
3224    (aver (fp-reg-tn-p src))
3225    (emit-byte segment #b11011101)
3226    (emit-fp-op segment src #b100)))
3227
3228 (define-instruction ftst (segment)
3229   (:printer floating-point-no ((op #b00100)))
3230   (:emitter
3231    (emit-byte segment #b11011001)
3232    (emit-byte segment #b11100100)))
3233
3234 ;;;; 80387 specials
3235
3236 (define-instruction fsqrt(segment)
3237   (:printer floating-point-no ((op #b11010)))
3238   (:emitter
3239    (emit-byte segment #b11011001)
3240    (emit-byte segment #b11111010)))
3241
3242 (define-instruction fscale(segment)
3243   (:printer floating-point-no ((op #b11101)))
3244   (:emitter
3245    (emit-byte segment #b11011001)
3246    (emit-byte segment #b11111101)))
3247
3248 (define-instruction fxtract(segment)
3249   (:printer floating-point-no ((op #b10100)))
3250   (:emitter
3251    (emit-byte segment #b11011001)
3252    (emit-byte segment #b11110100)))
3253
3254 (define-instruction fsin(segment)
3255   (:printer floating-point-no ((op #b11110)))
3256   (:emitter
3257    (emit-byte segment #b11011001)
3258    (emit-byte segment #b11111110)))
3259
3260 (define-instruction fcos(segment)
3261   (:printer floating-point-no ((op #b11111)))
3262   (:emitter
3263    (emit-byte segment #b11011001)
3264    (emit-byte segment #b11111111)))
3265
3266 (define-instruction fprem1(segment)
3267   (:printer floating-point-no ((op #b10101)))
3268   (:emitter
3269    (emit-byte segment #b11011001)
3270    (emit-byte segment #b11110101)))
3271
3272 (define-instruction fprem(segment)
3273   (:printer floating-point-no ((op #b11000)))
3274   (:emitter
3275    (emit-byte segment #b11011001)
3276    (emit-byte segment #b11111000)))
3277
3278 (define-instruction fxam (segment)
3279   (:printer floating-point-no ((op #b00101)))
3280   (:emitter
3281    (emit-byte segment #b11011001)
3282    (emit-byte segment #b11100101)))
3283
3284 ;;; These do push/pop to stack and need special handling
3285 ;;; in any VOPs that use them. See the book.
3286
3287 ;;; st0 <- st1*log2(st0)
3288 (define-instruction fyl2x(segment)      ; pops stack
3289   (:printer floating-point-no ((op #b10001)))
3290   (:emitter
3291    (emit-byte segment #b11011001)
3292    (emit-byte segment #b11110001)))
3293
3294 (define-instruction fyl2xp1(segment)
3295   (:printer floating-point-no ((op #b11001)))
3296   (:emitter
3297    (emit-byte segment #b11011001)
3298    (emit-byte segment #b11111001)))
3299
3300 (define-instruction f2xm1(segment)
3301   (:printer floating-point-no ((op #b10000)))
3302   (:emitter
3303    (emit-byte segment #b11011001)
3304    (emit-byte segment #b11110000)))
3305
3306 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
3307   (:printer floating-point-no ((op #b10010)))
3308   (:emitter
3309    (emit-byte segment #b11011001)
3310    (emit-byte segment #b11110010)))
3311
3312 (define-instruction fpatan(segment)     ; POPS STACK
3313   (:printer floating-point-no ((op #b10011)))
3314   (:emitter
3315    (emit-byte segment #b11011001)
3316    (emit-byte segment #b11110011)))
3317
3318 ;;;; loading constants
3319
3320 (define-instruction fldz(segment)
3321   (:printer floating-point-no ((op #b01110)))
3322   (:emitter
3323    (emit-byte segment #b11011001)
3324    (emit-byte segment #b11101110)))
3325
3326 (define-instruction fld1(segment)
3327   (:printer floating-point-no ((op #b01000)))
3328   (:emitter
3329    (emit-byte segment #b11011001)
3330    (emit-byte segment #b11101000)))
3331
3332 (define-instruction fldpi(segment)
3333   (:printer floating-point-no ((op #b01011)))
3334   (:emitter
3335    (emit-byte segment #b11011001)
3336    (emit-byte segment #b11101011)))
3337
3338 (define-instruction fldl2t(segment)
3339   (:printer floating-point-no ((op #b01001)))
3340   (:emitter
3341    (emit-byte segment #b11011001)
3342    (emit-byte segment #b11101001)))
3343
3344 (define-instruction fldl2e(segment)
3345   (:printer floating-point-no ((op #b01010)))
3346   (:emitter
3347    (emit-byte segment #b11011001)
3348    (emit-byte segment #b11101010)))
3349
3350 (define-instruction fldlg2(segment)
3351   (:printer floating-point-no ((op #b01100)))
3352   (:emitter
3353    (emit-byte segment #b11011001)
3354    (emit-byte segment #b11101100)))
3355
3356 (define-instruction fldln2(segment)
3357   (:printer floating-point-no ((op #b01101)))
3358   (:emitter
3359    (emit-byte segment #b11011001)
3360    (emit-byte segment #b11101101)))
3361
3362 ;; new xmm insns required by sse float
3363 ;; movsd andpd comisd comiss
3364
3365 (define-instruction movsd (segment dst src)
3366 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3367   (:emitter
3368    (cond ((typep src 'tn)
3369           (emit-byte segment #xf2)
3370           (maybe-emit-rex-for-ea segment dst src)
3371           (emit-byte segment #x0f)
3372           (emit-byte segment #x11)
3373           (emit-ea segment dst (reg-tn-encoding src)))
3374          (t
3375           (emit-byte segment #xf2)
3376           (maybe-emit-rex-for-ea segment src dst)
3377           (emit-byte segment #x0f)
3378           (emit-byte segment #x10)
3379           (emit-ea segment src (reg-tn-encoding dst))))))
3380
3381 (define-instruction movss (segment dst src)
3382 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3383   (:emitter
3384    (cond ((tn-p src)
3385           (emit-byte segment #xf3)
3386           (maybe-emit-rex-for-ea segment dst src)
3387           (emit-byte segment #x0f)
3388           (emit-byte segment #x11)
3389           (emit-ea segment dst (reg-tn-encoding src)))
3390          (t
3391           (emit-byte segment #xf3)
3392           (maybe-emit-rex-for-ea segment src dst)
3393           (emit-byte segment #x0f)
3394           (emit-byte segment #x10)
3395           (emit-ea segment src (reg-tn-encoding dst))))))
3396
3397 (define-instruction andpd (segment dst src)
3398 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3399   (:emitter
3400    (emit-byte segment #x66)
3401    (maybe-emit-rex-for-ea segment src dst)
3402    (emit-byte segment #x0f)
3403    (emit-byte segment #x54)
3404    (emit-ea segment src (reg-tn-encoding dst))))
3405
3406 (define-instruction andps (segment dst src)
3407   (:emitter
3408    (maybe-emit-rex-for-ea segment src dst)
3409    (emit-byte segment #x0f)
3410    (emit-byte segment #x54)
3411    (emit-ea segment src (reg-tn-encoding dst))))
3412
3413 (define-instruction comisd (segment dst src)
3414 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3415   (:emitter
3416    (emit-byte segment #x66)
3417    (maybe-emit-rex-for-ea segment src dst)
3418    (emit-byte segment #x0f)
3419    (emit-byte segment #x2f)
3420    (emit-ea segment src (reg-tn-encoding dst))))
3421
3422 (define-instruction comiss (segment dst src)
3423 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3424   (:emitter
3425    (maybe-emit-rex-for-ea segment src dst)
3426    (emit-byte segment #x0f)
3427    (emit-byte segment #x2f)
3428    (emit-ea segment src (reg-tn-encoding dst))))
3429
3430 ;;  movd movq xorp xord
3431
3432 ;; we only do the xmm version of movd
3433 (define-instruction movd (segment dst src)
3434 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3435   (:emitter
3436    (cond ((fp-reg-tn-p dst)
3437           (emit-byte segment #x66)
3438           (maybe-emit-rex-for-ea segment src dst)
3439           (emit-byte segment #x0f)
3440           (emit-byte segment #x6e)
3441           (emit-ea segment src (reg-tn-encoding dst)))
3442          (t
3443           (aver (fp-reg-tn-p src))
3444           (emit-byte segment #x66)
3445           (maybe-emit-rex-for-ea segment dst src)
3446           (emit-byte segment #x0f)
3447           (emit-byte segment #x7e)
3448           (emit-ea segment dst (reg-tn-encoding src))))))
3449
3450 (define-instruction movq (segment dst src)
3451 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3452   (:emitter
3453    (cond ((fp-reg-tn-p dst)
3454           (emit-byte segment #xf3)
3455           (maybe-emit-rex-for-ea segment src dst)
3456           (emit-byte segment #x0f)
3457           (emit-byte segment #x7e)
3458           (emit-ea segment src (reg-tn-encoding dst)))
3459          (t
3460           (aver (fp-reg-tn-p src))
3461           (emit-byte segment #x66)
3462           (maybe-emit-rex-for-ea segment dst src)
3463           (emit-byte segment #x0f)
3464           (emit-byte segment #xd6)
3465           (emit-ea segment dst (reg-tn-encoding src))))))
3466
3467 (define-instruction xorpd (segment dst src)
3468 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3469   (:emitter
3470    (emit-byte segment #x66)
3471    (maybe-emit-rex-for-ea segment src dst)
3472    (emit-byte segment #x0f)
3473    (emit-byte segment #x57)
3474    (emit-ea segment src (reg-tn-encoding dst))))
3475
3476 (define-instruction xorps (segment dst src)
3477 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3478   (:emitter
3479    (maybe-emit-rex-for-ea segment src dst)
3480    (emit-byte segment #x0f)
3481    (emit-byte segment #x57)
3482    (emit-ea segment src (reg-tn-encoding dst))))
3483
3484 (define-instruction cvtsd2si (segment dst src)
3485 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3486   (:emitter
3487    (emit-byte segment #xf2)
3488    (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
3489    (emit-byte segment #x0f)
3490    (emit-byte segment #x2d)
3491    (emit-ea segment src (reg-tn-encoding dst))))
3492
3493 (define-instruction cvtsd2ss (segment dst src)
3494 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3495   (:emitter
3496    (emit-byte segment #xf2)
3497    (maybe-emit-rex-for-ea segment src dst)
3498    (emit-byte segment #x0f)
3499    (emit-byte segment #x5a)
3500    (emit-ea segment src (reg-tn-encoding dst))))
3501
3502 (define-instruction cvtss2si (segment dst src)
3503 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3504   (:emitter
3505    (emit-byte segment #xf3)
3506    (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
3507    (emit-byte segment #x0f)
3508    (emit-byte segment #x2d)
3509    (emit-ea segment src (reg-tn-encoding dst))))
3510
3511 (define-instruction cvtss2sd (segment dst src)
3512 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3513   (:emitter
3514    (emit-byte segment #xf3)
3515    (maybe-emit-rex-for-ea segment src dst)
3516    (emit-byte segment #x0f)
3517    (emit-byte segment #x5a)
3518    (emit-ea segment src (reg-tn-encoding dst))))
3519
3520 (define-instruction cvtsi2ss (segment dst src)
3521 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3522   (:emitter
3523    (emit-byte segment #xf3)
3524    (maybe-emit-rex-for-ea segment src dst)
3525    (emit-byte segment #x0f)
3526    (emit-byte segment #x2a)
3527    (emit-ea segment src (reg-tn-encoding dst))))
3528
3529 (define-instruction cvtsi2sd (segment dst src)
3530 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3531   (:emitter
3532    (emit-byte segment #xf2)
3533    (maybe-emit-rex-for-ea segment src dst)
3534    (emit-byte segment #x0f)
3535    (emit-byte segment #x2a)
3536    (emit-ea segment src (reg-tn-encoding dst))))
3537
3538 (define-instruction cvtdq2pd (segment dst src)
3539 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3540   (:emitter
3541    (emit-byte segment #xf3)
3542    (maybe-emit-rex-for-ea segment src dst)
3543    (emit-byte segment #x0f)
3544    (emit-byte segment #xe6)
3545    (emit-ea segment src (reg-tn-encoding dst))))
3546
3547 (define-instruction cvtdq2ps (segment dst src)
3548 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3549   (:emitter
3550    (maybe-emit-rex-for-ea segment src dst)
3551    (emit-byte segment #x0f)
3552    (emit-byte segment #x5b)
3553    (emit-ea segment src (reg-tn-encoding dst))))
3554
3555 ;; CVTTSD2SI CVTTSS2SI
3556
3557 (define-instruction cvttsd2si (segment dst src)
3558 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3559   (:emitter
3560    (emit-byte segment #xf2)
3561    (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
3562    (emit-byte segment #x0f)
3563    (emit-byte segment #x2c)
3564    (emit-ea segment src (reg-tn-encoding dst))))
3565
3566 (define-instruction cvttss2si (segment dst src)
3567 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3568   (:emitter
3569    (emit-byte segment #xf3)
3570    (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
3571    (emit-byte segment #x0f)
3572    (emit-byte segment #x2c)
3573    (emit-ea segment src (reg-tn-encoding dst))))
3574
3575 (define-instruction addsd (segment dst src)
3576 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3577   (:emitter
3578    (emit-byte segment #xf2)
3579    (maybe-emit-rex-for-ea segment src dst)
3580    (emit-byte segment #x0f)
3581    (emit-byte segment #x58)
3582    (emit-ea segment src (reg-tn-encoding dst))))
3583
3584 (define-instruction addss (segment dst src)
3585 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3586   (:emitter
3587    (emit-byte segment #xf3)
3588    (maybe-emit-rex-for-ea segment src dst)
3589    (emit-byte segment #x0f)
3590    (emit-byte segment #x58)
3591    (emit-ea segment src (reg-tn-encoding dst))))
3592
3593 (define-instruction divsd (segment dst src)
3594 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3595   (:emitter
3596    (emit-byte segment #xf2)
3597    (maybe-emit-rex-for-ea segment src dst)
3598    (emit-byte segment #x0f)
3599    (emit-byte segment #x5e)
3600    (emit-ea segment src (reg-tn-encoding dst))))
3601
3602 (define-instruction divss (segment dst src)
3603 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3604   (:emitter
3605    (emit-byte segment #xf3)
3606    (maybe-emit-rex-for-ea segment src dst)
3607    (emit-byte segment #x0f)
3608    (emit-byte segment #x5e)
3609    (emit-ea segment src (reg-tn-encoding dst))))
3610
3611 (define-instruction mulsd (segment dst src)
3612 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3613   (:emitter
3614    (emit-byte segment #xf2)
3615    (maybe-emit-rex-for-ea segment src dst)
3616    (emit-byte segment #x0f)
3617    (emit-byte segment #x59)
3618    (emit-ea segment src (reg-tn-encoding dst))))
3619
3620 (define-instruction mulss (segment dst src)
3621 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3622   (:emitter
3623    (emit-byte segment #xf3)
3624    (maybe-emit-rex-for-ea segment src dst)
3625    (emit-byte segment #x0f)
3626    (emit-byte segment #x59)
3627    (emit-ea segment src (reg-tn-encoding dst))))
3628
3629 (define-instruction subsd (segment dst src)
3630 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3631   (:emitter
3632    (emit-byte segment #xf2)
3633    (maybe-emit-rex-for-ea segment src dst)
3634    (emit-byte segment #x0f)
3635    (emit-byte segment #x5c)
3636    (emit-ea segment src (reg-tn-encoding dst))))
3637
3638 (define-instruction subss (segment dst src)
3639 ;  (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
3640   (:emitter
3641    (emit-byte segment #xf3)
3642    (maybe-emit-rex-for-ea segment src dst)
3643    (emit-byte segment #x0f)
3644    (emit-byte segment #x5c)
3645    (emit-ea segment src (reg-tn-encoding dst))))
3646
3647 (define-instruction ldmxcsr (segment src)
3648   (:emitter
3649    (emit-byte segment #x0f)
3650    (emit-byte segment #xae)
3651    (emit-ea segment src 2)))
3652
3653 (define-instruction stmxcsr (segment dst)
3654   (:emitter
3655    (emit-byte segment #x0f)
3656    (emit-byte segment #xae)
3657    (emit-ea segment dst 3)))
3658