src/compiler/x86-64/insts.lisp

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