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