src/compiler/x86-64/insts.lisp

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