;;; This includes legacy registers and R8-R15.
(deftype full-reg () '(unsigned-byte 4))
+;;; The XMM registers XMM0 - XMM15.
+(deftype xmmreg () '(unsigned-byte 4))
+
;;; Default word size for the chip: if the operand size /= :dword
;;; we need to output #x66 (or REX) prefix
(def!constant +default-operand-size+ :dword)
(defun offset-next (value dstate)
(declare (type integer value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(+ (sb!disassem:dstate-next-addr dstate) value))
(defparameter *byte-reg-names*
#(al cl dl bl spl bpl sil dil r8b r9b r10b r11b r12b r13b r14b r15b))
+(defparameter *high-byte-reg-names*
+ #(ah ch dh bh))
(defparameter *word-reg-names*
#(ax cx dx bx sp bp si di r8w r9w r10w r11w r12w r13w r14w r15w))
(defparameter *dword-reg-names*
:word
:qword))
+;;; Print to STREAM the name of the general-purpose register encoded by
+;;; VALUE and of size WIDTH. For robustness, the high byte registers
+;;; (AH, BH, CH, DH) are correctly detected, too, although the compiler
+;;; does not use them.
(defun print-reg-with-width (value width stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (ignore dstate))
- (princ (aref (ecase width
- (:byte *byte-reg-names*)
- (:word *word-reg-names*)
- (:dword *dword-reg-names*)
- (:qword *qword-reg-names*))
- value)
- stream)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (princ (if (and (eq width :byte)
+ (<= 4 value 7)
+ (not (sb!disassem:dstate-get-inst-prop dstate 'rex)))
+ (aref *high-byte-reg-names* (- value 4))
+ (aref (ecase width
+ (:byte *byte-reg-names*)
+ (:word *word-reg-names*)
+ (:dword *dword-reg-names*)
+ (:qword *qword-reg-names*))
+ value))
+ stream)
;; XXX plus should do some source-var notes
)
(defun print-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
(inst-operand-size dstate)
- stream
- dstate))
+ stream
+ dstate))
(defun print-reg-default-qword (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
(inst-operand-size-default-qword dstate)
- stream
- dstate))
+ stream
+ dstate))
(defun print-byte-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value :byte stream dstate))
(defun print-addr-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value +default-address-size+ stream dstate))
;;; Print a register or a memory reference of the given WIDTH.
(declare (type (or list full-reg) value)
(type (member :byte :word :dword :qword) width)
(type boolean sized-p)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'full-reg)
(print-reg-with-width value width stream dstate)
- (print-mem-access value (and sized-p width) stream dstate)))
+ (print-mem-access value width sized-p stream dstate)))
;;; Print a register or a memory reference. The width is determined by
;;; calling INST-OPERAND-SIZE.
(defun print-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size dstate) nil stream dstate))
;; memory references.
(defun print-sized-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size dstate) t stream dstate))
;;; :qword.
(defun print-sized-reg/mem-default-qword (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size-default-qword dstate) t stream dstate))
(defun print-sized-byte-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :byte t stream dstate))
(defun print-sized-word-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :word t stream dstate))
(defun print-sized-dword-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :dword t stream dstate))
(defun print-label (value stream dstate)
(declare (ignore dstate))
(sb!disassem:princ16 value stream))
+(defun print-xmmreg (value stream dstate)
+ (declare (type xmmreg value)
+ (type stream stream)
+ (ignore dstate))
+ (format stream "XMM~d" value))
+
+(defun print-xmmreg/mem (value stream dstate)
+ (declare (type (or list xmmreg) value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (if (typep value 'xmmreg)
+ (print-xmmreg value stream dstate)
+ (print-mem-access value nil nil stream dstate)))
+
;;; This prefilter is used solely for its side effects, namely to put
;;; the bits found in the REX prefix into the DSTATE for use by other
;;; prefilters and by printers.
(defun prefilter-wrxb (value dstate)
(declare (type (unsigned-byte 4) value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(sb!disassem:dstate-put-inst-prop dstate 'rex)
(when (plusp (logand value #b1000))
(sb!disassem:dstate-put-inst-prop dstate 'rex-w))
;;; the property OPERAND-SIZE-8 into the DSTATE if VALUE is 0.
(defun prefilter-width (value dstate)
(declare (type bit value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(when (zerop value)
(sb!disassem:dstate-put-inst-prop dstate 'operand-size-8))
value)
+;;; This prefilter is used solely for its side effect, namely to put
+;;; the property OPERAND-SIZE-16 into the DSTATE.
+(defun prefilter-x66 (value dstate)
+ (declare (type (eql #x66) value)
+ (ignore value)
+ (type sb!disassem:disassem-state dstate))
+ (sb!disassem:dstate-put-inst-prop dstate 'operand-size-16))
+
;;; A register field that can be extended by REX.R.
(defun prefilter-reg-r (value dstate)
(declare (type reg value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(if (sb!disassem::dstate-get-inst-prop dstate 'rex-r)
(+ value 8)
value))
;;; A register field that can be extended by REX.B.
(defun prefilter-reg-b (value dstate)
(declare (type reg value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(if (sb!disassem::dstate-get-inst-prop dstate 'rex-b)
(+ value 8)
value))
;;; INDEX-REG.
(defun prefilter-reg/mem (value dstate)
(declare (type list value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(let ((mod (first value))
- (r/m (second value)))
+ (r/m (second value)))
(declare (type (unsigned-byte 2) mod)
- (type (unsigned-byte 3) r/m))
+ (type (unsigned-byte 3) r/m))
(let ((full-reg (if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
(+ r/m 8)
r/m)))
(declare (type full-reg full-reg))
(cond ((= mod #b11)
- ;; registers
- full-reg)
- ((= r/m #b100)
- ;; sib byte
- (let ((sib (sb!disassem:read-suffix 8 dstate)))
- (declare (type (unsigned-byte 8) sib))
- (let ((base-reg (ldb (byte 3 0) sib))
- (index-reg (ldb (byte 3 3) sib))
- (index-scale (ldb (byte 2 6) sib)))
- (declare (type (unsigned-byte 3) base-reg index-reg)
- (type (unsigned-byte 2) index-scale))
- (let* ((offset
- (case mod
- (#b00
- (if (= base-reg #b101)
- (sb!disassem:read-signed-suffix 32 dstate)
- nil))
- (#b01
- (sb!disassem:read-signed-suffix 8 dstate))
- (#b10
- (sb!disassem:read-signed-suffix 32 dstate)))))
- (list (unless (and (= mod #b00) (= base-reg #b101))
+ ;; registers
+ full-reg)
+ ((= r/m #b100)
+ ;; sib byte
+ (let ((sib (sb!disassem:read-suffix 8 dstate)))
+ (declare (type (unsigned-byte 8) sib))
+ (let ((base-reg (ldb (byte 3 0) sib))
+ (index-reg (ldb (byte 3 3) sib))
+ (index-scale (ldb (byte 2 6) sib)))
+ (declare (type (unsigned-byte 3) base-reg index-reg)
+ (type (unsigned-byte 2) index-scale))
+ (let* ((offset
+ (case mod
+ (#b00
+ (if (= base-reg #b101)
+ (sb!disassem:read-signed-suffix 32 dstate)
+ nil))
+ (#b01
+ (sb!disassem:read-signed-suffix 8 dstate))
+ (#b10
+ (sb!disassem:read-signed-suffix 32 dstate)))))
+ (list (unless (and (= mod #b00) (= base-reg #b101))
(if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
(+ base-reg 8)
base-reg))
- offset
- (unless (= index-reg #b100)
+ offset
+ (unless (= index-reg #b100)
(if (sb!disassem:dstate-get-inst-prop dstate 'rex-x)
(+ index-reg 8)
index-reg))
- (ash 1 index-scale))))))
- ((and (= mod #b00) (= r/m #b101))
- (list 'rip (sb!disassem:read-signed-suffix 32 dstate)) )
- ((= mod #b00)
- (list full-reg))
- ((= mod #b01)
- (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
- (t ; (= mod #b10)
- (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
+ (ash 1 index-scale))))))
+ ((and (= mod #b00) (= r/m #b101))
+ (list 'rip (sb!disassem:read-signed-suffix 32 dstate)))
+ ((= mod #b00)
+ (list full-reg))
+ ((= mod #b01)
+ (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
+ (t ; (= mod #b10)
+ (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
(defun read-address (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(sb!disassem:read-suffix (width-bits (inst-operand-size dstate)) dstate))
(defun width-bits (width)
(:byte 8)
(:word 16)
(:dword 32)
- (:qword 64)
- (:float 32)
- (:double 64)))
+ (:qword 64)))
) ; EVAL-WHEN
\f
(princ (schar (symbol-name (inst-operand-size dstate)) 0)
stream)))
+;;; Used to capture the effect of the #x66 operand size override prefix.
+(sb!disassem:define-arg-type x66
+ :prefilter #'prefilter-x66)
+
(sb!disassem:define-arg-type displacement
:sign-extend t
:use-label #'offset-next
:printer (lambda (value stream dstate)
- (sb!disassem:maybe-note-assembler-routine value nil dstate)
- (print-label value stream dstate)))
+ (sb!disassem:maybe-note-assembler-routine value nil dstate)
+ (print-label value stream dstate)))
(sb!disassem:define-arg-type accum
:printer (lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-reg 0 stream dstate)))
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg 0 stream dstate)))
(sb!disassem:define-arg-type reg
:prefilter #'prefilter-reg-r
;;; argument type definition following this one.
(sb!disassem:define-arg-type signed-imm-data
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(let ((width (width-bits (inst-operand-size dstate))))
(when (= width 64)
(setf width 32))
;;; register.
(sb!disassem:define-arg-type signed-imm-data-upto-qword
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(sb!disassem:read-signed-suffix
(width-bits (inst-operand-size dstate))
dstate)))
;;; argument is PUSH.
(sb!disassem:define-arg-type signed-imm-data-default-qword
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(let ((width (width-bits
(inst-operand-size-default-qword dstate))))
(when (= width 64)
(sb!disassem:define-arg-type signed-imm-byte
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 8 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 8 dstate)))
(sb!disassem:define-arg-type imm-byte
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 8 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 8 dstate)))
;;; needed for the ret imm16 instruction
(sb!disassem:define-arg-type imm-word-16
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 16 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
(sb!disassem:define-arg-type reg/mem
:prefilter #'prefilter-reg/mem
:prefilter #'prefilter-reg/mem
:printer #'print-sized-reg/mem-default-qword)
-;;; added by jrd
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-(defun print-fp-reg (value stream dstate)
- (declare (ignore dstate))
- (format stream "FR~D" value))
-(defun prefilter-fp-reg (value dstate)
- ;; just return it
- (declare (ignore dstate))
- value)
-) ; EVAL-WHEN
-(sb!disassem:define-arg-type fp-reg
- :prefilter #'prefilter-fp-reg
- :printer #'print-fp-reg)
+;;; XMM registers
+(sb!disassem:define-arg-type xmmreg
+ :prefilter #'prefilter-reg-r
+ :printer #'print-xmmreg)
+
+(sb!disassem:define-arg-type xmmreg-b
+ :prefilter #'prefilter-reg-b
+ :printer #'print-xmmreg)
+
+(sb!disassem:define-arg-type xmmreg/mem
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-xmmreg/mem)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *conditions*
(let ((vec (make-array 16 :initial-element nil)))
(dolist (cond *conditions*)
(when (null (aref vec (cdr cond)))
- (setf (aref vec (cdr cond)) (car cond))))
+ (setf (aref vec (cdr cond)) (car cond))))
vec))
) ; EVAL-WHEN
+;;; SSE shuffle patterns. The names end in the number of bits of the
+;;; immediate byte that are used to encode the pattern and the radix
+;;; in which to print the value.
+(macrolet ((define-sse-shuffle-arg-type (name format-string)
+ `(sb!disassem:define-arg-type ,name
+ :type 'imm-byte
+ :printer (lambda (value stream dstate)
+ (declare (type (unsigned-byte 8) value)
+ (type stream stream)
+ (ignore dstate))
+ (format stream ,format-string value)))))
+ (define-sse-shuffle-arg-type sse-shuffle-pattern-2-2 "#b~2,'0B")
+ (define-sse-shuffle-arg-type sse-shuffle-pattern-8-4 "#4r~4,4,'0R"))
+
;;; Set assembler parameters. (In CMU CL, this was done with
;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
(eval-when (:compile-toplevel :load-toplevel :execute)
(eval-when (:compile-toplevel :execute)
(defun swap-if (direction field1 separator field2)
`(:if (,direction :constant 0)
- (,field1 ,separator ,field2)
- (,field2 ,separator ,field1))))
+ (,field1 ,separator ,field2)
+ (,field2 ,separator ,field1))))
(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
(op :field (byte 8 0))
(accum :type 'accum)
(imm))
+(sb!disassem:define-instruction-format (two-bytes 16
+ :default-printer '(:name))
+ (op :fields (list (byte 8 0) (byte 8 8))))
+
+(sb!disassem:define-instruction-format (three-bytes 24
+ :default-printer '(:name))
+ (op :fields (list (byte 8 0) (byte 8 8) (byte 8 16))))
+
+;;; Prefix instructions
+
+(sb!disassem:define-instruction-format (rex 8)
+ (rex :field (byte 4 4) :value #b0100)
+ (wrxb :field (byte 4 0) :type 'wrxb))
+
+(sb!disassem:define-instruction-format (x66 8)
+ (x66 :field (byte 8 0) :type 'x66 :value #x66))
+
+;;; A one-byte instruction with a #x66 prefix, used to indicate an
+;;; operand size of :word.
+(sb!disassem:define-instruction-format (x66-byte 16
+ :default-printer '(:name))
+ (x66 :field (byte 8 0) :value #x66)
+ (op :field (byte 8 8)))
+
+;;; A one-byte instruction with a REX prefix, used to indicate an
+;;; operand size of :qword. REX.W must be 1, the other three bits are
+;;; ignored.
+(sb!disassem:define-instruction-format (rex-byte 16
+ :default-printer '(:name))
+ (rex :field (byte 5 3) :value #b01001)
+ (op :field (byte 8 8)))
+
(sb!disassem:define-instruction-format (simple 8)
(op :field (byte 7 1))
(width :field (byte 1 0) :type 'width)
(accum :type 'accum)
(imm))
-(sb!disassem:define-instruction-format (rex-simple 16)
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (op :field (byte 7 9))
- (width :field (byte 1 8) :type 'width)
- ;; optional fields
- (accum :type 'accum)
- (imm))
-
;;; Same as simple, but with direction bit
(sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
(op :field (byte 6 2))
;;; Same as simple, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (accum-imm 8
- :include 'simple
- :default-printer '(:name
- :tab accum ", " imm))
- (imm :type 'signed-imm-data))
-
-(sb!disassem:define-instruction-format (rex-accum-imm 16
- :include 'rex-simple
- :default-printer '(:name
- :tab accum ", " imm))
+ :include 'simple
+ :default-printer '(:name
+ :tab accum ", " imm))
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format (reg-no-width 8
- :default-printer '(:name :tab reg))
- (op :field (byte 5 3))
+ :default-printer '(:name :tab reg))
+ (op :field (byte 5 3))
(reg :field (byte 3 0) :type 'reg-b)
;; optional fields
(accum :type 'accum)
(imm))
-(sb!disassem:define-instruction-format (rex-reg-no-width 16
- :default-printer '(:name :tab reg))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (op :field (byte 5 11))
- (reg :field (byte 3 8) :type 'reg-b)
- ;; optional fields
- (accum :type 'accum)
- (imm))
-
;;; Same as reg-no-width, but with a default operand size of :qword.
(sb!disassem:define-instruction-format (reg-no-width-default-qword 8
- :include 'reg-no-width
+ :include 'reg-no-width
:default-printer '(:name :tab reg))
(reg :type 'reg-b-default-qword))
-;;; Same as rex-reg-no-width, but with a default operand size of :qword.
-(sb!disassem:define-instruction-format (rex-reg-no-width-default-qword 16
- :include 'rex-reg-no-width
- :default-printer '(:name :tab reg))
- (reg :type 'reg-b-default-qword))
-
-(sb!disassem:define-instruction-format (modrm-reg-no-width 24
- :default-printer '(:name :tab reg))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (ff :field (byte 8 8) :value #b11111111)
- (mod :field (byte 2 22))
- (modrm-reg :field (byte 3 19))
- (reg :field (byte 3 16) :type 'reg-b)
- ;; optional fields
- (accum :type 'accum)
- (imm))
-
;;; Adds a width field to reg-no-width. Note that we can't use
;;; :INCLUDE 'REG-NO-WIDTH here to save typing because that would put
;;; the WIDTH field last, but the prefilter for WIDTH must run before
;;; the one for IMM to be able to determine the correct size of IMM.
(sb!disassem:define-instruction-format (reg 8
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(op :field (byte 4 4))
(width :field (byte 1 3) :type 'width)
(reg :field (byte 3 0) :type 'reg-b)
(imm))
(sb!disassem:define-instruction-format (rex-reg 16
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
(width :field (byte 1 11) :type 'width)
(imm))
(sb!disassem:define-instruction-format (two-bytes 16
- :default-printer '(:name))
+ :default-printer '(:name))
(op :fields (list (byte 8 0) (byte 8 8))))
(sb!disassem:define-instruction-format (reg-reg/mem 16
- :default-printer
- `(:name :tab reg ", " reg/mem))
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
(op :field (byte 7 1))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'reg/mem)
- (reg :field (byte 3 11) :type 'reg)
- ;; optional fields
- (imm))
-
-(sb!disassem:define-instruction-format (rex-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (width :field (byte 1 8) :type 'width)
- (op :field (byte 7 9))
- (reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 11) :type 'reg)
;; optional fields
(imm))
;;; same as reg-reg/mem, but with direction bit
(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
- :include 'reg-reg/mem
- :default-printer
- `(:name
- :tab
- ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ :include 'reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
(op :field (byte 6 2))
(dir :field (byte 1 1)))
-(sb!disassem:define-instruction-format (rex-reg-reg/mem-dir 24
- :include 'rex-reg-reg/mem
- :default-printer
- `(:name
- :tab
- ,(swap-if 'dir 'reg/mem ", " 'reg)))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (op :field (byte 6 10))
- (dir :field (byte 1 9)))
-
;;; Same as reg-reg/mem, but uses the reg field as a second op code.
(sb!disassem:define-instruction-format (reg/mem 16
- :default-printer '(:name :tab reg/mem))
+ :default-printer '(:name :tab reg/mem))
(op :fields (list (byte 7 1) (byte 3 11)))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'sized-reg/mem)
- ;; optional fields
- (imm))
-
-(sb!disassem:define-instruction-format (rex-reg/mem 24
- :default-printer '(:name :tab reg/mem))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (op :fields (list (byte 7 9) (byte 3 19)))
- (width :field (byte 1 8) :type 'width)
- (reg/mem :fields (list (byte 2 22) (byte 3 16))
:type 'sized-reg/mem)
;; optional fields
(imm))
:default-printer '(:name :tab reg/mem))
(op :fields (list (byte 8 0) (byte 3 11)))
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'sized-reg/mem-default-qword))
-
-(sb!disassem:define-instruction-format (rex-reg/mem-default-qword 24
- :default-printer '(:name :tab reg/mem))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (op :fields (list (byte 8 8) (byte 3 19)))
- (reg/mem :fields (list (byte 2 22) (byte 3 16))
:type 'sized-reg/mem-default-qword))
;;; Same as reg/mem, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (reg/mem-imm 16
- :include 'reg/mem
- :default-printer
- '(:name :tab reg/mem ", " imm))
- (reg/mem :type 'sized-reg/mem)
- (imm :type 'signed-imm-data))
-
-(sb!disassem:define-instruction-format (rex-reg/mem-imm 24
- :include 'rex-reg/mem
- :default-printer
- '(:name :tab reg/mem ", " imm))
+ :include 'reg/mem
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
(reg/mem :type 'sized-reg/mem)
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format
(accum-reg/mem 16
:include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
- (reg/mem :type 'reg/mem) ; don't need a size
+ (reg/mem :type 'reg/mem) ; don't need a size
(accum :type 'accum))
;;; Same as reg-reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 7 9))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (ext-reg-reg/mem-no-width 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 8 8))
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg))
-
-(sb!disassem:define-instruction-format (rex-ext-reg-reg/mem-no-width 32
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (prefix :field (byte 8 8) :value #b00001111)
- (op :field (byte 8 16))
- (reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'reg/mem)
- (reg :field (byte 3 27) :type 'reg))
-
-;;; Same as reg-reg/mem, but with a prefix of #xf2 0f
-(sb!disassem:define-instruction-format (xmm-ext-reg-reg/mem 32
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #xf2)
- (prefix2 :field (byte 8 8) :value #x0f)
- (op :field (byte 7 17))
- (width :field (byte 1 16) :type 'width)
- (reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'reg/mem)
- (reg :field (byte 3 27) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
+(sb!disassem:define-instruction-format (ext-reg/mem-no-width 24
+ :default-printer
+ `(:name :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :fields (list (byte 8 8) (byte 3 19)))
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'reg/mem))
+
;;; reg-no-width with #x0f prefix
(sb!disassem:define-instruction-format (ext-reg-no-width 16
- :default-printer '(:name :tab reg))
- (prefix :field (byte 8 0) :value #b00001111)
- (op :field (byte 5 11))
+ :default-printer '(:name :tab reg))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :field (byte 5 11))
(reg :field (byte 3 8) :type 'reg-b))
;;; Same as reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg/mem 24
- :default-printer '(:name :tab reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer '(:name :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :fields (list (byte 7 9) (byte 3 19)))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'sized-reg/mem)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (ext-reg/mem-imm 24
:include 'ext-reg/mem
- :default-printer
+ :default-printer
'(:name :tab reg/mem ", " imm))
(imm :type 'signed-imm-data))
+
+(sb!disassem:define-instruction-format (ext-reg/mem-no-width+imm8 24
+ :include 'ext-reg/mem-no-width
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
+ (imm :type 'imm-byte))
\f
-;;;; This section was added by jrd, for fp instructions.
-
-;;; regular fp inst to/from registers/memory
-(sb!disassem:define-instruction-format (floating-point 16
- :default-printer
- `(:name :tab reg/mem))
- (prefix :field (byte 5 3) :value #b11011)
- (op :fields (list (byte 3 0) (byte 3 11)))
- (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
-
-;;; fp insn to/from fp reg
-(sb!disassem:define-instruction-format (floating-point-fp 16
- :default-printer `(:name :tab fp-reg))
- (prefix :field (byte 5 3) :value #b11011)
- (suffix :field (byte 2 14) :value #b11)
- (op :fields (list (byte 3 0) (byte 3 11)))
- (fp-reg :field (byte 3 8) :type 'fp-reg))
-
-;;; fp insn to/from fp reg, with the reversed source/destination flag.
-(sb!disassem:define-instruction-format
- (floating-point-fp-d 16
- :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
- (prefix :field (byte 5 3) :value #b11011)
- (suffix :field (byte 2 14) :value #b11)
- (op :fields (list (byte 2 0) (byte 3 11)))
- (d :field (byte 1 2))
- (fp-reg :field (byte 3 8) :type 'fp-reg))
-
-
-;;; (added by (?) pfw)
-;;; fp no operand isns
-(sb!disassem:define-instruction-format (floating-point-no 16
- :default-printer '(:name))
- (prefix :field (byte 8 0) :value #b11011001)
- (suffix :field (byte 3 13) :value #b111)
- (op :field (byte 5 8)))
-
-(sb!disassem:define-instruction-format (floating-point-3 16
- :default-printer '(:name))
- (prefix :field (byte 5 3) :value #b11011)
- (suffix :field (byte 2 14) :value #b11)
- (op :fields (list (byte 3 0) (byte 6 8))))
-
-(sb!disassem:define-instruction-format (floating-point-5 16
- :default-printer '(:name))
- (prefix :field (byte 8 0) :value #b11011011)
- (suffix :field (byte 3 13) :value #b111)
- (op :field (byte 5 8)))
-
-(sb!disassem:define-instruction-format (floating-point-st 16
- :default-printer '(:name))
- (prefix :field (byte 8 0) :value #b11011111)
- (suffix :field (byte 3 13) :value #b111)
- (op :field (byte 5 8)))
+;;;; XMM instructions
+
+;;; All XMM instructions use an extended opcode (#x0F as the first
+;;; opcode byte). Therefore in the following "EXT" in the name of the
+;;; instruction formats refers to the formats that have an additional
+;;; prefix (#x66, #xF2 or #xF3).
+
+;;; Instructions having an XMM register as the destination operand
+;;; and an XMM register or a memory location as the source operand.
+;;; The size of the operands is implicitly given by the instruction.
+(sb!disassem:define-instruction-format (xmm-xmm/mem 24
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (x0f :field (byte 8 0) :value #x0f)
+ (op :field (byte 8 8))
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 19) :type 'xmmreg)
+ ;; optional fields
+ (imm))
-(sb!disassem:define-instruction-format (string-op 8
- :include 'simple
- :default-printer '(:name width)))
+(sb!disassem:define-instruction-format (ext-xmm-xmm/mem 32
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 27) :type 'xmmreg)
+ (imm))
-(sb!disassem:define-instruction-format (rex-string-op 16
- :include 'rex-simple
- :default-printer '(:name width)))
+(sb!disassem:define-instruction-format (ext-rex-xmm-xmm/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-2byte-xmm-xmm/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op1 :field (byte 8 16)) ; #x38 or #x3a
+ (op2 :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg))
+
+(sb!disassem:define-instruction-format (ext-rex-2byte-xmm-xmm/mem 48
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op1 :field (byte 8 24)) ; #x38 or #x3a
+ (op2 :field (byte 8 32))
+ (reg/mem :fields (list (byte 2 46) (byte 3 40))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 43) :type 'xmmreg))
+
+;;; Same as xmm-xmm/mem etc., but with direction bit.
+
+(sb!disassem:define-instruction-format (ext-xmm-xmm/mem-dir 32
+ :include 'ext-xmm-xmm/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg ", " 'reg/mem)))
+ (op :field (byte 7 17))
+ (dir :field (byte 1 16)))
+
+(sb!disassem:define-instruction-format (ext-rex-xmm-xmm/mem-dir 40
+ :include 'ext-rex-xmm-xmm/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg ", " 'reg/mem)))
+ (op :field (byte 7 25))
+ (dir :field (byte 1 24)))
+
+;;; Instructions having an XMM register as one operand
+;;; and a constant (unsigned) byte as the other.
+
+(sb!disassem:define-instruction-format (ext-xmm-imm 32
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (/i :field (byte 3 27))
+ (b11 :field (byte 2 30) :value #b11)
+ (reg/mem :field (byte 3 24)
+ :type 'xmmreg-b)
+ (imm :type 'imm-byte))
+
+(sb!disassem:define-instruction-format (ext-rex-xmm-imm 40
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (/i :field (byte 3 35))
+ (b11 :field (byte 2 38) :value #b11)
+ (reg/mem :field (byte 3 32)
+ :type 'xmmreg-b)
+ (imm :type 'imm-byte))
+
+;;; Instructions having an XMM register as one operand and a general-
+;;; -purpose register or a memory location as the other operand.
+
+(sb!disassem:define-instruction-format (xmm-reg/mem 24
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (x0f :field (byte 8 0) :value #x0f)
+ (op :field (byte 8 8))
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 19) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-xmm-reg/mem 32
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 27) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-rex-xmm-reg/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-2byte-xmm-reg/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op1 :field (byte 8 16))
+ (op2 :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32)) :type 'sized-reg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg)
+ (imm))
+
+;;; Instructions having a general-purpose register as one operand and an
+;;; XMM register or a memory location as the other operand.
+
+(sb!disassem:define-instruction-format (reg-xmm/mem 24
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (x0f :field (byte 8 0) :value #x0f)
+ (op :field (byte 8 8))
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 19) :type 'reg))
+
+(sb!disassem:define-instruction-format (ext-reg-xmm/mem 32
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 27) :type 'reg))
+
+(sb!disassem:define-instruction-format (ext-rex-reg-xmm/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'xmmreg/mem)
+ (reg :field (byte 3 35) :type 'reg))
+
+;;; Instructions having a general-purpose register or a memory location
+;;; as one operand and an a XMM register as the other operand.
+
+(sb!disassem:define-instruction-format (ext-reg/mem-xmm 32
+ :default-printer
+ '(:name :tab reg/mem ", " reg))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24))
+ :type 'reg/mem)
+ (reg :field (byte 3 27) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-rex-reg/mem-xmm 40
+ :default-printer
+ '(:name :tab reg/mem ", " reg))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'reg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-2byte-reg/mem-xmm 40
+ :default-printer
+ '(:name :tab reg/mem ", " reg))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op1 :field (byte 8 16))
+ (op2 :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32)) :type 'reg/mem)
+ (reg :field (byte 3 35) :type 'xmmreg)
+ (imm))
+
+(sb!disassem:define-instruction-format (ext-rex-2byte-reg/mem-xmm 48
+ :default-printer
+ '(:name :tab reg/mem ", " reg))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op1 :field (byte 8 24))
+ (op2 :field (byte 8 32))
+ (reg/mem :fields (list (byte 2 46) (byte 3 40)) :type 'reg/mem)
+ (reg :field (byte 3 43) :type 'xmmreg)
+ (imm))
+
+;;; Instructions having a general-purpose register as one operand and an a
+;;; general-purpose register or a memory location as the other operand,
+;;; and using a prefix byte.
+
+(sb!disassem:define-instruction-format (ext-prefix-reg-reg/mem 32
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op :field (byte 8 16))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 27) :type 'reg))
+
+(sb!disassem:define-instruction-format (ext-rex-prefix-reg-reg/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 35) :type 'reg))
+
+(sb!disassem:define-instruction-format (ext-2byte-prefix-reg-reg/mem 40
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (x0f :field (byte 8 8) :value #x0f)
+ (op1 :field (byte 8 16)) ; #x38 or #x3a
+ (op2 :field (byte 8 24))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 35) :type 'reg))
+
+(sb!disassem:define-instruction-format (ext-rex-2byte-prefix-reg-reg/mem 48
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0))
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (x0f :field (byte 8 16) :value #x0f)
+ (op1 :field (byte 8 24)) ; #x38 or #x3a
+ (op2 :field (byte 8 32))
+ (reg/mem :fields (list (byte 2 46) (byte 3 40))
+ :type 'sized-reg/mem)
+ (reg :field (byte 3 43) :type 'reg))
+
+;; XMM comparison instruction
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *sse-conditions* #(:eq :lt :le :unord :neq :nlt :nle :ord)))
+
+(sb!disassem:define-arg-type sse-condition-code
+ ;; Inherit the prefilter from IMM-BYTE to READ-SUFFIX the byte.
+ :type 'imm-byte
+ :printer *sse-conditions*)
+
+(sb!disassem:define-instruction-format (string-op 8
+ :include 'simple
+ :default-printer '(:name width)))
(sb!disassem:define-instruction-format (short-cond-jump 16)
(op :field (byte 4 4))
- (cc :field (byte 4 0) :type 'condition-code)
+ (cc :field (byte 4 0) :type 'condition-code)
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (short-jump 16
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(const :field (byte 4 4) :value #b1110)
- (op :field (byte 4 0))
+ (op :field (byte 4 0))
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (near-cond-jump 16)
(op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the offset.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (near-jump 8
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(op :field (byte 8 0))
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the address.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (cond-set 24
- :default-printer '('set cc :tab reg/mem))
+ :default-printer '('set cc :tab reg/mem))
(prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 4 12) :value #b1001)
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'sized-byte-reg/mem)
- (reg :field (byte 3 19) :value #b000))
+ :type 'sized-byte-reg/mem)
+ (reg :field (byte 3 19) :value #b000))
(sb!disassem:define-instruction-format (cond-move 24
:default-printer
(reg :field (byte 3 19) :type 'reg))
(sb!disassem:define-instruction-format (enter-format 32
- :default-printer '(:name
- :tab disp
- (:unless (:constant 0)
- ", " level)))
+ :default-printer '(:name
+ :tab disp
+ (:unless (:constant 0)
+ ", " level)))
(op :field (byte 8 0))
(disp :field (byte 16 8))
(level :field (byte 8 24)))
;;; Single byte instruction with an immediate byte argument.
(sb!disassem:define-instruction-format (byte-imm 16
- :default-printer '(:name :tab code))
+ :default-printer '(:name :tab code))
(op :field (byte 8 0))
(code :field (byte 8 8)))
+
+;;; Two byte instruction with an immediate byte argument.
+;;;
+(sb!disassem:define-instruction-format (word-imm 24
+ :default-printer '(:name :tab code))
+ (op :field (byte 16 0))
+ (code :field (byte 8 16)))
+
+;;; F3 escape map - Needs a ton more work.
+
+(sb!disassem:define-instruction-format (F3-escape 24)
+ (prefix1 :field (byte 8 0) :value #xF3)
+ (prefix2 :field (byte 8 8) :value #x0F)
+ (op :field (byte 8 16)))
+
+(sb!disassem:define-instruction-format (rex-F3-escape 32)
+ ;; F3 is a legacy prefix which was generalized to select an alternate opcode
+ ;; map. Legacy prefixes are encoded in the instruction before a REX prefix.
+ (prefix1 :field (byte 8 0) :value #xF3)
+ (rex :field (byte 4 12) :value 4) ; "prefix2"
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (prefix3 :field (byte 8 16) :value #x0F)
+ (op :field (byte 8 24)))
+
+(sb!disassem:define-instruction-format (F3-escape-reg-reg/mem 32
+ :include 'F3-escape
+ :default-printer
+ '(:name :tab reg "," reg/mem))
+ (reg/mem :fields (list (byte 2 30) (byte 3 24)) :type 'sized-reg/mem)
+ (reg :field (byte 3 27) :type 'reg))
+
+(sb!disassem:define-instruction-format (rex-F3-escape-reg-reg/mem 40
+ :include 'rex-F3-escape
+ :default-printer
+ '(:name :tab reg "," reg/mem))
+ (reg/mem :fields (list (byte 2 38) (byte 3 32)) :type 'sized-reg/mem)
+ (reg :field (byte 3 35) :type 'reg))
+
\f
;;;; primitive emitters
(define-bitfield-emitter emit-dword 32
(byte 32 0))
+;;; Most uses of dwords are as displacements or as immediate values in
+;;; 64-bit operations. In these cases they are sign-extended to 64 bits.
+;;; EMIT-DWORD is unsuitable there because it accepts values of type
+;;; (OR (SIGNED-BYTE 32) (UNSIGNED-BYTE 32)), so we provide a more
+;;; restricted emitter here.
+(defun emit-signed-dword (segment value)
+ (declare (type segment segment)
+ (type (signed-byte 32) value))
+ (declare (inline emit-dword))
+ (emit-dword segment value))
+
(define-bitfield-emitter emit-qword 64
(byte 64 0))
(note-fixup segment (if quad-p :absolute64 :absolute) fixup)
(let ((offset (fixup-offset fixup)))
(if (label-p offset)
- (emit-back-patch segment
- (if quad-p 8 4)
- (lambda (segment posn)
- (declare (ignore posn))
- (let ((val (- (+ (component-header-length)
- (or (label-position offset)
- 0))
- other-pointer-lowtag)))
- (if quad-p
- (emit-qword segment val )
- (emit-dword segment val )))))
- (if quad-p
- (emit-qword segment (or offset 0))
- (emit-dword segment (or offset 0))))))
+ (emit-back-patch segment
+ (if quad-p 8 4)
+ (lambda (segment posn)
+ (declare (ignore posn))
+ (let ((val (- (+ (component-header-length)
+ (or (label-position offset)
+ 0))
+ other-pointer-lowtag)))
+ (if quad-p
+ (emit-qword segment val)
+ (emit-signed-dword segment val)))))
+ (if quad-p
+ (emit-qword segment (or offset 0))
+ (emit-signed-dword segment (or offset 0))))))
(defun emit-relative-fixup (segment fixup)
(note-fixup segment :relative fixup)
- (emit-dword segment (or (fixup-offset fixup) 0)))
+ (emit-signed-dword segment (or (fixup-offset fixup) 0)))
\f
;;;; the effective-address (ea) structure
(defun reg-tn-encoding (tn)
(declare (type tn tn))
- (aver (member (sb-name (sc-sb (tn-sc tn))) '(registers float-registers)))
;; ea only has space for three bits of register number: regs r8
;; and up are selected by a REX prefix byte which caller is responsible
;; for having emitted where necessary already
- (cond ((fp-reg-tn-p tn)
- (mod (tn-offset tn) 8))
- (t
- (let ((offset (mod (tn-offset tn) 16)))
- (logior (ash (logand offset 1) 2)
- (ash offset -1))))))
-
+ (ecase (sb-name (sc-sb (tn-sc tn)))
+ (registers
+ (let ((offset (mod (tn-offset tn) 16)))
+ (logior (ash (logand offset 1) 2)
+ (ash offset -1))))
+ (float-registers
+ (mod (tn-offset tn) 8))))
+
(defstruct (ea (:constructor make-ea (size &key base index scale disp))
- (:copier nil))
- ;; note that we can represent an EA qith a QWORD size, but EMIT-EA
+ (:copier nil))
+ ;; note that we can represent an EA with a QWORD size, but EMIT-EA
;; can't actually emit it on its own: caller also needs to emit REX
;; prefix
(size nil :type (member :byte :word :dword :qword))
(disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
(def!method print-object ((ea ea) stream)
(cond ((or *print-escape* *print-readably*)
- (print-unreadable-object (ea stream :type t)
- (format stream
- "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
- (ea-size ea)
- (ea-base ea)
- (ea-index ea)
- (let ((scale (ea-scale ea)))
- (if (= scale 1) nil scale))
- (ea-disp ea))))
- (t
- (format stream "~A PTR [" (symbol-name (ea-size ea)))
- (when (ea-base ea)
- (write-string (sb!c::location-print-name (ea-base ea)) stream)
- (when (ea-index ea)
- (write-string "+" stream)))
- (when (ea-index ea)
- (write-string (sb!c::location-print-name (ea-index ea)) stream))
- (unless (= (ea-scale ea) 1)
- (format stream "*~A" (ea-scale ea)))
- (typecase (ea-disp ea)
- (null)
- (integer
- (format stream "~@D" (ea-disp ea)))
- (t
- (format stream "+~A" (ea-disp ea))))
- (write-char #\] stream))))
-
-(defun emit-constant-tn-rip (segment constant-tn reg)
+ (print-unreadable-object (ea stream :type t)
+ (format stream
+ "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+ (ea-size ea)
+ (ea-base ea)
+ (ea-index ea)
+ (let ((scale (ea-scale ea)))
+ (if (= scale 1) nil scale))
+ (ea-disp ea))))
+ (t
+ (format stream "~A PTR [" (symbol-name (ea-size ea)))
+ (when (ea-base ea)
+ (write-string (sb!c::location-print-name (ea-base ea)) stream)
+ (when (ea-index ea)
+ (write-string "+" stream)))
+ (when (ea-index ea)
+ (write-string (sb!c::location-print-name (ea-index ea)) stream))
+ (unless (= (ea-scale ea) 1)
+ (format stream "*~A" (ea-scale ea)))
+ (typecase (ea-disp ea)
+ (null)
+ (integer
+ (format stream "~@D" (ea-disp ea)))
+ (t
+ (format stream "+~A" (ea-disp ea))))
+ (write-char #\] stream))))
+
+(defun emit-constant-tn-rip (segment constant-tn reg remaining-bytes)
;; AMD64 doesn't currently have a code object register to use as a
;; base register for constant access. Instead we use RIP-relative
;; addressing. The offset from the SIMPLE-FUN-HEADER to the instruction
;; that stores the constant. Since we don't know where the code header
;; starts, instead count backwards from the function header.
(let* ((2comp (component-info *component-being-compiled*))
- (constants (ir2-component-constants 2comp))
- (len (length constants))
- ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
- ;; If there are an even amount of constants, there will be
- ;; an extra qword of padding before the function header, which
- ;; needs to be adjusted for. XXX: This will break if new slots
- ;; are added to the code header.
- (offset (* (- (+ len (if (evenp len)
- 1
- 2))
- (tn-offset constant-tn))
- n-word-bytes)))
+ (constants (ir2-component-constants 2comp))
+ (len (length constants))
+ ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
+ ;; If there are an even amount of constants, there will be
+ ;; an extra qword of padding before the function header, which
+ ;; needs to be adjusted for. XXX: This will break if new slots
+ ;; are added to the code header.
+ (offset (* (- (+ len (if (evenp len)
+ 1
+ 2))
+ (tn-offset constant-tn))
+ n-word-bytes)))
;; RIP-relative addressing
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- ;; The addressing is relative to end of instruction,
- ;; i.e. the end of this dword. Hence the + 4.
- (emit-dword segment (+ 4 (- (+ offset posn)))))))
+ 4
+ (lambda (segment posn)
+ ;; The addressing is relative to end of instruction,
+ ;; i.e. the end of this dword. Hence the + 4.
+ (emit-signed-dword segment
+ (+ 4 remaining-bytes
+ (- (+ offset posn)))))))
(values))
-(defun emit-label-rip (segment fixup reg)
+(defun emit-label-rip (segment fixup reg remaining-bytes)
(let ((label (fixup-offset fixup)))
;; RIP-relative addressing
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment (- (label-position label)
- (+ posn 4))))))
+ 4
+ (lambda (segment posn)
+ (emit-signed-dword segment
+ (- (label-position label)
+ (+ posn 4 remaining-bytes))))))
(values))
-(defun emit-ea (segment thing reg &optional allow-constants)
+(defun emit-ea (segment thing reg &key allow-constants (remaining-bytes 0))
(etypecase thing
(tn
;; this would be eleganter if we had a function that would create
;; an ea given a tn
(ecase (sb-name (sc-sb (tn-sc thing)))
((registers float-registers)
- (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+ (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
(stack
- ;; Convert stack tns into an index off RBP.
- (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
- (cond ((< -128 disp 127)
- (emit-mod-reg-r/m-byte segment #b01 reg #b101)
- (emit-byte segment disp))
- (t
- (emit-mod-reg-r/m-byte segment #b10 reg #b101)
- (emit-dword segment disp)))))
+ ;; Convert stack tns into an index off RBP.
+ (let ((disp (frame-byte-offset (tn-offset thing))))
+ (cond ((<= -128 disp 127)
+ (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+ (emit-byte segment disp))
+ (t
+ (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+ (emit-signed-dword segment disp)))))
(constant
- (unless allow-constants
- ;; Why?
- (error
- "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
- (emit-constant-tn-rip segment thing reg))))
+ (unless allow-constants
+ ;; Why?
+ (error
+ "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+ (emit-constant-tn-rip segment thing reg remaining-bytes))))
(ea
(let* ((base (ea-base thing))
- (index (ea-index thing))
- (scale (ea-scale thing))
- (disp (ea-disp thing))
- (mod (cond ((or (null base)
- (and (eql disp 0)
- (not (= (reg-tn-encoding base) #b101))))
- #b00)
- ((and (fixnump disp) (<= -128 disp 127))
- #b01)
- (t
- #b10)))
- (r/m (cond (index #b100)
- ((null base) #b101)
- (t (reg-tn-encoding base)))))
+ (index (ea-index thing))
+ (scale (ea-scale thing))
+ (disp (ea-disp thing))
+ (mod (cond ((or (null base)
+ (and (eql disp 0)
+ (not (= (reg-tn-encoding base) #b101))))
+ #b00)
+ ((and (fixnump disp) (<= -128 disp 127))
+ #b01)
+ (t
+ #b10)))
+ (r/m (cond (index #b100)
+ ((null base) #b101)
+ (t (reg-tn-encoding base)))))
+ (when (and (fixup-p disp)
+ (label-p (fixup-offset disp)))
+ (aver (null base))
+ (aver (null index))
+ (return-from emit-ea (emit-ea segment disp reg
+ :allow-constants allow-constants
+ :remaining-bytes remaining-bytes)))
(when (and (= mod 0) (= r/m #b101))
- ;; this is rip-relative in amd64, so we'll use a sib instead
- (setf r/m #b100 scale 1))
+ ;; this is rip-relative in amd64, so we'll use a sib instead
+ (setf r/m #b100 scale 1))
(emit-mod-reg-r/m-byte segment mod reg r/m)
(when (= r/m #b100)
- (let ((ss (1- (integer-length scale)))
- (index (if (null index)
- #b100
- (let ((index (reg-tn-encoding index)))
- (if (= index #b100)
- (error "can't index off of ESP")
- index))))
- (base (if (null base)
- #b101
- (reg-tn-encoding base))))
- (emit-sib-byte segment ss index base)))
+ (let ((ss (1- (integer-length scale)))
+ (index (if (null index)
+ #b100
+ (let ((index (reg-tn-encoding index)))
+ (if (= index #b100)
+ (error "can't index off of ESP")
+ index))))
+ (base (if (null base)
+ #b101
+ (reg-tn-encoding base))))
+ (emit-sib-byte segment ss index base)))
(cond ((= mod #b01)
- (emit-byte segment disp))
- ((or (= mod #b10) (null base))
- (if (fixup-p disp)
- (emit-absolute-fixup segment disp)
- (emit-dword segment disp))))))
+ (emit-byte segment disp))
+ ((or (= mod #b10) (null base))
+ (if (fixup-p disp)
+ (emit-absolute-fixup segment disp)
+ (emit-signed-dword segment disp))))))
(fixup
(typecase (fixup-offset thing)
(label
- (emit-label-rip segment thing reg))
+ (emit-label-rip segment thing reg remaining-bytes))
(t
- (emit-mod-reg-r/m-byte segment #b00 reg #b100)
- (emit-sib-byte segment 0 #b100 #b101)
- (emit-absolute-fixup segment thing))))))
-
-(defun fp-reg-tn-p (thing)
- (and (tn-p thing)
- (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
-
-;;; like the above, but for fp-instructions--jrd
-(defun emit-fp-op (segment thing op)
- (if (fp-reg-tn-p thing)
- (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
- (byte 3 0)
- #b11000000)))
- (emit-ea segment thing op)))
+ (emit-mod-reg-r/m-byte segment #b00 reg #b100)
+ (emit-sib-byte segment 0 #b100 #b101)
+ (emit-absolute-fixup segment thing))))))
(defun byte-reg-p (thing)
(and (tn-p thing)
(and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
(t nil)))
+;;; Return true if THING is a general-purpose register TN.
(defun register-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
(and (register-p thing)
(= (tn-offset thing) 0)))
+;;; Return true if THING is an XMM register TN.
+(defun xmm-register-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
\f
;;;; utilities
(def!constant +operand-size-prefix-byte+ #b01100110)
(defun maybe-emit-operand-size-prefix (segment size)
- (unless (or (eq size :byte)
- (eq size :qword) ; REX prefix handles this
- (eq size +default-operand-size+))
+ (unless (or (eq size :byte)
+ (eq size :qword) ; REX prefix handles this
+ (eq size +default-operand-size+))
(emit-byte segment +operand-size-prefix-byte+)))
+;;; A REX prefix must be emitted if at least one of the following
+;;; conditions is true:
+;; 1. The operand size is :QWORD and the default operand size of the
+;; instruction is not :QWORD.
+;;; 2. The instruction references an extended register.
+;;; 3. The instruction references one of the byte registers SIL, DIL,
+;;; SPL or BPL.
+
+;;; Emit a REX prefix if necessary. OPERAND-SIZE is used to determine
+;;; whether to set REX.W. Callers pass it explicitly as :DO-NOT-SET if
+;;; this should not happen, for example because the instruction's
+;;; default operand size is qword. R, X and B are NIL or TNs specifying
+;;; registers the encodings of which are extended with the REX.R, REX.X
+;;; and REX.B bit, respectively. To determine whether one of the byte
+;;; registers is used that can only be accessed using a REX prefix, we
+;;; need only to test R and B, because X is only used for the index
+;;; register of an effective address and therefore never byte-sized.
+;;; For R we can avoid to calculate the size of the TN because it is
+;;; always OPERAND-SIZE. The size of B must be calculated here because
+;;; B can be address-sized (if it is the base register of an effective
+;;; address), of OPERAND-SIZE (if the instruction operates on two
+;;; registers) or of some different size (in the instructions that
+;;; combine arguments of different sizes: MOVZX, MOVSX, MOVSXD and
+;;; several SSE instructions, e.g. CVTSD2SI). We don't distinguish
+;;; between general-purpose and floating point registers for this cause
+;;; because only general-purpose registers can be byte-sized at all.
(defun maybe-emit-rex-prefix (segment operand-size r x b)
+ (declare (type (member nil :byte :word :dword :qword :do-not-set)
+ operand-size)
+ (type (or null tn) r x b))
(labels ((if-hi (r)
- (if (and r (> (tn-offset r)
- ;; offset of r8 is 16, offset of xmm8 is 8
- (if (fp-reg-tn-p r)
- 7
- 15)))
- 1
- 0)))
+ (if (and r (> (tn-offset r)
+ ;; offset of r8 is 16, offset of xmm8 is 8
+ (if (eq (sb-name (sc-sb (tn-sc r)))
+ 'float-registers)
+ 7
+ 15)))
+ 1
+ 0))
+ (reg-4-7-p (r)
+ ;; Assuming R is a TN describing a general-purpose
+ ;; register, return true if it references register
+ ;; 4 upto 7.
+ (<= 8 (tn-offset r) 15)))
(let ((rex-w (if (eq operand-size :qword) 1 0))
- (rex-r (if-hi r))
- (rex-x (if-hi x))
- (rex-b (if-hi b)))
- (when (or (eq operand-size :byte) ;; REX needed to access SIL/DIL
- (not (zerop (logior rex-w rex-r rex-x rex-b))))
- (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
-
-(defun maybe-emit-rex-for-ea (segment ea reg &key operand-size)
- (let ((ea-p (ea-p ea))) ;emit-ea can also be called with a tn
+ (rex-r (if-hi r))
+ (rex-x (if-hi x))
+ (rex-b (if-hi b)))
+ (when (or (not (zerop (logior rex-w rex-r rex-x rex-b)))
+ (and r
+ (eq operand-size :byte)
+ (reg-4-7-p r))
+ (and b
+ (eq (operand-size b) :byte)
+ (reg-4-7-p b)))
+ (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
+
+;;; Emit a REX prefix if necessary. The operand size is determined from
+;;; THING or can be overwritten by OPERAND-SIZE. This and REG are always
+;;; passed to MAYBE-EMIT-REX-PREFIX. Additionally, if THING is an EA we
+;;; pass its index and base registers, if it is a register TN, we pass
+;;; only itself.
+;;; In contrast to EMIT-EA above, neither stack TNs nor fixups need to
+;;; be treated specially here: If THING is a stack TN, neither it nor
+;;; any of its components are passed to MAYBE-EMIT-REX-PREFIX which
+;;; works correctly because stack references always use RBP as the base
+;;; register and never use an index register so no extended registers
+;;; need to be accessed. Fixups are assembled using an addressing mode
+;;; of displacement-only or RIP-plus-displacement (see EMIT-EA), so may
+;;; not reference an extended register. The displacement-only addressing
+;;; mode requires that REX.X is 0, which is ensured here.
+(defun maybe-emit-rex-for-ea (segment thing reg &key operand-size)
+ (declare (type (or ea tn fixup) thing)
+ (type (or null tn) reg)
+ (type (member nil :byte :word :dword :qword :do-not-set)
+ operand-size))
+ (let ((ea-p (ea-p thing)))
(maybe-emit-rex-prefix segment
- (or operand-size (operand-size ea))
- reg
- (and ea-p (ea-index ea))
- (cond (ea-p (ea-base ea))
- ((and (tn-p ea)
- (member (sb-name (sc-sb (tn-sc ea)))
- '(float-registers registers)))
- ea)
- (t nil)))))
+ (or operand-size (operand-size thing))
+ reg
+ (and ea-p (ea-index thing))
+ (cond (ea-p (ea-base thing))
+ ((and (tn-p thing)
+ (member (sb-name (sc-sb (tn-sc thing)))
+ '(float-registers registers)))
+ thing)
+ (t nil)))))
(defun operand-size (thing)
(typecase thing
;; FIXME: might as well be COND instead of having to use #. readmacro
;; to hack up the code
(case (sc-name (tn-sc thing))
+ #!+sb-simd-pack
+ (#.*oword-sc-names*
+ :oword)
(#.*qword-sc-names*
- :qword)
+ :qword)
(#.*dword-sc-names*
- :dword)
+ :dword)
(#.*word-sc-names*
- :word)
+ :word)
(#.*byte-sc-names*
- :byte)
+ :byte)
;; added by jrd: float-registers is a separate size (?)
+ ;; The only place in the code where we are called with THING
+ ;; being a float-register is in MAYBE-EMIT-REX-PREFIX when it
+ ;; checks whether THING is a byte register. Thus our result in
+ ;; these cases could as well be :dword and :qword. I leave it as
+ ;; :float and :double which is more likely to trigger an aver
+ ;; instead of silently doing the wrong thing in case this
+ ;; situation should change. Lutz Euler, 2005-10-23.
(#.*float-sc-names*
- :float)
+ :float)
(#.*double-sc-names*
- :double)
+ :double)
+ (#.*complex-sc-names*
+ :complex)
(t
- (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+ (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
(ea
(ea-size thing))
(fixup
(defun matching-operand-size (dst src)
(let ((dst-size (operand-size dst))
- (src-size (operand-size src)))
+ (src-size (operand-size src)))
(if dst-size
- (if src-size
- (if (eq dst-size src-size)
- dst-size
- (error "size mismatch: ~S is a ~S and ~S is a ~S."
- dst dst-size src src-size))
- dst-size)
- (if src-size
- src-size
- (error "can't tell the size of either ~S or ~S" dst src)))))
-
-(defun emit-sized-immediate (segment size value &optional quad-p)
+ (if src-size
+ (if (eq dst-size src-size)
+ dst-size
+ (error "size mismatch: ~S is a ~S and ~S is a ~S."
+ dst dst-size src src-size))
+ dst-size)
+ (if src-size
+ src-size
+ (error "can't tell the size of either ~S or ~S" dst src)))))
+
+;;; Except in a very few cases (MOV instructions A1, A3 and B8 - BF)
+;;; we expect dword data bytes even when 64 bit work is being done.
+;;; But A1 and A3 are currently unused and B8 - BF use EMIT-QWORD
+;;; directly, so we emit all quad constants as dwords, additionally
+;;; making sure that they survive the sign-extension to 64 bits
+;;; unchanged.
+(defun emit-sized-immediate (segment size value)
(ecase size
(:byte
(emit-byte segment value))
(:word
(emit-word segment value))
- ((:dword :qword)
- ;; except in a very few cases (MOV instructions A1,A3,B8) we expect
- ;; dword data bytes even when 64 bit work is being done. So, mostly
- ;; we treat quad constants as dwords.
- (if (and quad-p (eq size :qword))
- (emit-qword segment value)
- (emit-dword segment value)))))
+ (:dword
+ (emit-dword segment value))
+ (:qword
+ (emit-signed-dword segment value))))
\f
+;;;; prefixes
+
+(define-instruction rex (segment)
+ (:printer rex () nil :print-name nil)
+ (:emitter
+ (bug "REX prefix used as a standalone instruction")))
+
+(define-instruction x66 (segment)
+ (:printer x66 () nil :print-name nil)
+ (:emitter
+ (bug "#X66 prefix used as a standalone instruction")))
+
+(defun emit-prefix (segment name)
+ (declare (ignorable segment))
+ (ecase name
+ ((nil))
+ (:lock
+ #!+sb-thread
+ (emit-byte segment #xf0))))
+
+(define-instruction lock (segment)
+ (:printer byte ((op #b11110000)) nil)
+ (:emitter
+ (bug "LOCK prefix used as a standalone instruction")))
+
+(define-instruction rep (segment)
+ (:emitter
+ (emit-byte segment #b11110011)))
+
+(define-instruction repe (segment)
+ (:printer byte ((op #b11110011)) nil)
+ (:emitter
+ (emit-byte segment #b11110011)))
+
+(define-instruction repne (segment)
+ (:printer byte ((op #b11110010)) nil)
+ (:emitter
+ (emit-byte segment #b11110010)))
+
;;;; general data transfer
+;;; This is the part of the MOV instruction emitter that does moving
+;;; of an immediate value into a qword register. We go to some length
+;;; to achieve the shortest possible encoding.
+(defun emit-immediate-move-to-qword-register (segment dst src)
+ (declare (type integer src))
+ (cond ((typep src '(unsigned-byte 32))
+ ;; We use the B8 - BF encoding with an operand size of 32 bits
+ ;; here and let the implicit zero-extension fill the upper half
+ ;; of the 64-bit destination register. Instruction size: five
+ ;; or six bytes. (A REX prefix will be emitted only if the
+ ;; destination is an extended register.)
+ (maybe-emit-rex-prefix segment :dword nil nil dst)
+ (emit-byte-with-reg segment #b10111 (reg-tn-encoding dst))
+ (emit-dword segment src))
+ (t
+ (maybe-emit-rex-prefix segment :qword nil nil dst)
+ (cond ((typep src '(signed-byte 32))
+ ;; Use the C7 encoding that takes a 32-bit immediate and
+ ;; sign-extends it to 64 bits. Instruction size: seven
+ ;; bytes.
+ (emit-byte segment #b11000111)
+ (emit-mod-reg-r/m-byte segment #b11 #b000
+ (reg-tn-encoding dst))
+ (emit-signed-dword segment src))
+ ((<= (- (expt 2 64) (expt 2 31))
+ src
+ (1- (expt 2 64)))
+ ;; This triggers on positive integers of 64 bits length
+ ;; with the most significant 33 bits being 1. We use the
+ ;; same encoding as in the previous clause.
+ (emit-byte segment #b11000111)
+ (emit-mod-reg-r/m-byte segment #b11 #b000
+ (reg-tn-encoding dst))
+ (emit-signed-dword segment (- src (expt 2 64))))
+ (t
+ ;; We need a full 64-bit immediate. Instruction size:
+ ;; ten bytes.
+ (emit-byte-with-reg segment #b10111 (reg-tn-encoding dst))
+ (emit-qword segment src))))))
+
(define-instruction mov (segment dst src)
;; immediate to register
(:printer reg ((op #b1011) (imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " imm))
+ '(:name :tab reg ", " imm))
(:printer rex-reg ((op #b1011) (imm nil :type 'signed-imm-data-upto-qword))
- '(:name :tab reg ", " imm))
+ '(:name :tab reg ", " imm))
;; absolute mem to/from accumulator
(:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
- `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+ `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
;; register to/from register/memory
(:printer reg-reg/mem-dir ((op #b100010)))
- (:printer rex-reg-reg/mem-dir ((op #b100010)))
;; immediate to register/memory
(:printer reg/mem-imm ((op '(#b1100011 #b000))))
- (:printer rex-reg/mem-imm ((op '(#b1100011 #b000))))
(:emitter
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
- (cond ((integerp src)
- (maybe-emit-rex-prefix segment size nil nil dst)
- (emit-byte-with-reg segment
- (if (eq size :byte)
- #b10110
- #b10111)
- (reg-tn-encoding dst))
- (emit-sized-immediate segment size src (eq size :qword)))
- (t
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment
- (if (eq size :byte)
- #b10001010
- #b10001011))
- (emit-ea segment src (reg-tn-encoding dst) t))))
- ((integerp src)
- ;; C7 only deals with 32 bit immediates even if register is
- ;; 64 bit: only b8-bf use 64 bit immediates
- (maybe-emit-rex-for-ea segment dst nil)
- (cond ((typep src '(or (signed-byte 32) (unsigned-byte 32)))
- (emit-byte segment
- (if (eq size :byte) #b11000110 #b11000111))
- (emit-ea segment dst #b000)
- (emit-sized-immediate segment
- (case size (:qword :dword) (t size))
- src))
- (t
- (aver nil))))
- ((register-p src)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
- (emit-ea segment dst (reg-tn-encoding src)))
- ((fixup-p src)
- ;; Generally we can't MOV a fixupped value into an EA, since
- ;; MOV on non-registers can only take a 32-bit immediate arg.
- ;; Make an exception for :FOREIGN fixups (pretty much just
- ;; the runtime asm, since other foreign calls go through the
- ;; the linkage table) and for linkage table references, since
- ;; these should always end up in low memory.
- (aver (or (eq (fixup-flavor src) :foreign)
- (eq (fixup-flavor src) :foreign-dataref)
- (eq (ea-size dst) :dword)))
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment #b11000111)
- (emit-ea segment dst #b000)
- (emit-absolute-fixup segment src))
- (t
- (error "bogus arguments to MOV: ~S ~S" dst src))))))
-
+ (cond ((integerp src)
+ (cond ((eq size :qword)
+ (emit-immediate-move-to-qword-register segment
+ dst src))
+ (t
+ (maybe-emit-rex-prefix segment size nil nil dst)
+ (emit-byte-with-reg segment
+ (if (eq size :byte)
+ #b10110
+ #b10111)
+ (reg-tn-encoding dst))
+ (emit-sized-immediate segment size src))))
+ (t
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10001010
+ #b10001011))
+ (emit-ea segment src (reg-tn-encoding dst) :allow-constants t))))
+ ((integerp src)
+ ;; C7 only deals with 32 bit immediates even if the
+ ;; destination is a 64-bit location. The value is
+ ;; sign-extended in this case.
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+ (emit-ea segment dst #b000)
+ (emit-sized-immediate segment size src))
+ ((register-p src)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+ (emit-ea segment dst (reg-tn-encoding src)))
+ ((fixup-p src)
+ ;; Generally we can't MOV a fixupped value into an EA, since
+ ;; MOV on non-registers can only take a 32-bit immediate arg.
+ ;; Make an exception for :FOREIGN fixups (pretty much just
+ ;; the runtime asm, since other foreign calls go through the
+ ;; the linkage table) and for linkage table references, since
+ ;; these should always end up in low memory.
+ (aver (or (eq (fixup-flavor src) :foreign)
+ (eq (fixup-flavor src) :foreign-dataref)
+ (eq (ea-size dst) :dword)))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment #b11000111)
+ (emit-ea segment dst #b000)
+ (emit-absolute-fixup segment src))
+ (t
+ (error "bogus arguments to MOV: ~S ~S" dst src))))))
+
+;;; Emit a sign-extending (if SIGNED-P is true) or zero-extending move.
+;;; To achieve the shortest possible encoding zero extensions into a
+;;; 64-bit destination are assembled as a straight 32-bit MOV (if the
+;;; source size is 32 bits) or as MOVZX with a 32-bit destination (if
+;;; the source size is 8 or 16 bits). Due to the implicit zero extension
+;;; to 64 bits this has the same effect as a MOVZX with 64-bit
+;;; destination but often needs no REX prefix.
(defun emit-move-with-extension (segment dst src signed-p)
(aver (register-p dst))
(let ((dst-size (operand-size dst))
- (src-size (operand-size src))
- (opcode (if signed-p #b10111110 #b10110110)))
- (ecase dst-size
- (:word
- (aver (eq src-size :byte))
- (maybe-emit-operand-size-prefix segment :word)
- (emit-byte segment #b00001111)
- (emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))
- ((:dword :qword)
- (ecase src-size
- (:byte
- (maybe-emit-operand-size-prefix segment :dword)
- (maybe-emit-rex-for-ea segment src dst
- :operand-size (operand-size dst))
- (emit-byte segment #b00001111)
- (emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))
- (:word
- (maybe-emit-rex-for-ea segment src dst
- :operand-size (operand-size dst))
- (emit-byte segment #b00001111)
- (emit-byte segment (logior opcode 1))
- (emit-ea segment src (reg-tn-encoding dst)))
- (:dword
- (aver (eq dst-size :qword))
- ;; dst is in reg, src is in modrm
- (let ((ea-p (ea-p src)))
- (maybe-emit-rex-prefix segment (if signed-p :qword :dword) dst
- (and ea-p (ea-index src))
- (cond (ea-p (ea-base src))
- ((tn-p src) src)
- (t nil)))
- (emit-byte segment #x63) ;movsxd
- ;;(emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))))))))
+ (src-size (operand-size src))
+ (opcode (if signed-p #b10111110 #b10110110)))
+ (macrolet ((emitter (operand-size &rest bytes)
+ `(progn
+ (maybe-emit-rex-for-ea segment src dst
+ :operand-size ,operand-size)
+ ,@(mapcar (lambda (byte)
+ `(emit-byte segment ,byte))
+ bytes)
+ (emit-ea segment src (reg-tn-encoding dst)))))
+ (ecase dst-size
+ (:word
+ (aver (eq src-size :byte))
+ (maybe-emit-operand-size-prefix segment :word)
+ (emitter :word #b00001111 opcode))
+ ((:dword :qword)
+ (unless signed-p
+ (setf dst-size :dword))
+ (ecase src-size
+ (:byte
+ (emitter dst-size #b00001111 opcode))
+ (:word
+ (emitter dst-size #b00001111 (logior opcode 1)))
+ (:dword
+ (aver (or (not signed-p) (eq dst-size :qword)))
+ (emitter dst-size
+ (if signed-p #x63 #x8b))))))))) ; movsxd or straight mov
(define-instruction movsx (segment dst src)
(:printer ext-reg-reg/mem-no-width
((op #b10111110) (reg/mem nil :type 'sized-byte-reg/mem)))
- (:printer rex-ext-reg-reg/mem-no-width
- ((op #b10111110) (reg/mem nil :type 'sized-byte-reg/mem)))
(:printer ext-reg-reg/mem-no-width
((op #b10111111) (reg/mem nil :type 'sized-word-reg/mem)))
- (:printer rex-ext-reg-reg/mem-no-width
- ((op #b10111111) (reg/mem nil :type 'sized-word-reg/mem)))
(:emitter (emit-move-with-extension segment dst src :signed)))
(define-instruction movzx (segment dst src)
(:printer ext-reg-reg/mem-no-width
((op #b10110110) (reg/mem nil :type 'sized-byte-reg/mem)))
- (:printer rex-ext-reg-reg/mem-no-width
- ((op #b10110110) (reg/mem nil :type 'sized-byte-reg/mem)))
(:printer ext-reg-reg/mem-no-width
((op #b10110111) (reg/mem nil :type 'sized-word-reg/mem)))
- (:printer rex-ext-reg-reg/mem-no-width
- ((op #b10110111) (reg/mem nil :type 'sized-word-reg/mem)))
(:emitter (emit-move-with-extension segment dst src nil)))
+;;; The regular use of MOVSXD is with an operand size of :qword. This
+;;; sign-extends the dword source into the qword destination register.
+;;; If the operand size is :dword the instruction zero-extends the dword
+;;; source into the qword destination register, i.e. it does the same as
+;;; a dword MOV into a register.
(define-instruction movsxd (segment dst src)
- (:printer rex-reg-reg/mem ((op #b0110001) (width 1)
- (reg/mem nil :type 'sized-dword-reg/mem)))
+ (:printer reg-reg/mem ((op #b0110001) (width 1)
+ (reg/mem nil :type 'sized-dword-reg/mem)))
(:emitter (emit-move-with-extension segment dst src :signed)))
;;; this is not a real amd64 instruction, of course
(define-instruction push (segment src)
;; register
(:printer reg-no-width-default-qword ((op #b01010)))
- (:printer rex-reg-no-width-default-qword ((op #b01010)))
;; register/memory
(:printer reg/mem-default-qword ((op '(#b11111111 #b110))))
- (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b110))))
;; immediate
(:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
- '(:name :tab imm))
+ '(:name :tab imm))
(:printer byte ((op #b01101000)
(imm nil :type 'signed-imm-data-default-qword))
- '(:name :tab imm))
+ '(:name :tab imm))
;; ### segment registers?
(:emitter
(cond ((integerp src)
- (cond ((<= -128 src 127)
- (emit-byte segment #b01101010)
- (emit-byte segment src))
- (t
- ;; AMD64 manual says no REX needed but is unclear
- ;; whether it expects 32 or 64 bit immediate here
- (emit-byte segment #b01101000)
- (emit-dword segment src))))
- (t
- (let ((size (operand-size src)))
- (aver (not (eq size :byte)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment src nil)
- (cond ((register-p src)
- (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
- (t
- (emit-byte segment #b11111111)
- (emit-ea segment src #b110 t))))))))
-
-(define-instruction pusha (segment)
- (:printer byte ((op #b01100000)))
- (:emitter
- (emit-byte segment #b01100000)))
+ (cond ((<= -128 src 127)
+ (emit-byte segment #b01101010)
+ (emit-byte segment src))
+ (t
+ ;; A REX-prefix is not needed because the operand size
+ ;; defaults to 64 bits. The size of the immediate is 32
+ ;; bits and it is sign-extended.
+ (emit-byte segment #b01101000)
+ (emit-signed-dword segment src))))
+ (t
+ (let ((size (operand-size src)))
+ (aver (or (eq size :qword) (eq size :word)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment src nil :operand-size :do-not-set)
+ (cond ((register-p src)
+ (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #b11111111)
+ (emit-ea segment src #b110 :allow-constants t))))))))
(define-instruction pop (segment dst)
(:printer reg-no-width-default-qword ((op #b01011)))
- (:printer rex-reg-no-width-default-qword ((op #b01011)))
(:printer reg/mem-default-qword ((op '(#b10001111 #b000))))
- (:printer rex-reg/mem-default-qword ((op '(#b10001111 #b000))))
(:emitter
(let ((size (operand-size dst)))
- (aver (not (eq size :byte)))
+ (aver (or (eq size :qword) (eq size :word)))
(maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment dst nil)
+ (maybe-emit-rex-for-ea segment dst nil :operand-size :do-not-set)
(cond ((register-p dst)
- (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
- (t
- (emit-byte segment #b10001111)
- (emit-ea segment dst #b000))))))
-
-(define-instruction popa (segment)
- (:printer byte ((op #b01100001)))
- (:emitter
- (emit-byte segment #b01100001)))
+ (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment #b10001111)
+ (emit-ea segment dst #b000))))))
(define-instruction xchg (segment operand1 operand2)
;; Register with accumulator.
(:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
;; Register/Memory with Register.
(:printer reg-reg/mem ((op #b1000011)))
- (:printer rex-reg-reg/mem ((op #b1000011)))
(:emitter
(let ((size (matching-operand-size operand1 operand2)))
(maybe-emit-operand-size-prefix segment size)
(labels ((xchg-acc-with-something (acc something)
- (if (and (not (eq size :byte)) (register-p something))
- (progn
- (maybe-emit-rex-for-ea segment acc something)
- (emit-byte-with-reg segment
- #b10010
- (reg-tn-encoding something)))
- (xchg-reg-with-something acc something)))
- (xchg-reg-with-something (reg something)
- (maybe-emit-rex-for-ea segment something reg)
- (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (if (and (not (eq size :byte)) (register-p something))
+ (progn
+ (maybe-emit-rex-for-ea segment acc something)
+ (emit-byte-with-reg segment
+ #b10010
+ (reg-tn-encoding something)))
+ (xchg-reg-with-something acc something)))
+ (xchg-reg-with-something (reg something)
+ (maybe-emit-rex-for-ea segment something reg)
+ (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((accumulator-p operand1)
- (xchg-acc-with-something operand1 operand2))
- ((accumulator-p operand2)
- (xchg-acc-with-something operand2 operand1))
- ((register-p operand1)
- (xchg-reg-with-something operand1 operand2))
- ((register-p operand2)
- (xchg-reg-with-something operand2 operand1))
- (t
- (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+ (xchg-acc-with-something operand1 operand2))
+ ((accumulator-p operand2)
+ (xchg-acc-with-something operand2 operand1))
+ ((register-p operand1)
+ (xchg-reg-with-something operand1 operand2))
+ ((register-p operand2)
+ (xchg-reg-with-something operand2 operand1))
+ (t
+ (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
(define-instruction lea (segment dst src)
- (:printer rex-reg-reg/mem ((op #b1000110)))
(:printer reg-reg/mem ((op #b1000110) (width 1)))
(:emitter
(aver (or (dword-reg-p dst) (qword-reg-p dst)))
(maybe-emit-rex-for-ea segment src dst
- :operand-size :qword)
+ :operand-size (if (dword-reg-p dst) :dword :qword))
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
-(define-instruction cmpxchg (segment dst src)
+(define-instruction cmpxchg (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-for-ea segment dst src)
(emit-ea segment dst (reg-tn-encoding src)))))
\f
-
-(define-instruction fs-segment-prefix (segment)
- (:emitter
- (emit-byte segment #x64)))
-
;;;; flag control instructions
;;; CLC -- Clear Carry Flag.
;;;; arithmetic
(defun emit-random-arith-inst (name segment dst src opcode
- &optional allow-constants)
+ &optional allow-constants)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment #b10000011)
- (emit-ea segment dst opcode allow-constants)
- (emit-byte segment src))
- ((accumulator-p dst)
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte)
- #b00000100
- #b00000101)))
- (emit-sized-immediate segment size src))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
- (emit-ea segment dst opcode allow-constants)
- (emit-sized-immediate segment size src))))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment #b10000011)
+ (emit-ea segment dst opcode :allow-constants allow-constants)
+ (emit-byte segment src))
+ ((accumulator-p dst)
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte)
+ #b00000100
+ #b00000101)))
+ (emit-sized-immediate segment size src))
+ (t
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+ (emit-ea segment dst opcode :allow-constants allow-constants)
+ (emit-sized-immediate segment size src))))
((register-p src)
(maybe-emit-rex-for-ea segment dst src)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000000 #b00000001)))
- (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000000 #b00000001)))
+ (emit-ea segment dst (reg-tn-encoding src) :allow-constants allow-constants))
((register-p dst)
(maybe-emit-rex-for-ea segment src dst)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000010 #b00000011)))
- (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000010 #b00000011)))
+ (emit-ea segment src (reg-tn-encoding dst) :allow-constants allow-constants))
(t
(error "bogus operands to ~A" name)))))
(eval-when (:compile-toplevel :execute)
(defun arith-inst-printer-list (subop)
`((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
- (rex-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
(reg/mem-imm ((op (#b1000000 ,subop))))
- (rex-reg/mem-imm ((op (#b1000000 ,subop))))
;; The redundant encoding #x82 is invalid in 64-bit mode,
;; therefore we force WIDTH to 1.
(reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
- (imm nil :type signed-imm-byte)))
- (rex-reg/mem-imm ((op (#b1000001 ,subop))
- (imm nil :type signed-imm-byte)))
- (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
- (rex-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
- )
+ (imm nil :type signed-imm-byte)))
+ (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))))
-(define-instruction add (segment dst src)
+(define-instruction add (segment dst src &optional prefix)
(:printer-list (arith-inst-printer-list #b000))
- (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+ (:emitter
+ (emit-prefix segment prefix)
+ (emit-random-arith-inst "ADD" segment dst src #b000)))
(define-instruction adc (segment dst src)
(:printer-list (arith-inst-printer-list #b010))
(:printer-list (arith-inst-printer-list #b111))
(:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+;;; The one-byte encodings for INC and DEC are used as REX prefixes
+;;; in 64-bit mode so we always use the two-byte form.
(define-instruction inc (segment dst)
- ;; Register
- (:printer modrm-reg-no-width ((modrm-reg #b000)))
- ;; Register/Memory
- ;; (:printer rex-reg/mem ((op '(#b11111111 #b001))))
(:printer reg/mem ((op '(#b1111111 #b000))))
(:emitter
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
- (cond #+nil ; these opcodes become REX prefixes in x86-64
- ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b000))))))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b000))))
(define-instruction dec (segment dst)
- ;; Register.
- (:printer modrm-reg-no-width ((modrm-reg #b001)))
- ;; Register/Memory
(:printer reg/mem ((op '(#b1111111 #b001))))
(:emitter
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
- (cond #+nil
- ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b001))))))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b001))))
(define-instruction neg (segment dst)
(:printer reg/mem ((op '(#b1111011 #b011))))
(define-instruction imul (segment dst &optional src1 src2)
(:printer accum-reg/mem ((op '(#b1111011 #b101))))
(:printer ext-reg-reg/mem-no-width ((op #b10101111)))
- (:printer rex-ext-reg-reg/mem-no-width ((op #b10101111)))
(:printer reg-reg/mem ((op #b0110100) (width 1)
(imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " reg/mem ", " imm))
- (:printer rex-reg-reg/mem ((op #b0110100) (width 1)
- (imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " reg/mem ", " imm))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:printer reg-reg/mem ((op #b0110101) (width 1)
- (imm nil :type 'signed-imm-byte))
- '(:name :tab reg ", " reg/mem ", " imm))
- (:printer rex-reg-reg/mem ((op #b0110101) (width 1)
- (imm nil :type 'signed-imm-byte))
- '(:name :tab reg ", " reg/mem ", " imm))
+ (imm nil :type 'signed-imm-byte))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:emitter
(flet ((r/m-with-immed-to-reg (reg r/m immed)
- (let* ((size (matching-operand-size reg r/m))
- (sx (and (not (eq size :byte)) (<= -128 immed 127))))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment r/m reg)
- (emit-byte segment (if sx #b01101011 #b01101001))
- (emit-ea segment r/m (reg-tn-encoding reg))
- (if sx
- (emit-byte segment immed)
- (emit-sized-immediate segment size immed)))))
+ (let* ((size (matching-operand-size reg r/m))
+ (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment r/m reg)
+ (emit-byte segment (if sx #b01101011 #b01101001))
+ (emit-ea segment r/m (reg-tn-encoding reg))
+ (if sx
+ (emit-byte segment immed)
+ (emit-sized-immediate segment size immed)))))
(cond (src2
- (r/m-with-immed-to-reg dst src1 src2))
- (src1
- (if (integerp src1)
- (r/m-with-immed-to-reg dst dst src1)
- (let ((size (matching-operand-size dst src1)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment src1 dst)
- (emit-byte segment #b00001111)
- (emit-byte segment #b10101111)
- (emit-ea segment src1 (reg-tn-encoding dst)))))
- (t
- (let ((size (operand-size dst)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment dst #b101)))))))
+ (r/m-with-immed-to-reg dst src1 src2))
+ (src1
+ (if (integerp src1)
+ (r/m-with-immed-to-reg dst dst src1)
+ (let ((size (matching-operand-size dst src1)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment src1 dst)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10101111)
+ (emit-ea segment src1 (reg-tn-encoding dst)))))
+ (t
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b101)))))))
(define-instruction div (segment dst src)
(:printer accum-reg/mem ((op '(#b1111011 #b110))))
;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
(define-instruction cbw (segment)
+ (:printer x66-byte ((op #b10011000)))
(:emitter
(maybe-emit-operand-size-prefix segment :word)
(emit-byte segment #b10011000)))
-;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
+;;; CWDE -- Convert Word To Double Word Extended. EAX <- sign_xtnd(AX)
(define-instruction cwde (segment)
+ (:printer byte ((op #b10011000)))
(:emitter
(maybe-emit-operand-size-prefix segment :dword)
(emit-byte segment #b10011000)))
+;;; CDQE -- Convert Double Word To Quad Word Extended. RAX <- sign_xtnd(EAX)
+(define-instruction cdqe (segment)
+ (:printer rex-byte ((op #b10011000)))
+ (:emitter
+ (maybe-emit-rex-prefix segment :qword nil nil nil)
+ (emit-byte segment #b10011000)))
+
;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
(define-instruction cwd (segment)
+ (:printer x66-byte ((op #b10011001)))
(:emitter
(maybe-emit-operand-size-prefix segment :word)
(emit-byte segment #b10011001)))
(maybe-emit-operand-size-prefix segment :dword)
(emit-byte segment #b10011001)))
-;;; CQO -- Convert Quad or Octaword. RDX:RAX <- sign_xtnd(RAX)
+;;; CQO -- Convert Quad Word to Octaword. RDX:RAX <- sign_xtnd(RAX)
(define-instruction cqo (segment)
+ (:printer rex-byte ((op #b10011001)))
(:emitter
(maybe-emit-rex-prefix segment :qword nil nil nil)
(emit-byte segment #b10011001)))
-(define-instruction xadd (segment dst src)
+(define-instruction xadd (segment dst src &optional prefix)
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
(:emitter
(aver (register-p src))
+ (emit-prefix segment prefix)
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-for-ea segment dst src)
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(multiple-value-bind (major-opcode immed)
- (case amount
- (:cl (values #b11010010 nil))
- (1 (values #b11010000 nil))
- (t (values #b11000000 t)))
+ (case amount
+ (:cl (values #b11010010 nil))
+ (1 (values #b11010000 nil))
+ (t (values #b11000000 t)))
(maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment
- (if (eq size :byte) major-opcode (logior major-opcode 1)))
+ (if (eq size :byte) major-opcode (logior major-opcode 1)))
(emit-ea segment dst opcode)
(when immed
- (emit-byte segment amount)))))
+ (emit-byte segment amount)))))
(eval-when (:compile-toplevel :execute)
(defun shift-inst-printer-list (subop)
`((reg/mem ((op (#b1101000 ,subop)))
- (:name :tab reg/mem ", 1"))
- (rex-reg/mem ((op (#b1101000 ,subop)))
- (:name :tab reg/mem ", 1"))
+ (:name :tab reg/mem ", 1"))
(reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
- (rex-reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
+ (:name :tab reg/mem ", " 'cl))
(reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type imm-byte)))
- (rex-reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type imm-byte))))))
+ (imm nil :type imm-byte))))))
(define-instruction rol (segment dst amount)
(:printer-list
(maybe-emit-rex-for-ea segment dst src)
(emit-byte segment #b00001111)
(emit-byte segment (dpb opcode (byte 1 3)
- (if (eq amt :cl) #b10100101 #b10100100)))
- (emit-ea segment dst (reg-tn-encoding src))
+ (if (eq amt :cl) #b10100101 #b10100100)))
+ (emit-ea segment dst (reg-tn-encoding src))
(unless (eq amt :cl)
(emit-byte segment amt))))
(eval-when (:compile-toplevel :execute)
(defun double-shift-inst-printer-list (op)
- `(#+nil
- (ext-reg-reg/mem-imm ((op ,(logior op #b100))
- (imm nil :type signed-imm-byte)))
- (ext-reg-reg/mem ((op ,(logior op #b101)))
- (:name :tab reg/mem ", " 'cl)))))
+ `((ext-reg-reg/mem-no-width ((op ,(logior op #b100))
+ (imm nil :type imm-byte))
+ (:name :tab reg/mem ", " reg ", " imm))
+ (ext-reg-reg/mem-no-width ((op ,(logior op #b101)))
+ (:name :tab reg/mem ", " reg ", " 'cl)))))
(define-instruction shld (segment dst src amt)
- (:declare (type (or (member :cl) (mod 32)) amt))
+ (:declare (type (or (member :cl) (mod 64)) amt))
(:printer-list (double-shift-inst-printer-list #b10100000))
(:emitter
(emit-double-shift segment #b0 dst src amt)))
(define-instruction shrd (segment dst src amt)
- (:declare (type (or (member :cl) (mod 32)) amt))
+ (:declare (type (or (member :cl) (mod 64)) amt))
(:printer-list (double-shift-inst-printer-list #b10101000))
(:emitter
(emit-double-shift segment #b1 dst src amt)))
(define-instruction test (segment this that)
(:printer accum-imm ((op #b1010100)))
- (:printer rex-accum-imm ((op #b1010100)))
(:printer reg/mem-imm ((op '(#b1111011 #b000))))
- (:printer rex-reg/mem-imm ((op '(#b1111011 #b000))))
(:printer reg-reg/mem ((op #b1000010)))
- (:printer rex-reg-reg/mem ((op #b1000010)))
(:emitter
(let ((size (matching-operand-size this that)))
(maybe-emit-operand-size-prefix segment size)
(flet ((test-immed-and-something (immed something)
- (cond ((accumulator-p something)
- (maybe-emit-rex-for-ea segment something nil)
- (emit-byte segment
- (if (eq size :byte) #b10101000 #b10101001))
- (emit-sized-immediate segment size immed))
- (t
- (maybe-emit-rex-for-ea segment something nil)
- (emit-byte segment
- (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment something #b000)
- (emit-sized-immediate segment size immed))))
- (test-reg-and-something (reg something)
- (maybe-emit-rex-for-ea segment something reg)
- (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (cond ((accumulator-p something)
+ (maybe-emit-rex-for-ea segment something nil)
+ (emit-byte segment
+ (if (eq size :byte) #b10101000 #b10101001))
+ (emit-sized-immediate segment size immed))
+ (t
+ (maybe-emit-rex-for-ea segment something nil)
+ (emit-byte segment
+ (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment something #b000)
+ (emit-sized-immediate segment size immed))))
+ (test-reg-and-something (reg something)
+ (maybe-emit-rex-for-ea segment something reg)
+ (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((integerp that)
- (test-immed-and-something that this))
- ((integerp this)
- (test-immed-and-something this that))
- ((register-p this)
- (test-reg-and-something this that))
- ((register-p that)
- (test-reg-and-something that this))
- (t
- (error "bogus operands for TEST: ~S and ~S" this that)))))))
+ (test-immed-and-something that this))
+ ((integerp this)
+ (test-immed-and-something this that))
+ ((register-p this)
+ (test-reg-and-something this that))
+ ((register-p that)
+ (test-reg-and-something that this))
+ (t
+ (error "bogus operands for TEST: ~S and ~S" this that)))))))
+
+;;; Emit the most compact form of the test immediate instruction,
+;;; using an 8 bit test when the immediate is only 8 bits and the
+;;; value is one of the four low registers (rax, rbx, rcx, rdx) or the
+;;; control stack.
+(defun emit-optimized-test-inst (x y)
+ (typecase y
+ ((unsigned-byte 7)
+ (let ((offset (tn-offset x)))
+ (cond ((and (sc-is x any-reg descriptor-reg)
+ (or (= offset rax-offset) (= offset rbx-offset)
+ (= offset rcx-offset) (= offset rdx-offset)))
+ (inst test (reg-in-size x :byte) y))
+ ((sc-is x control-stack)
+ (inst test (make-ea :byte :base rbp-tn
+ :disp (frame-byte-offset offset))
+ y))
+ (t
+ (inst test x y)))))
+ (t
+ (inst test x y))))
(define-instruction or (segment dst src)
(:printer-list
(define-instruction cmps (segment size)
(:printer string-op ((op #b1010011)))
- (:printer rex-string-op ((op #b1010011)))
(:emitter
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-prefix segment size nil nil nil)
(define-instruction ins (segment acc)
(:printer string-op ((op #b0110110)))
- (:printer rex-string-op ((op #b0110110)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(define-instruction lods (segment acc)
(:printer string-op ((op #b1010110)))
- (:printer rex-string-op ((op #b1010110)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(define-instruction movs (segment size)
(:printer string-op ((op #b1010010)))
- (:printer rex-string-op ((op #b1010010)))
(:emitter
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-prefix segment size nil nil nil)
(define-instruction outs (segment acc)
(:printer string-op ((op #b0110111)))
- (:printer rex-string-op ((op #b0110111)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(define-instruction scas (segment acc)
(:printer string-op ((op #b1010111)))
- (:printer rex-string-op ((op #b1010111)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(define-instruction stos (segment acc)
(:printer string-op ((op #b1010101)))
- (:printer rex-string-op ((op #b1010101)))
(:emitter
(let ((size (operand-size acc)))
(aver (accumulator-p acc))
(:emitter
(emit-byte segment #b11010111)))
-(define-instruction rep (segment)
- (:emitter
- (emit-byte segment #b11110010)))
-
-(define-instruction repe (segment)
- (:printer byte ((op #b11110011)))
- (:emitter
- (emit-byte segment #b11110011)))
-
-(define-instruction repne (segment)
- (:printer byte ((op #b11110010)))
- (:emitter
- (emit-byte segment #b11110010)))
-
\f
;;;; bit manipulation
(define-instruction bsf (segment dst src)
- (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
+ (:printer ext-reg-reg/mem-no-width ((op #b10111100)))
(:emitter
(let ((size (matching-operand-size dst src)))
(when (eq size :byte)
(emit-ea segment src (reg-tn-encoding dst)))))
(define-instruction bsr (segment dst src)
- (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
+ (:printer ext-reg-reg/mem-no-width ((op #b10111101)))
(:emitter
(let ((size (matching-operand-size dst src)))
(when (eq size :byte)
(error "can't scan bytes: ~S" src))
(maybe-emit-operand-size-prefix segment size)
(cond ((integerp index)
- (maybe-emit-rex-for-ea segment src nil)
- (emit-byte segment #b00001111)
- (emit-byte segment #b10111010)
- (emit-ea segment src opcode)
- (emit-byte segment index))
- (t
- (maybe-emit-rex-for-ea segment src index)
- (emit-byte segment #b00001111)
- (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
- (emit-ea segment src (reg-tn-encoding index))))))
+ (maybe-emit-rex-for-ea segment src nil)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10111010)
+ (emit-ea segment src opcode)
+ (emit-byte segment index))
+ (t
+ (maybe-emit-rex-for-ea segment src index)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+ (emit-ea segment src (reg-tn-encoding index))))))
(eval-when (:compile-toplevel :execute)
(defun bit-test-inst-printer-list (subop)
- `((ext-reg/mem-imm ((op (#b1011101 ,subop))
- (reg/mem nil :type reg/mem)
- (imm nil :type imm-byte)
- (width 0)))
- (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
- (width 1))
- (:name :tab reg/mem ", " reg)))))
-
-(define-instruction bt (segment src index)
- (:printer-list (bit-test-inst-printer-list #b100))
- (:emitter
- (emit-bit-test-and-mumble segment src index #b100)))
-
-(define-instruction btc (segment src index)
- (:printer-list (bit-test-inst-printer-list #b111))
- (:emitter
- (emit-bit-test-and-mumble segment src index #b111)))
-
-(define-instruction btr (segment src index)
- (:printer-list (bit-test-inst-printer-list #b110))
- (:emitter
- (emit-bit-test-and-mumble segment src index #b110)))
-
-(define-instruction bts (segment src index)
- (:printer-list (bit-test-inst-printer-list #b101))
- (:emitter
- (emit-bit-test-and-mumble segment src index #b101)))
+ `((ext-reg/mem-no-width+imm8 ((op (#xBA ,subop))))
+ (ext-reg-reg/mem-no-width ((op ,(dpb subop (byte 3 3) #b10000011))
+ (reg/mem nil :type sized-reg/mem))
+ (:name :tab reg/mem ", " reg)))))
+
+(macrolet ((define (inst opcode-extension)
+ `(define-instruction ,inst (segment src index)
+ (:printer-list (bit-test-inst-printer-list ,opcode-extension))
+ (:emitter (emit-bit-test-and-mumble segment src index
+ ,opcode-extension)))))
+ (define bt 4)
+ (define bts 5)
+ (define btr 6)
+ (define btc 7))
\f
;;;; control transfer
(define-instruction call (segment where)
(:printer near-jump ((op #b11101000)))
(:printer reg/mem-default-qword ((op '(#b11111111 #b010))))
- (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b010))))
(:emitter
(typecase where
(label
- (maybe-emit-rex-for-ea segment where nil)
(emit-byte segment #b11101000) ; 32 bit relative
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment
- (- (label-position where)
- (+ posn 4))))))
+ 4
+ (lambda (segment posn)
+ (emit-signed-dword segment
+ (- (label-position where)
+ (+ posn 4))))))
(fixup
- (maybe-emit-rex-for-ea segment where nil)
- (emit-byte segment #b11101000)
- (emit-relative-fixup segment where))
+ ;; There is no CALL rel64...
+ (error "Cannot CALL a fixup: ~S" where))
(t
- (maybe-emit-rex-for-ea segment where nil)
+ (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
(emit-byte segment #b11111111)
(emit-ea segment where #b010)))))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment
- 1
- (lambda (segment posn)
- (let ((disp (- (label-position target) (1+ posn))))
- (aver (<= -128 disp 127))
- (emit-byte segment disp)))))
+ 1
+ (lambda (segment posn)
+ (let ((disp (- (label-position target) (1+ posn))))
+ (aver (<= -128 disp 127))
+ (emit-byte segment disp)))))
(define-instruction jmp (segment cond &optional where)
;; conditional jumps
(:printer near-cond-jump () '('j cc :tab label))
;; unconditional jumps
(:printer short-jump ((op #b1011)))
- (:printer near-jump ((op #b11101001)) )
+ (:printer near-jump ((op #b11101001)))
(:printer reg/mem-default-qword ((op '(#b11111111 #b100))))
- (:printer rex-reg/mem-default-qword ((op '(#b11111111 #b100))))
(:emitter
(cond (where
- (emit-chooser
- segment 6 2
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b01110000))
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 6))))
- (emit-byte segment #b00001111)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b10000000))
- (emit-dword segment disp)))))
- ((label-p (setq where cond))
- (emit-chooser
- segment 5 0
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment #b11101011)
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 5))))
- (emit-byte segment #b11101001)
- (emit-dword segment disp)))))
- ((fixup-p where)
- (emit-byte segment #b11101001)
- (emit-relative-fixup segment where))
- (t
- (unless (or (ea-p where) (tn-p where))
- (error "don't know what to do with ~A" where))
- ;; near jump defaults to 64 bit
- ;; w-bit in rex prefix is unnecessary
- (maybe-emit-rex-for-ea segment where nil :operand-size :dword)
- (emit-byte segment #b11111111)
- (emit-ea segment where #b100)))))
-
-(define-instruction jmp-short (segment label)
- (:emitter
- (emit-byte segment #b11101011)
- (emit-byte-displacement-backpatch segment label)))
+ (emit-chooser
+ segment 6 2
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b01110000))
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 6))))
+ (emit-byte segment #b00001111)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b10000000))
+ (emit-signed-dword segment disp)))))
+ ((label-p (setq where cond))
+ (emit-chooser
+ segment 5 0
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 5))))
+ (emit-byte segment #b11101001)
+ (emit-signed-dword segment disp)))))
+ ((fixup-p where)
+ (emit-byte segment #b11101001)
+ (emit-relative-fixup segment where))
+ (t
+ (unless (or (ea-p where) (tn-p where))
+ (error "don't know what to do with ~A" where))
+ ;; near jump defaults to 64 bit
+ ;; w-bit in rex prefix is unnecessary
+ (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
+ (emit-byte segment #b11111111)
+ (emit-ea segment where #b100)))))
(define-instruction ret (segment &optional stack-delta)
(:printer byte ((op #b11000011)))
(:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
- '(:name :tab imm))
+ '(:name :tab imm))
(:emitter
- (cond (stack-delta
- (emit-byte segment #b11000010)
- (emit-word segment stack-delta))
- (t
- (emit-byte segment #b11000011)))))
+ (cond ((and stack-delta (not (zerop stack-delta)))
+ (emit-byte segment #b11000010)
+ (emit-word segment stack-delta))
+ (t
+ (emit-byte segment #b11000011)))))
-(define-instruction jecxz (segment target)
+(define-instruction jrcxz (segment target)
(:printer short-jump ((op #b0011)))
(:emitter
(emit-byte segment #b11100011)
(define-instruction loop (segment target)
(:printer short-jump ((op #b0010)))
(:emitter
- (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
+ (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
(emit-byte-displacement-backpatch segment target)))
(define-instruction loopz (segment target)
(:emitter
(aver (register-p dst))
(let ((size (matching-operand-size dst src)))
- (aver (or (eq size :word) (eq size :dword) (eq size :qword) ))
+ (aver (or (eq size :word) (eq size :dword) (eq size :qword)))
(maybe-emit-operand-size-prefix segment size))
(maybe-emit-rex-for-ea segment src dst)
(emit-byte segment #b00001111)
(define-instruction enter (segment disp &optional (level 0))
(:declare (type (unsigned-byte 16) disp)
- (type (unsigned-byte 8) level))
+ (type (unsigned-byte 8) level))
(:printer enter-format ((op #b11001000)))
(:emitter
(emit-byte segment #b11001000)
(defun snarf-error-junk (sap offset &optional length-only)
(let* ((length (sb!sys:sap-ref-8 sap offset))
- (vector (make-array length :element-type '(unsigned-byte 8))))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type sb!sys:system-area-pointer sap)
- (type (unsigned-byte 8) length)
- (type (simple-array (unsigned-byte 8) (*)) vector))
+ (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
(cond (length-only
- (values 0 (1+ length) nil nil))
- (t
- (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
- vector (* n-word-bits
- vector-data-offset)
- (* length n-byte-bits))
- (collect ((sc-offsets)
- (lengths))
- (lengths 1) ; the length byte
- (let* ((index 0)
- (error-number (sb!c:read-var-integer vector index)))
- (lengths index)
- (loop
- (when (>= index length)
- (return))
- (let ((old-index index))
- (sc-offsets (sb!c:read-var-integer vector index))
- (lengths (- index old-index))))
- (values error-number
- (1+ length)
- (sc-offsets)
- (lengths))))))))
+ (values 0 (1+ length) nil nil))
+ (t
+ (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+ vector 0 length)
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (let* ((index 0)
+ (error-number (sb!c:read-var-integer vector index)))
+ (lengths index)
+ (loop
+ (when (>= index length)
+ (return))
+ (let ((old-index index))
+ (sc-offsets (sb!c:read-var-integer vector index))
+ (lengths (- index old-index))))
+ (values error-number
+ (1+ length)
+ (sc-offsets)
+ (lengths))))))))
#|
(defmacro break-cases (breaknum &body cases)
(let ((bn-temp (gensym)))
(collect ((clauses))
(dolist (case cases)
- (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+ (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
`(let ((,bn-temp ,breaknum))
- (cond ,@(clauses))))))
+ (cond ,@(clauses))))))
|#
(defun break-control (chunk inst stream dstate)
(declare (ignore inst))
(flet ((nt (x) (if stream (sb!disassem:note x dstate))))
- ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
- ;; map has it undefined; and it should be easier to look in the target
- ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
- ;; from first principles whether it's defined in some way that genesis
- ;; can't grok.
- (case (byte-imm-code chunk dstate)
+ ;; XXX: {BYTE,WORD}-IMM-CODE below is a macro defined by the
+ ;; DEFINE-INSTRUCTION-FORMAT for {BYTE,WORD}-IMM above. Due to
+ ;; the spectacular design for DEFINE-INSTRUCTION-FORMAT (involving
+ ;; a call to EVAL in order to define the macros at compile-time
+ ;; only) they do not even show up as symbols in the target core.
+ (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
+ #!+ud2-breakpoints (word-imm-code chunk dstate)
(#.error-trap
(nt "error trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
(#.halt-trap
(nt "halt trap"))
(#.fun-end-breakpoint-trap
- (nt "function end breakpoint trap")))))
+ (nt "function end breakpoint trap"))
+ (#.single-step-around-trap
+ (nt "single-step trap (around)"))
+ (#.single-step-before-trap
+ (nt "single-step trap (before)")))))
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
- (:printer byte-imm ((op #b11001100)) '(:name :tab code)
- :control #'break-control)
- (:emitter
- (emit-byte segment #b11001100)
+ #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+ :control #'break-control)
+ #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
+ :control #'break-control)
+ (:emitter
+ #!-ud2-breakpoints (emit-byte segment #b11001100)
+ ;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
+ ;; throw a sigill with 0x0b0f instead and check for this in the
+ ;; SIGILL handler and pass it on to the sigtrap handler if
+ ;; appropriate
+ #!+ud2-breakpoints (emit-word segment #b0000101100001111)
(emit-byte segment code)))
(define-instruction int (segment number)
(emit-byte segment #b11001101)
(emit-byte segment number)))))
-(define-instruction into (segment)
- (:printer byte ((op #b11001110)))
- (:emitter
- (emit-byte segment #b11001110)))
-
-(define-instruction bound (segment reg bounds)
- (:emitter
- (let ((size (matching-operand-size reg bounds)))
- (when (eq size :byte)
- (error "can't bounds-test bytes: ~S" reg))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment bounds reg)
- (emit-byte segment #b01100010)
- (emit-ea segment bounds (reg-tn-encoding reg)))))
-
(define-instruction iret (segment)
(:printer byte ((op #b11001111)))
(:emitter
(define-instruction nop (segment)
(:printer byte ((op #b10010000)))
+ ;; multi-byte NOP
+ (:printer ext-reg/mem-no-width ((op '(#x1f 0))) '(:name))
(:emitter
(emit-byte segment #b10010000)))
+;;; Emit a sequence of single- or multi-byte NOPs to fill AMOUNT many
+;;; bytes with the smallest possible number of such instructions.
+(defun emit-long-nop (segment amount)
+ (declare (type segment segment)
+ (type index amount))
+ ;; Pack all instructions into one byte vector to save space.
+ (let* ((bytes #.(coerce #(#x90
+ #x66 #x90
+ #x0f #x1f #x00
+ #x0f #x1f #x40 #x00
+ #x0f #x1f #x44 #x00 #x00
+ #x66 #x0f #x1f #x44 #x00 #x00
+ #x0f #x1f #x80 #x00 #x00 #x00 #x00
+ #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00
+ #x66 #x0f #x1f #x84 #x00 #x00 #x00 #x00 #x00)
+ '(vector (unsigned-byte 8))))
+ (max-length (isqrt (* 2 (length bytes)))))
+ (loop
+ (let* ((count (min amount max-length))
+ (start (ash (* count (1- count)) -1)))
+ (dotimes (i count)
+ (emit-byte segment (aref bytes (+ start i)))))
+ (if (> amount max-length)
+ (decf amount max-length)
+ (return)))))
+
(define-instruction wait (segment)
(:printer byte ((op #b10011011)))
(:emitter
(emit-byte segment #b10011011)))
-(define-instruction lock (segment)
- (:printer byte ((op #b11110000)))
- (:emitter
- (emit-byte segment #b11110000)))
\f
;;;; miscellaneous hackery
(defun emit-header-data (segment type)
(emit-back-patch segment
- n-word-bytes
- (lambda (segment posn)
- (emit-qword segment
- (logior type
- (ash (+ posn
- (component-header-length))
- (- n-widetag-bits
- word-shift)))))))
+ n-word-bytes
+ (lambda (segment posn)
+ (emit-qword segment
+ (logior type
+ (ash (+ posn
+ (component-header-length))
+ (- n-widetag-bits
+ word-shift)))))))
(define-instruction simple-fun-header-word (segment)
(:emitter
(:emitter
(emit-header-data segment return-pc-header-widetag)))
\f
-;;;; fp instructions
-;;;;
-;;;; Note: We treat the single-precision and double-precision variants
-;;;; as separate instructions.
-
-;;; Load single to st(0).
-(define-instruction fld (segment source)
- (:printer floating-point ((op '(#b001 #b000))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011001)
- (emit-fp-op segment source #b000)))
-
-;;; Load double to st(0).
-(define-instruction fldd (segment source)
- (:printer floating-point ((op '(#b101 #b000))))
- (:printer floating-point-fp ((op '(#b001 #b000))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011001)
- (progn
- (maybe-emit-rex-for-ea segment source nil)
- (emit-byte segment #b11011101)))
- (emit-fp-op segment source #b000)))
-
-;;; Load long to st(0).
-(define-instruction fldl (segment source)
- (:printer floating-point ((op '(#b011 #b101))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011011)
- (emit-fp-op segment source #b101)))
-
-;;; Store single from st(0).
-(define-instruction fst (segment dest)
- (:printer floating-point ((op '(#b001 #b010))))
- (:emitter
- (cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b010)))))
-
-;;; Store double from st(0).
-(define-instruction fstd (segment dest)
- (:printer floating-point ((op '(#b101 #b010))))
- (:printer floating-point-fp ((op '(#b101 #b010))))
- (:emitter
- (cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010)))))
-
-;;; Arithmetic ops are all done with at least one operand at top of
-;;; stack. The other operand is is another register or a 32/64 bit
-;;; memory loc.
-
-;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
-;;; that these conflict with the Gdb conventions for binops. To reduce
-;;; the confusion I've added comments showing the mathamatical
-;;; operation and the two syntaxes. By the ASM386 convention the
-;;; instruction syntax is:
-;;;
-;;; Fop Source
-;;; or Fop Destination, Source
-;;;
-;;; If only one operand is given then it is the source and the
-;;; destination is ST(0). There are reversed forms of the fsub and
-;;; fdiv instructions inducated by an 'R' suffix.
-;;;
-;;; The mathematical operation for the non-reverse form is always:
-;;; destination = destination op source
-;;;
-;;; For the reversed form it is:
-;;; destination = source op destination
-;;;
-;;; The instructions below only accept one operand at present which is
-;;; usually the source. I've hack in extra instructions to implement
-;;; the fops with a ST(i) destination, these have a -sti suffix and
-;;; the operand is the destination with the source being ST(0).
-
-;;; Add single:
-;;; st(0) = st(0) + memory or st(i).
-(define-instruction fadd (segment source)
- (:printer floating-point ((op '(#b000 #b000))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b000)))
-
-;;; Add double:
-;;; st(0) = st(0) + memory or st(i).
-(define-instruction faddd (segment source)
- (:printer floating-point ((op '(#b100 #b000))))
- (:printer floating-point-fp ((op '(#b000 #b000))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (emit-byte segment #b11011100))
- (emit-fp-op segment source #b000)))
-
-;;; Add double destination st(i):
-;;; st(i) = st(0) + st(i).
-(define-instruction fadd-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b000))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b000)))
-;;; with pop
-(define-instruction faddp-sti (segment destination)
- (:printer floating-point-fp ((op '(#b110 #b000))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011110)
- (emit-fp-op segment destination #b000)))
-
-;;; Subtract single:
-;;; st(0) = st(0) - memory or st(i).
-(define-instruction fsub (segment source)
- (:printer floating-point ((op '(#b000 #b100))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b100)))
-
-;;; Subtract single, reverse:
-;;; st(0) = memory or st(i) - st(0).
-(define-instruction fsubr (segment source)
- (:printer floating-point ((op '(#b000 #b101))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b101)))
-
-;;; Subtract double:
-;;; st(0) = st(0) - memory or st(i).
-(define-instruction fsubd (segment source)
- (:printer floating-point ((op '(#b100 #b100))))
- (:printer floating-point-fp ((op '(#b000 #b100))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
- (emit-fp-op segment source #b100)))
-
-;;; Subtract double, reverse:
-;;; st(0) = memory or st(i) - st(0).
-(define-instruction fsubrd (segment source)
- (:printer floating-point ((op '(#b100 #b101))))
- (:printer floating-point-fp ((op '(#b000 #b101))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
- (emit-fp-op segment source #b101)))
-
-;;; Subtract double, destination st(i):
-;;; st(i) = st(i) - st(0).
-;;;
-;;; ASM386 syntax: FSUB ST(i), ST
-;;; Gdb syntax: fsubr %st,%st(i)
-(define-instruction fsub-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b101))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b101)))
-;;; with a pop
-(define-instruction fsubp-sti (segment destination)
- (:printer floating-point-fp ((op '(#b110 #b101))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011110)
- (emit-fp-op segment destination #b101)))
-
-;;; Subtract double, reverse, destination st(i):
-;;; st(i) = st(0) - st(i).
-;;;
-;;; ASM386 syntax: FSUBR ST(i), ST
-;;; Gdb syntax: fsub %st,%st(i)
-(define-instruction fsubr-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b100))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b100)))
-;;; with a pop
-(define-instruction fsubrp-sti (segment destination)
- (:printer floating-point-fp ((op '(#b110 #b100))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011110)
- (emit-fp-op segment destination #b100)))
-
-;;; Multiply single:
-;;; st(0) = st(0) * memory or st(i).
-(define-instruction fmul (segment source)
- (:printer floating-point ((op '(#b000 #b001))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b001)))
-
-;;; Multiply double:
-;;; st(0) = st(0) * memory or st(i).
-(define-instruction fmuld (segment source)
- (:printer floating-point ((op '(#b100 #b001))))
- (:printer floating-point-fp ((op '(#b000 #b001))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
- (emit-fp-op segment source #b001)))
-
-;;; Multiply double, destination st(i):
-;;; st(i) = st(i) * st(0).
-(define-instruction fmul-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b001))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b001)))
-
-;;; Divide single:
-;;; st(0) = st(0) / memory or st(i).
-(define-instruction fdiv (segment source)
- (:printer floating-point ((op '(#b000 #b110))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b110)))
-
-;;; Divide single, reverse:
-;;; st(0) = memory or st(i) / st(0).
-(define-instruction fdivr (segment source)
- (:printer floating-point ((op '(#b000 #b111))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment source #b111)))
-
-;;; Divide double:
-;;; st(0) = st(0) / memory or st(i).
-(define-instruction fdivd (segment source)
- (:printer floating-point ((op '(#b100 #b110))))
- (:printer floating-point-fp ((op '(#b000 #b110))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
- (emit-fp-op segment source #b110)))
-
-;;; Divide double, reverse:
-;;; st(0) = memory or st(i) / st(0).
-(define-instruction fdivrd (segment source)
- (:printer floating-point ((op '(#b100 #b111))))
- (:printer floating-point-fp ((op '(#b000 #b111))))
- (:emitter
- (if (fp-reg-tn-p source)
- (emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
- (emit-fp-op segment source #b111)))
-
-;;; Divide double, destination st(i):
-;;; st(i) = st(i) / st(0).
-;;;
-;;; ASM386 syntax: FDIV ST(i), ST
-;;; Gdb syntax: fdivr %st,%st(i)
-(define-instruction fdiv-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b111))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b111)))
-
-;;; Divide double, reverse, destination st(i):
-;;; st(i) = st(0) / st(i).
-;;;
-;;; ASM386 syntax: FDIVR ST(i), ST
-;;; Gdb syntax: fdiv %st,%st(i)
-(define-instruction fdivr-sti (segment destination)
- (:printer floating-point-fp ((op '(#b100 #b110))))
- (:emitter
- (aver (fp-reg-tn-p destination))
- (emit-byte segment #b11011100)
- (emit-fp-op segment destination #b110)))
-
-;;; Exchange fr0 with fr(n). (There is no double precision variant.)
-(define-instruction fxch (segment source)
- (:printer floating-point-fp ((op '(#b001 #b001))))
- (:emitter
- (unless (and (tn-p source)
- (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
- (cl:break))
- (emit-byte segment #b11011001)
- (emit-fp-op segment source #b001)))
-
-;;; Push 32-bit integer to st0.
-(define-instruction fild (segment source)
- (:printer floating-point ((op '(#b011 #b000))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011011)
- (emit-fp-op segment source #b000)))
-
-;;; Push 64-bit integer to st0.
-(define-instruction fildl (segment source)
- (:printer floating-point ((op '(#b111 #b101))))
- (:emitter
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011111)
- (emit-fp-op segment source #b101)))
-
-;;; Store 32-bit integer.
-(define-instruction fist (segment dest)
- (:printer floating-point ((op '(#b011 #b010))))
- (:emitter
- (and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
- (emit-byte segment #b11011011)
- (emit-fp-op segment dest #b010)))
-
-;;; Store and pop 32-bit integer.
-(define-instruction fistp (segment dest)
- (:printer floating-point ((op '(#b011 #b011))))
- (:emitter
- (and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
- (emit-byte segment #b11011011)
- (emit-fp-op segment dest #b011)))
-
-;;; Store and pop 64-bit integer.
-(define-instruction fistpl (segment dest)
- (:printer floating-point ((op '(#b111 #b111))))
- (:emitter
- (and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
- (emit-byte segment #b11011111)
- (emit-fp-op segment dest #b111)))
-
-;;; Store single from st(0) and pop.
-(define-instruction fstp (segment dest)
- (:printer floating-point ((op '(#b001 #b011))))
- (:emitter
- (cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b011)))))
-
-;;; Store double from st(0) and pop.
-(define-instruction fstpd (segment dest)
- (:printer floating-point ((op '(#b101 #b011))))
- (:printer floating-point-fp ((op '(#b101 #b011))))
- (:emitter
- (cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011)))))
-
-;;; Store long from st(0) and pop.
-(define-instruction fstpl (segment dest)
- (:printer floating-point ((op '(#b011 #b111))))
- (:emitter
- (and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
- (emit-byte segment #b11011011)
- (emit-fp-op segment dest #b111)))
-
-;;; Decrement stack-top pointer.
-(define-instruction fdecstp (segment)
- (:printer floating-point-no ((op #b10110)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110110)))
-
-;;; Increment stack-top pointer.
-(define-instruction fincstp (segment)
- (:printer floating-point-no ((op #b10111)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110111)))
-
-;;; Free fp register.
-(define-instruction ffree (segment dest)
- (:printer floating-point-fp ((op '(#b101 #b000))))
- (:emitter
- (and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b000)))
-
-(define-instruction fabs (segment)
- (:printer floating-point-no ((op #b00001)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11100001)))
-
-(define-instruction fchs (segment)
- (:printer floating-point-no ((op #b00000)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11100000)))
-
-(define-instruction frndint(segment)
- (:printer floating-point-no ((op #b11100)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111100)))
-
-;;; Initialize NPX.
-(define-instruction fninit(segment)
- (:printer floating-point-5 ((op #b00011)))
- (:emitter
- (emit-byte segment #b11011011)
- (emit-byte segment #b11100011)))
-
-;;; Store Status Word to AX.
-(define-instruction fnstsw(segment)
- (:printer floating-point-st ((op #b00000)))
- (:emitter
- (emit-byte segment #b11011111)
- (emit-byte segment #b11100000)))
-
-;;; Load Control Word.
-;;;
-;;; src must be a memory location
-(define-instruction fldcw(segment src)
- (:printer floating-point ((op '(#b001 #b101))))
- (:emitter
- (and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
- (emit-byte segment #b11011001)
- (emit-fp-op segment src #b101)))
-
-;;; Store Control Word.
-(define-instruction fnstcw(segment dst)
- (:printer floating-point ((op '(#b001 #b111))))
- (:emitter
- (and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
- (emit-byte segment #b11011001)
- (emit-fp-op segment dst #b111)))
-
-;;; Store FP Environment.
-(define-instruction fstenv(segment dst)
- (:printer floating-point ((op '(#b001 #b110))))
- (:emitter
- (and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
- (emit-byte segment #b11011001)
- (emit-fp-op segment dst #b110)))
-
-;;; Restore FP Environment.
-(define-instruction fldenv(segment src)
- (:printer floating-point ((op '(#b001 #b100))))
- (:emitter
- (and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
- (emit-byte segment #b11011001)
- (emit-fp-op segment src #b100)))
-
-;;; Save FP State.
-(define-instruction fsave(segment dst)
- (:printer floating-point ((op '(#b101 #b110))))
- (:emitter
- (and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
- (emit-byte segment #b11011101)
- (emit-fp-op segment dst #b110)))
-
-;;; Restore FP State.
-(define-instruction frstor(segment src)
- (:printer floating-point ((op '(#b101 #b100))))
- (:emitter
- (and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
- (emit-byte segment #b11011101)
- (emit-fp-op segment src #b100)))
-
-;;; Clear exceptions.
-(define-instruction fnclex(segment)
- (:printer floating-point-5 ((op #b00010)))
- (:emitter
- (emit-byte segment #b11011011)
- (emit-byte segment #b11100010)))
-
-;;; comparison
-(define-instruction fcom (segment src)
- (:printer floating-point ((op '(#b000 #b010))))
- (:emitter
- (and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
- (emit-byte segment #b11011000)
- (emit-fp-op segment src #b010)))
-
-(define-instruction fcomd (segment src)
- (:printer floating-point ((op '(#b100 #b010))))
- (:printer floating-point-fp ((op '(#b000 #b010))))
- (:emitter
- (if (fp-reg-tn-p src)
- (emit-byte segment #b11011000)
- (progn
- (maybe-emit-rex-for-ea segment src nil)
- (emit-byte segment #b11011100)))
- (emit-fp-op segment src #b010)))
-
-;;; Compare ST1 to ST0, popping the stack twice.
-(define-instruction fcompp (segment)
- (:printer floating-point-3 ((op '(#b110 #b011001))))
- (:emitter
- (emit-byte segment #b11011110)
- (emit-byte segment #b11011001)))
-
-;;; unordered comparison
-(define-instruction fucom (segment src)
- (:printer floating-point-fp ((op '(#b101 #b100))))
- (:emitter
- (aver (fp-reg-tn-p src))
- (emit-byte segment #b11011101)
- (emit-fp-op segment src #b100)))
-
-(define-instruction ftst (segment)
- (:printer floating-point-no ((op #b00100)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11100100)))
-
-;;;; 80387 specials
-
-(define-instruction fsqrt(segment)
- (:printer floating-point-no ((op #b11010)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111010)))
-
-(define-instruction fscale(segment)
- (:printer floating-point-no ((op #b11101)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111101)))
-
-(define-instruction fxtract(segment)
- (:printer floating-point-no ((op #b10100)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110100)))
-
-(define-instruction fsin(segment)
- (:printer floating-point-no ((op #b11110)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111110)))
-
-(define-instruction fcos(segment)
- (:printer floating-point-no ((op #b11111)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111111)))
-
-(define-instruction fprem1(segment)
- (:printer floating-point-no ((op #b10101)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110101)))
-
-(define-instruction fprem(segment)
- (:printer floating-point-no ((op #b11000)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111000)))
-
-(define-instruction fxam (segment)
- (:printer floating-point-no ((op #b00101)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11100101)))
-
-;;; These do push/pop to stack and need special handling
-;;; in any VOPs that use them. See the book.
+;;;; Instructions required to do floating point operations using SSE
-;;; st0 <- st1*log2(st0)
-(define-instruction fyl2x(segment) ; pops stack
- (:printer floating-point-no ((op #b10001)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110001)))
-
-(define-instruction fyl2xp1(segment)
- (:printer floating-point-no ((op #b11001)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11111001)))
-
-(define-instruction f2xm1(segment)
- (:printer floating-point-no ((op #b10000)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110000)))
-
-(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
- (:printer floating-point-no ((op #b10010)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110010)))
-
-(define-instruction fpatan(segment) ; POPS STACK
- (:printer floating-point-no ((op #b10011)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11110011)))
-
-;;;; loading constants
-
-(define-instruction fldz(segment)
- (:printer floating-point-no ((op #b01110)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101110)))
-
-(define-instruction fld1(segment)
- (:printer floating-point-no ((op #b01000)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101000)))
-
-(define-instruction fldpi(segment)
- (:printer floating-point-no ((op #b01011)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101011)))
-
-(define-instruction fldl2t(segment)
- (:printer floating-point-no ((op #b01001)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101001)))
-
-(define-instruction fldl2e(segment)
- (:printer floating-point-no ((op #b01010)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101010)))
-
-(define-instruction fldlg2(segment)
- (:printer floating-point-no ((op #b01100)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101100)))
-
-(define-instruction fldln2(segment)
- (:printer floating-point-no ((op #b01101)))
- (:emitter
- (emit-byte segment #b11011001)
- (emit-byte segment #b11101101)))
-
-;; new xmm insns required by sse float
-;; movsd andpd comisd comiss
-
-(define-instruction movsd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (cond ((typep src 'tn)
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x11)
- (emit-ea segment dst (reg-tn-encoding src)))
- (t
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x10)
- (emit-ea segment src (reg-tn-encoding dst))))))
-
-(define-instruction movss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (cond ((tn-p src)
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x11)
- (emit-ea segment dst (reg-tn-encoding src)))
- (t
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x10)
- (emit-ea segment src (reg-tn-encoding dst))))))
-
-(define-instruction andpd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x54)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction andps (segment dst src)
- (:emitter
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x54)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction comisd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x2f)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction comiss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+;; Return a one- or two-element list of printers for SSE instructions.
+;; The one-element list is used in the cases where the REX prefix is
+;; really a prefix and thus automatically supported, the two-element
+;; list is used when the REX prefix is used in an infix position.
+(eval-when (:compile-toplevel :execute)
+ (defun sse-inst-printer-list (inst-format-stem prefix opcode
+ &key more-fields printer)
+ (let ((fields `(,@(when prefix
+ `((prefix ,prefix)))
+ (op ,opcode)
+ ,@more-fields))
+ (inst-formats (if prefix
+ (list (symbolicate "EXT-" inst-format-stem)
+ (symbolicate "EXT-REX-" inst-format-stem))
+ (list inst-format-stem))))
+ (mapcar (lambda (inst-format)
+ `(,inst-format ,fields ,@(when printer
+ (list printer))))
+ inst-formats)))
+ (defun 2byte-sse-inst-printer-list (inst-format-stem prefix op1 op2
+ &key more-fields printer)
+ (let ((fields `(,@(when prefix
+ `((prefix, prefix)))
+ (op1 ,op1)
+ (op2 ,op2)
+ ,@more-fields))
+ (inst-formats (if prefix
+ (list (symbolicate "EXT-" inst-format-stem)
+ (symbolicate "EXT-REX-" inst-format-stem))
+ (list inst-format-stem))))
+ (mapcar (lambda (inst-format)
+ `(,inst-format ,fields ,@(when printer
+ (list printer))))
+ inst-formats))))
+
+(defun emit-sse-inst (segment dst src prefix opcode
+ &key operand-size (remaining-bytes 0))
+ (when prefix
+ (emit-byte segment prefix))
+ (if operand-size
+ (maybe-emit-rex-for-ea segment src dst :operand-size operand-size)
+ (maybe-emit-rex-for-ea segment src dst))
+ (emit-byte segment #x0f)
+ (emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst) :remaining-bytes remaining-bytes))
+
+;; 0110 0110:0000 1111:0111 00gg: 11 010 xmmreg:imm8
+
+(defun emit-sse-inst-with-imm (segment dst/src imm
+ prefix opcode /i
+ &key operand-size)
+ (aver (<= 0 /i 7))
+ (when prefix
+ (emit-byte segment prefix))
+ (maybe-emit-rex-prefix segment operand-size dst/src nil nil)
+ (emit-byte segment #x0F)
+ (emit-byte segment opcode)
+ (emit-byte segment (logior (ash (logior #b11000 /i) 3)
+ (reg-tn-encoding dst/src)))
+ (emit-byte segment imm))
+
+(defun emit-sse-inst-2byte (segment dst src prefix op1 op2
+ &key operand-size (remaining-bytes 0))
+ (when prefix
+ (emit-byte segment prefix))
+ (if operand-size
+ (maybe-emit-rex-for-ea segment src dst :operand-size operand-size)
+ (maybe-emit-rex-for-ea segment src dst))
+ (emit-byte segment #x0f)
+ (emit-byte segment op1)
+ (emit-byte segment op2)
+ (emit-ea segment src (reg-tn-encoding dst) :remaining-bytes remaining-bytes))
+
+(macrolet
+ ((define-imm-sse-instruction (name opcode /i)
+ `(define-instruction ,name (segment dst/src imm)
+ (:printer-list
+ ',(sse-inst-printer-list 'xmm-imm #x66 opcode
+ :more-fields `((/i ,/i))))
+ (:emitter
+ (emit-sse-inst-with-imm segment dst/src imm
+ #x66 ,opcode ,/i
+ :operand-size :do-not-set)))))
+ (define-imm-sse-instruction pslldq #x73 7)
+ (define-imm-sse-instruction psllw-imm #x71 6)
+ (define-imm-sse-instruction pslld-imm #x72 6)
+ (define-imm-sse-instruction psllq-imm #x73 6)
+
+ (define-imm-sse-instruction psraw-imm #x71 4)
+ (define-imm-sse-instruction psrad-imm #x72 4)
+
+ (define-imm-sse-instruction psrldq #x73 3)
+ (define-imm-sse-instruction psrlw-imm #x71 2)
+ (define-imm-sse-instruction psrld-imm #x72 2)
+ (define-imm-sse-instruction psrlq-imm #x73 2))
+
+;;; Emit an SSE instruction that has an XMM register as the destination
+;;; operand and for which the size of the operands is implicitly given
+;;; by the instruction.
+(defun emit-regular-sse-inst (segment dst src prefix opcode
+ &key (remaining-bytes 0))
+ (aver (xmm-register-p dst))
+ (emit-sse-inst segment dst src prefix opcode
+ :operand-size :do-not-set
+ :remaining-bytes remaining-bytes))
+
+(defun emit-regular-2byte-sse-inst (segment dst src prefix op1 op2
+ &key (remaining-bytes 0))
+ (aver (xmm-register-p dst))
+ (emit-sse-inst-2byte segment dst src prefix op1 op2
+ :operand-size :do-not-set
+ :remaining-bytes remaining-bytes))
+
+;;; Instructions having an XMM register as the destination operand
+;;; and an XMM register or a memory location as the source operand.
+;;; The operand size is implicitly given by the instruction.
+
+(macrolet ((define-regular-sse-inst (name prefix opcode)
+ `(define-instruction ,name (segment dst src)
+ (:printer-list
+ ',(sse-inst-printer-list 'xmm-xmm/mem prefix opcode))
+ (:emitter
+ (emit-regular-sse-inst segment dst src ,prefix ,opcode)))))
+ ;; moves
+ (define-regular-sse-inst movshdup #xf3 #x16)
+ (define-regular-sse-inst movsldup #xf3 #x12)
+ (define-regular-sse-inst movddup #xf2 #x12)
+ ;; logical
+ (define-regular-sse-inst andpd #x66 #x54)
+ (define-regular-sse-inst andps nil #x54)
+ (define-regular-sse-inst andnpd #x66 #x55)
+ (define-regular-sse-inst andnps nil #x55)
+ (define-regular-sse-inst orpd #x66 #x56)
+ (define-regular-sse-inst orps nil #x56)
+ (define-regular-sse-inst pand #x66 #xdb)
+ (define-regular-sse-inst pandn #x66 #xdf)
+ (define-regular-sse-inst por #x66 #xeb)
+ (define-regular-sse-inst pxor #x66 #xef)
+ (define-regular-sse-inst xorpd #x66 #x57)
+ (define-regular-sse-inst xorps nil #x57)
+ ;; comparison
+ (define-regular-sse-inst comisd #x66 #x2f)
+ (define-regular-sse-inst comiss nil #x2f)
+ (define-regular-sse-inst ucomisd #x66 #x2e)
+ (define-regular-sse-inst ucomiss nil #x2e)
+ ;; integer comparison
+ (define-regular-sse-inst pcmpeqb #x66 #x74)
+ (define-regular-sse-inst pcmpeqw #x66 #x75)
+ (define-regular-sse-inst pcmpeqd #x66 #x76)
+ (define-regular-sse-inst pcmpgtb #x66 #x64)
+ (define-regular-sse-inst pcmpgtw #x66 #x65)
+ (define-regular-sse-inst pcmpgtd #x66 #x66)
+ ;; max/min
+ (define-regular-sse-inst maxpd #x66 #x5f)
+ (define-regular-sse-inst maxps nil #x5f)
+ (define-regular-sse-inst maxsd #xf2 #x5f)
+ (define-regular-sse-inst maxss #xf3 #x5f)
+ (define-regular-sse-inst minpd #x66 #x5d)
+ (define-regular-sse-inst minps nil #x5d)
+ (define-regular-sse-inst minsd #xf2 #x5d)
+ (define-regular-sse-inst minss #xf3 #x5d)
+ ;; integer max/min
+ (define-regular-sse-inst pmaxsw #x66 #xee)
+ (define-regular-sse-inst pmaxub #x66 #xde)
+ (define-regular-sse-inst pminsw #x66 #xea)
+ (define-regular-sse-inst pminub #x66 #xda)
+ ;; arithmetic
+ (define-regular-sse-inst addpd #x66 #x58)
+ (define-regular-sse-inst addps nil #x58)
+ (define-regular-sse-inst addsd #xf2 #x58)
+ (define-regular-sse-inst addss #xf3 #x58)
+ (define-regular-sse-inst addsubpd #x66 #xd0)
+ (define-regular-sse-inst addsubps #xf2 #xd0)
+ (define-regular-sse-inst divpd #x66 #x5e)
+ (define-regular-sse-inst divps nil #x5e)
+ (define-regular-sse-inst divsd #xf2 #x5e)
+ (define-regular-sse-inst divss #xf3 #x5e)
+ (define-regular-sse-inst haddpd #x66 #x7c)
+ (define-regular-sse-inst haddps #xf2 #x7c)
+ (define-regular-sse-inst hsubpd #x66 #x7d)
+ (define-regular-sse-inst hsubps #xf2 #x7d)
+ (define-regular-sse-inst mulpd #x66 #x59)
+ (define-regular-sse-inst mulps nil #x59)
+ (define-regular-sse-inst mulsd #xf2 #x59)
+ (define-regular-sse-inst mulss #xf3 #x59)
+ (define-regular-sse-inst rcpps nil #x53)
+ (define-regular-sse-inst rcpss #xf3 #x53)
+ (define-regular-sse-inst rsqrtps nil #x52)
+ (define-regular-sse-inst rsqrtss #xf3 #x52)
+ (define-regular-sse-inst sqrtpd #x66 #x51)
+ (define-regular-sse-inst sqrtps nil #x51)
+ (define-regular-sse-inst sqrtsd #xf2 #x51)
+ (define-regular-sse-inst sqrtss #xf3 #x51)
+ (define-regular-sse-inst subpd #x66 #x5c)
+ (define-regular-sse-inst subps nil #x5c)
+ (define-regular-sse-inst subsd #xf2 #x5c)
+ (define-regular-sse-inst subss #xf3 #x5c)
+ (define-regular-sse-inst unpckhpd #x66 #x15)
+ (define-regular-sse-inst unpckhps nil #x15)
+ (define-regular-sse-inst unpcklpd #x66 #x14)
+ (define-regular-sse-inst unpcklps nil #x14)
+ ;; integer arithmetic
+ (define-regular-sse-inst paddb #x66 #xfc)
+ (define-regular-sse-inst paddw #x66 #xfd)
+ (define-regular-sse-inst paddd #x66 #xfe)
+ (define-regular-sse-inst paddq #x66 #xd4)
+ (define-regular-sse-inst paddsb #x66 #xec)
+ (define-regular-sse-inst paddsw #x66 #xed)
+ (define-regular-sse-inst paddusb #x66 #xdc)
+ (define-regular-sse-inst paddusw #x66 #xdd)
+ (define-regular-sse-inst pavgb #x66 #xe0)
+ (define-regular-sse-inst pavgw #x66 #xe3)
+ (define-regular-sse-inst pmaddwd #x66 #xf5)
+ (define-regular-sse-inst pmulhuw #x66 #xe4)
+ (define-regular-sse-inst pmulhw #x66 #xe5)
+ (define-regular-sse-inst pmullw #x66 #xd5)
+ (define-regular-sse-inst pmuludq #x66 #xf4)
+ (define-regular-sse-inst psadbw #x66 #xf6)
+ (define-regular-sse-inst psllw #x66 #xf1)
+ (define-regular-sse-inst pslld #x66 #xf2)
+ (define-regular-sse-inst psllq #x66 #xf3)
+ (define-regular-sse-inst psraw #x66 #xe1)
+ (define-regular-sse-inst psrad #x66 #xe2)
+ (define-regular-sse-inst psrlw #x66 #xd1)
+ (define-regular-sse-inst psrld #x66 #xd2)
+ (define-regular-sse-inst psrlq #x66 #xd3)
+ (define-regular-sse-inst psubb #x66 #xf8)
+ (define-regular-sse-inst psubw #x66 #xf9)
+ (define-regular-sse-inst psubd #x66 #xfa)
+ (define-regular-sse-inst psubq #x66 #xfb)
+ (define-regular-sse-inst psubsb #x66 #xe8)
+ (define-regular-sse-inst psubsw #x66 #xe9)
+ (define-regular-sse-inst psubusb #x66 #xd8)
+ (define-regular-sse-inst psubusw #x66 #xd9)
+ ;; conversion
+ (define-regular-sse-inst cvtdq2pd #xf3 #xe6)
+ (define-regular-sse-inst cvtdq2ps nil #x5b)
+ (define-regular-sse-inst cvtpd2dq #xf2 #xe6)
+ (define-regular-sse-inst cvtpd2ps #x66 #x5a)
+ (define-regular-sse-inst cvtps2dq #x66 #x5b)
+ (define-regular-sse-inst cvtps2pd nil #x5a)
+ (define-regular-sse-inst cvtsd2ss #xf2 #x5a)
+ (define-regular-sse-inst cvtss2sd #xf3 #x5a)
+ (define-regular-sse-inst cvttpd2dq #x66 #xe6)
+ (define-regular-sse-inst cvttps2dq #xf3 #x5b)
+ ;; integer
+ (define-regular-sse-inst packsswb #x66 #x63)
+ (define-regular-sse-inst packssdw #x66 #x6b)
+ (define-regular-sse-inst packuswb #x66 #x67)
+ (define-regular-sse-inst punpckhbw #x66 #x68)
+ (define-regular-sse-inst punpckhwd #x66 #x69)
+ (define-regular-sse-inst punpckhdq #x66 #x6a)
+ (define-regular-sse-inst punpckhqdq #x66 #x6d)
+ (define-regular-sse-inst punpcklbw #x66 #x60)
+ (define-regular-sse-inst punpcklwd #x66 #x61)
+ (define-regular-sse-inst punpckldq #x66 #x62)
+ (define-regular-sse-inst punpcklqdq #x66 #x6c))
+
+(macrolet ((define-xmm-shuffle-sse-inst (name prefix opcode n-bits radix)
+ (let ((shuffle-pattern
+ (intern (format nil "SSE-SHUFFLE-PATTERN-~D-~D"
+ n-bits radix))))
+ `(define-instruction ,name (segment dst src pattern)
+ (:printer-list
+ ',(sse-inst-printer-list
+ 'xmm-xmm/mem prefix opcode
+ :more-fields `((imm nil :type ,shuffle-pattern))
+ :printer '(:name :tab reg ", " reg/mem ", " imm)))
+
+ (:emitter
+ (aver (typep pattern '(unsigned-byte ,n-bits)))
+ (emit-regular-sse-inst segment dst src ,prefix ,opcode
+ :remaining-bytes 1)
+ (emit-byte segment pattern))))))
+ (define-xmm-shuffle-sse-inst pshufd #x66 #x70 8 4)
+ (define-xmm-shuffle-sse-inst pshufhw #xf3 #x70 8 4)
+ (define-xmm-shuffle-sse-inst pshuflw #xf2 #x70 8 4)
+ (define-xmm-shuffle-sse-inst shufpd #x66 #xc6 2 2)
+ (define-xmm-shuffle-sse-inst shufps nil #xc6 8 4))
+
+;; MASKMOVDQU (dst is DS:RDI)
+(define-instruction maskmovdqu (segment src mask)
+ (:printer-list
+ (sse-inst-printer-list 'xmm-xmm/mem #x66 #xf7))
+ (:emitter
+ (aver (xmm-register-p src))
+ (aver (xmm-register-p mask))
+ (emit-regular-sse-inst segment src mask #x66 #xf7)))
+
+(macrolet ((define-comparison-sse-inst (name prefix opcode
+ name-prefix name-suffix)
+ `(define-instruction ,name (segment op x y)
+ (:printer-list
+ ',(sse-inst-printer-list
+ 'xmm-xmm/mem prefix opcode
+ :more-fields '((imm nil :type sse-condition-code))
+ :printer `(,name-prefix imm ,name-suffix
+ :tab reg ", " reg/mem)))
+ (:emitter
+ (let ((code (position op *sse-conditions*)))
+ (aver code)
+ (emit-regular-sse-inst segment x y ,prefix ,opcode
+ :remaining-bytes 1)
+ (emit-byte segment code))))))
+ (define-comparison-sse-inst cmppd #x66 #xc2 "CMP" "PD")
+ (define-comparison-sse-inst cmpps nil #xc2 "CMP" "PS")
+ (define-comparison-sse-inst cmpsd #xf2 #xc2 "CMP" "SD")
+ (define-comparison-sse-inst cmpss #xf3 #xc2 "CMP" "SS"))
+
+;;; MOVSD, MOVSS
+(macrolet ((define-movsd/ss-sse-inst (name prefix)
+ `(define-instruction ,name (segment dst src)
+ (:printer-list
+ ',(sse-inst-printer-list 'xmm-xmm/mem-dir
+ prefix #b0001000))
+ (:emitter
+ (cond ((xmm-register-p dst)
+ (emit-sse-inst segment dst src ,prefix #x10
+ :operand-size :do-not-set))
+ (t
+ (aver (xmm-register-p src))
+ (emit-sse-inst segment src dst ,prefix #x11
+ :operand-size :do-not-set)))))))
+ (define-movsd/ss-sse-inst movsd #xf2)
+ (define-movsd/ss-sse-inst movss #xf3))
+
+;;; Packed MOVs
+(macrolet ((define-mov-sse-inst (name prefix opcode-from opcode-to
+ &key force-to-mem reg-reg-name)
+ `(progn
+ ,(when reg-reg-name
+ `(define-instruction ,reg-reg-name (segment dst src)
+ (:emitter
+ (aver (xmm-register-p dst))
+ (aver (xmm-register-p src))
+ (emit-regular-sse-inst segment dst src
+ ,prefix ,opcode-from))))
+ (define-instruction ,name (segment dst src)
+ (:printer-list
+ '(,@(when opcode-from
+ (sse-inst-printer-list
+ 'xmm-xmm/mem prefix opcode-from))
+ ,@(sse-inst-printer-list
+ 'xmm-xmm/mem prefix opcode-to
+ :printer '(:name :tab reg/mem ", " reg))))
+ (:emitter
+ (cond ,@(when opcode-from
+ `(((xmm-register-p dst)
+ ,(when force-to-mem
+ `(aver (not (or (register-p src)
+ (xmm-register-p src)))))
+ (emit-regular-sse-inst
+ segment dst src ,prefix ,opcode-from))))
+ (t
+ (aver (xmm-register-p src))
+ ,(when force-to-mem
+ `(aver (not (or (register-p dst)
+ (xmm-register-p dst)))))
+ (emit-regular-sse-inst segment src dst
+ ,prefix ,opcode-to))))))))
+ ;; direction bit?
+ (define-mov-sse-inst movapd #x66 #x28 #x29)
+ (define-mov-sse-inst movaps nil #x28 #x29)
+ (define-mov-sse-inst movdqa #x66 #x6f #x7f)
+ (define-mov-sse-inst movdqu #xf3 #x6f #x7f)
+
+ ;; streaming
+ (define-mov-sse-inst movntdq #x66 nil #xe7 :force-to-mem t)
+ (define-mov-sse-inst movntpd #x66 nil #x2b :force-to-mem t)
+ (define-mov-sse-inst movntps nil nil #x2b :force-to-mem t)
+
+ ;; use movhps for movlhps and movlps for movhlps
+ (define-mov-sse-inst movhpd #x66 #x16 #x17 :force-to-mem t)
+ (define-mov-sse-inst movhps nil #x16 #x17 :reg-reg-name movlhps)
+ (define-mov-sse-inst movlpd #x66 #x12 #x13 :force-to-mem t)
+ (define-mov-sse-inst movlps nil #x12 #x13 :reg-reg-name movhlps)
+ (define-mov-sse-inst movupd #x66 #x10 #x11)
+ (define-mov-sse-inst movups nil #x10 #x11))
+
+;;; MOVNTDQA
+(define-instruction movntdqa (segment dst src)
+ (:printer-list
+ (2byte-sse-inst-printer-list '2byte-xmm-xmm/mem #x66 #x38 #x2a))
(:emitter
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x2f)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-;; movd movq xorp xord
-
-;; we only do the xmm version of movd
-(define-instruction movd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (cond ((fp-reg-tn-p dst)
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x6e)
- (emit-ea segment src (reg-tn-encoding dst)))
- (t
- (aver (fp-reg-tn-p src))
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x7e)
- (emit-ea segment dst (reg-tn-encoding src))))))
+ (aver (and (xmm-register-p dst)
+ (not (xmm-register-p src))))
+ (emit-regular-2byte-sse-inst segment dst src #x66 #x38 #x2a)))
+;;; MOVQ
(define-instruction movq (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (cond ((fp-reg-tn-p dst)
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x7e)
- (emit-ea segment src (reg-tn-encoding dst)))
- (t
- (aver (fp-reg-tn-p src))
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #xd6)
- (emit-ea segment dst (reg-tn-encoding src))))))
-
-(define-instruction xorpd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x57)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction xorps (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x57)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtsd2si (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
- (emit-byte segment #x0f)
- (emit-byte segment #x2d)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtsd2ss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5a)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtss2si (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
- (emit-byte segment #x0f)
- (emit-byte segment #x2d)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtss2sd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5a)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtsi2ss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x2a)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtsi2sd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x2a)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtdq2pd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #xe6)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvtdq2ps (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5b)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-;; CVTTSD2SI CVTTSS2SI
-
-(define-instruction cvttsd2si (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
- (emit-byte segment #x0f)
- (emit-byte segment #x2c)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction cvttss2si (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst :operand-size :qword)
- (emit-byte segment #x0f)
- (emit-byte segment #x2c)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction addsd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x58)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction addss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x58)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction divsd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5e)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction divss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5e)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction mulsd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x59)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction mulss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
- (:emitter
- (emit-byte segment #xf3)
+ (:printer-list
+ (append
+ (sse-inst-printer-list 'xmm-xmm/mem #xf3 #x7e)
+ (sse-inst-printer-list 'xmm-xmm/mem #x66 #xd6
+ :printer '(:name :tab reg/mem ", " reg))))
+ (:emitter
+ (cond ((xmm-register-p dst)
+ (emit-sse-inst segment dst src #xf3 #x7e
+ :operand-size :do-not-set))
+ (t
+ (aver (xmm-register-p src))
+ (emit-sse-inst segment src dst #x66 #xd6
+ :operand-size :do-not-set)))))
+
+;;; Instructions having an XMM register as the destination operand
+;;; and a general-purpose register or a memory location as the source
+;;; operand. The operand size is calculated from the source operand.
+
+;;; MOVD - Move a 32- or 64-bit value from a general-purpose register or
+;;; a memory location to the low order 32 or 64 bits of an XMM register
+;;; with zero extension or vice versa.
+;;; We do not support the MMX version of this instruction.
+(define-instruction movd (segment dst src)
+ (:printer-list
+ (append
+ (sse-inst-printer-list 'xmm-reg/mem #x66 #x6e)
+ (sse-inst-printer-list 'xmm-reg/mem #x66 #x7e
+ :printer '(:name :tab reg/mem ", " reg))))
+ (:emitter
+ (cond ((xmm-register-p dst)
+ (emit-sse-inst segment dst src #x66 #x6e))
+ (t
+ (aver (xmm-register-p src))
+ (emit-sse-inst segment src dst #x66 #x7e)))))
+
+(macrolet ((define-extract-sse-instruction (name prefix op1 op2 &key explicit-qword)
+ `(define-instruction ,name (segment dst src imm)
+ (:printer
+ ,(if op2 (if explicit-qword
+ 'ext-rex-2byte-reg/mem-xmm
+ 'ext-2byte-reg/mem-xmm)
+ 'ext-reg/mem-xmm)
+ ((prefix '(,prefix))
+ ,@(if op2
+ `((op1 '(,op1)) (op2 '(,op2)))
+ `((op '(,op1))))
+ (imm nil :type 'imm-byte))
+ '(:name :tab reg/mem ", " reg ", " imm))
+ (:emitter
+ (aver (and (xmm-register-p src) (not (xmm-register-p dst))))
+ ,(if op2
+ `(emit-sse-inst-2byte segment dst src ,prefix ,op1 ,op2
+ :operand-size ,(if explicit-qword
+ :qword
+ :do-not-set)
+ :remaining-bytes 1)
+ `(emit-sse-inst segment dst src ,prefix ,op1
+ :operand-size ,(if explicit-qword
+ :qword
+ :do-not-set)
+ :remaining-bytes 1))
+ (emit-byte segment imm))))
+
+ (define-insert-sse-instruction (name prefix op1 op2)
+ `(define-instruction ,name (segment dst src imm)
+ (:printer
+ ,(if op2 'ext-2byte-xmm-reg/mem 'ext-xmm-reg/mem)
+ ((prefix '(,prefix))
+ ,@(if op2
+ `((op1 '(,op1)) (op2 '(,op2)))
+ `((op '(,op1))))
+ (imm nil :type 'imm-byte))
+ '(:name :tab reg ", " reg/mem ", " imm))
+ (:emitter
+ (aver (and (xmm-register-p dst) (not (xmm-register-p src))))
+ ,(if op2
+ `(emit-sse-inst-2byte segment dst src ,prefix ,op1 ,op2
+ :operand-size :do-not-set
+ :remaining-bytes 1)
+ `(emit-sse-inst segment dst src ,prefix ,op1
+ :operand-size :do-not-set
+ :remaining-bytes 1))
+ (emit-byte segment imm)))))
+
+
+ ;; pinsrq not encodable in 64-bit mode
+ (define-insert-sse-instruction pinsrb #x66 #x3a #x20)
+ (define-insert-sse-instruction pinsrw #x66 #xc4 nil)
+ (define-insert-sse-instruction pinsrd #x66 #x3a #x22)
+ (define-insert-sse-instruction insertps #x66 #x3a #x21)
+
+ (define-extract-sse-instruction pextrb #x66 #x3a #x14)
+ (define-extract-sse-instruction pextrd #x66 #x3a #x16)
+ (define-extract-sse-instruction pextrq #x66 #x3a #x16 :explicit-qword t)
+ (define-extract-sse-instruction extractps #x66 #x3a #x17))
+
+;; PEXTRW has a new 2-byte encoding in SSE4.1 to allow dst to be
+;; a memory address.
+(define-instruction pextrw (segment dst src imm)
+ (:printer-list
+ (append
+ (2byte-sse-inst-printer-list '2byte-reg/mem-xmm #x66 #x3a #x15
+ :more-fields '((imm nil :type imm-byte))
+ :printer
+ '(:name :tab reg/mem ", " reg ", " imm))
+ (sse-inst-printer-list 'reg/mem-xmm #x66 #xc5
+ :more-fields '((imm nil :type imm-byte))
+ :printer
+ '(:name :tab reg/mem ", " reg ", " imm))))
+ (:emitter
+ (aver (xmm-register-p src))
+ (if (not (register-p dst))
+ (emit-sse-inst-2byte segment dst src #x66 #x3a #x15
+ :operand-size :do-not-set :remaining-bytes 1)
+ (emit-sse-inst segment dst src #x66 #xc5
+ :operand-size :do-not-set :remaining-bytes 1))
+ (emit-byte segment imm)))
+
+(macrolet ((define-integer-source-sse-inst (name prefix opcode &key mem-only)
+ `(define-instruction ,name (segment dst src)
+ (:printer-list
+ ',(sse-inst-printer-list 'xmm-reg/mem prefix opcode))
+ (:emitter
+ (aver (xmm-register-p dst))
+ ,(when mem-only
+ `(aver (not (or (register-p src)
+ (xmm-register-p src)))))
+ (let ((src-size (operand-size src)))
+ (aver (or (eq src-size :qword) (eq src-size :dword))))
+ (emit-sse-inst segment dst src ,prefix ,opcode)))))
+ (define-integer-source-sse-inst cvtsi2sd #xf2 #x2a)
+ (define-integer-source-sse-inst cvtsi2ss #xf3 #x2a)
+ ;; FIXME: memory operand is always a QWORD
+ (define-integer-source-sse-inst cvtpi2pd #x66 #x2a :mem-only t)
+ (define-integer-source-sse-inst cvtpi2ps nil #x2a :mem-only t))
+
+;;; Instructions having a general-purpose register as the destination
+;;; operand and an XMM register or a memory location as the source
+;;; operand. The operand size is calculated from the destination
+;;; operand.
+
+(macrolet ((define-gpr-destination-sse-inst (name prefix opcode &key reg-only)
+ `(define-instruction ,name (segment dst src)
+ (:printer-list
+ ',(sse-inst-printer-list 'reg-xmm/mem prefix opcode))
+ (:emitter
+ (aver (register-p dst))
+ ,(when reg-only
+ `(aver (xmm-register-p src)))
+ (let ((dst-size (operand-size dst)))
+ (aver (or (eq dst-size :qword) (eq dst-size :dword)))
+ (emit-sse-inst segment dst src ,prefix ,opcode
+ :operand-size dst-size))))))
+ (define-gpr-destination-sse-inst cvtsd2si #xf2 #x2d)
+ (define-gpr-destination-sse-inst cvtss2si #xf3 #x2d)
+ (define-gpr-destination-sse-inst cvttsd2si #xf2 #x2c)
+ (define-gpr-destination-sse-inst cvttss2si #xf3 #x2c)
+ (define-gpr-destination-sse-inst movmskpd #x66 #x50 :reg-only t)
+ (define-gpr-destination-sse-inst movmskps nil #x50 :reg-only t)
+ (define-gpr-destination-sse-inst pmovmskb #x66 #xd7 :reg-only t))
+
+;;;; We call these "2byte" instructions due to their two opcode bytes.
+;;;; Intel and AMD call them three-byte instructions, as they count the
+;;;; 0x0f byte for determining the number of opcode bytes.
+
+;;; Instructions that take XMM-XMM/MEM and XMM-XMM/MEM-IMM arguments.
+
+(macrolet ((regular-2byte-sse-inst (name prefix op1 op2)
+ `(define-instruction ,name (segment dst src)
+ (:printer-list
+ ',(2byte-sse-inst-printer-list '2byte-xmm-xmm/mem prefix op1 op2))
+ (:emitter
+ (emit-regular-2byte-sse-inst segment dst src ,prefix ,op1 ,op2))))
+ (regular-2byte-sse-inst-imm (name prefix op1 op2)
+ `(define-instruction ,name (segment dst src imm)
+ (:printer-list
+ ',(2byte-sse-inst-printer-list '2byte-xmm-xmm/mem prefix op1 op2
+ :more-fields '((imm nil :type imm-byte))
+ :printer `(:name :tab reg ", " reg/mem ", " imm)))
+ (:emitter
+ (aver (typep imm '(unsigned-byte 8)))
+ (emit-regular-2byte-sse-inst segment dst src ,prefix ,op1 ,op2
+ :remaining-bytes 1)
+ (emit-byte segment imm)))))
+ (regular-2byte-sse-inst pshufb #x66 #x38 #x00)
+ (regular-2byte-sse-inst phaddw #x66 #x38 #x01)
+ (regular-2byte-sse-inst phaddd #x66 #x38 #x02)
+ (regular-2byte-sse-inst phaddsw #x66 #x38 #x03)
+ (regular-2byte-sse-inst pmaddubsw #x66 #x38 #x04)
+ (regular-2byte-sse-inst phsubw #x66 #x38 #x05)
+ (regular-2byte-sse-inst phsubd #x66 #x38 #x06)
+ (regular-2byte-sse-inst phsubsw #x66 #x38 #x07)
+ (regular-2byte-sse-inst psignb #x66 #x38 #x08)
+ (regular-2byte-sse-inst psignw #x66 #x38 #x09)
+ (regular-2byte-sse-inst psignd #x66 #x38 #x0a)
+ (regular-2byte-sse-inst pmulhrsw #x66 #x38 #x0b)
+
+ (regular-2byte-sse-inst ptest #x66 #x38 #x17)
+ (regular-2byte-sse-inst pabsb #x66 #x38 #x1c)
+ (regular-2byte-sse-inst pabsw #x66 #x38 #x1d)
+ (regular-2byte-sse-inst pabsd #x66 #x38 #x1e)
+
+ (regular-2byte-sse-inst pmuldq #x66 #x38 #x28)
+ (regular-2byte-sse-inst pcmpeqq #x66 #x38 #x29)
+ (regular-2byte-sse-inst packusdw #x66 #x38 #x2b)
+
+ (regular-2byte-sse-inst pcmpgtq #x66 #x38 #x37)
+ (regular-2byte-sse-inst pminsb #x66 #x38 #x38)
+ (regular-2byte-sse-inst pminsd #x66 #x38 #x39)
+ (regular-2byte-sse-inst pminuw #x66 #x38 #x3a)
+ (regular-2byte-sse-inst pminud #x66 #x38 #x3b)
+ (regular-2byte-sse-inst pmaxsb #x66 #x38 #x3c)
+ (regular-2byte-sse-inst pmaxsd #x66 #x38 #x3d)
+ (regular-2byte-sse-inst pmaxuw #x66 #x38 #x3e)
+ (regular-2byte-sse-inst pmaxud #x66 #x38 #x3f)
+
+ (regular-2byte-sse-inst pmulld #x66 #x38 #x40)
+ (regular-2byte-sse-inst phminposuw #x66 #x38 #x41)
+
+ (regular-2byte-sse-inst aesimc #x66 #x38 #xdb)
+ (regular-2byte-sse-inst aesenc #x66 #x38 #xdc)
+ (regular-2byte-sse-inst aesenclast #x66 #x38 #xdd)
+ (regular-2byte-sse-inst aesdec #x66 #x38 #xde)
+ (regular-2byte-sse-inst aesdeclast #x66 #x38 #xdf)
+
+ (regular-2byte-sse-inst pmovsxbw #x66 #x38 #x20)
+ (regular-2byte-sse-inst pmovsxbd #x66 #x38 #x21)
+ (regular-2byte-sse-inst pmovsxbq #x66 #x38 #x22)
+ (regular-2byte-sse-inst pmovsxwd #x66 #x38 #x23)
+ (regular-2byte-sse-inst pmovsxwq #x66 #x38 #x24)
+ (regular-2byte-sse-inst pmovsxdq #x66 #x38 #x25)
+
+ (regular-2byte-sse-inst pmovzxbw #x66 #x38 #x30)
+ (regular-2byte-sse-inst pmovzxbd #x66 #x38 #x31)
+ (regular-2byte-sse-inst pmovzxbq #x66 #x38 #x32)
+ (regular-2byte-sse-inst pmovzxwd #x66 #x38 #x33)
+ (regular-2byte-sse-inst pmovzxwq #x66 #x38 #x34)
+ (regular-2byte-sse-inst pmovzxdq #x66 #x38 #x35)
+
+ (regular-2byte-sse-inst-imm roundps #x66 #x3a #x08)
+ (regular-2byte-sse-inst-imm roundpd #x66 #x3a #x09)
+ (regular-2byte-sse-inst-imm roundss #x66 #x3a #x0a)
+ (regular-2byte-sse-inst-imm roundsd #x66 #x3a #x0b)
+ (regular-2byte-sse-inst-imm blendps #x66 #x3a #x0c)
+ (regular-2byte-sse-inst-imm blendpd #x66 #x3a #x0d)
+ (regular-2byte-sse-inst-imm pblendw #x66 #x3a #x0e)
+ (regular-2byte-sse-inst-imm palignr #x66 #x3a #x0f)
+ (regular-2byte-sse-inst-imm dpps #x66 #x3a #x40)
+ (regular-2byte-sse-inst-imm dppd #x66 #x3a #x41)
+
+ (regular-2byte-sse-inst-imm mpsadbw #x66 #x3a #x42)
+ (regular-2byte-sse-inst-imm pclmulqdq #x66 #x3a #x44)
+
+ (regular-2byte-sse-inst-imm pcmpestrm #x66 #x3a #x60)
+ (regular-2byte-sse-inst-imm pcmpestri #x66 #x3a #x61)
+ (regular-2byte-sse-inst-imm pcmpistrm #x66 #x3a #x62)
+ (regular-2byte-sse-inst-imm pcmpistri #x66 #x3a #x63)
+
+ (regular-2byte-sse-inst-imm aeskeygenassist #x66 #x3a #xdf))
+
+;;; Other SSE instructions
+
+;; Instructions implicitly using XMM0 as a mask
+(macrolet ((define-sse-inst-implicit-mask (name prefix op1 op2)
+ `(define-instruction ,name (segment dst src mask)
+ (:printer-list
+ ',(2byte-sse-inst-printer-list
+ '2byte-xmm-xmm/mem prefix op1 op2
+ :printer '(:name :tab reg ", " reg/mem ", XMM0")))
+ (:emitter
+ (aver (xmm-register-p dst))
+ (aver (and (xmm-register-p mask) (= (tn-offset mask) 0)))
+ (emit-regular-2byte-sse-inst segment dst src ,prefix ,op1 ,op2)))))
+
+ (define-sse-inst-implicit-mask pblendvb #x66 #x38 #x10)
+ (define-sse-inst-implicit-mask blendvps #x66 #x38 #x14)
+ (define-sse-inst-implicit-mask blendvpd #x66 #x38 #x15))
+
+;; FIXME: is that right!?
+(define-instruction movnti (segment dst src)
+ (:printer ext-reg-reg/mem-no-width ((op #xc3)))
+ (:emitter
+ (aver (not (or (register-p dst)
+ (xmm-register-p dst))))
+ (aver (register-p src))
(maybe-emit-rex-for-ea segment src dst)
(emit-byte segment #x0f)
- (emit-byte segment #x59)
- (emit-ea segment src (reg-tn-encoding dst))))
+ (emit-byte segment #xc3)
+ (emit-ea segment dst (reg-tn-encoding src))))
+
+(define-instruction prefetch (segment type src)
+ (:printer ext-reg/mem-no-width ((op '(#x18 0)))
+ '("PREFETCHNTA" :tab reg/mem))
+ (:printer ext-reg/mem-no-width ((op '(#x18 1)))
+ '("PREFETCHT0" :tab reg/mem))
+ (:printer ext-reg/mem-no-width ((op '(#x18 2)))
+ '("PREFETCHT1" :tab reg/mem))
+ (:printer ext-reg/mem-no-width ((op '(#x18 3)))
+ '("PREFETCHT2" :tab reg/mem))
+ (:emitter
+ (aver (not (or (register-p src)
+ (xmm-register-p src))))
+ (aver (eq (operand-size src) :byte))
+ (let ((type (position type #(:nta :t0 :t1 :t2))))
+ (aver type)
+ (maybe-emit-rex-for-ea segment src nil)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x18)
+ (emit-ea segment src type))))
-(define-instruction subsd (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+(define-instruction clflush (segment src)
+ (:printer ext-reg/mem-no-width ((op '(#xae 7))))
(:emitter
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
+ (aver (not (or (register-p src)
+ (xmm-register-p src))))
+ (aver (eq (operand-size src) :byte))
+ (maybe-emit-rex-for-ea segment src nil)
(emit-byte segment #x0f)
- (emit-byte segment #x5c)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction subss (segment dst src)
-; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
+ (emit-byte segment #xae)
+ (emit-ea segment src 7)))
+
+(macrolet ((define-fence-instruction (name last-byte)
+ `(define-instruction ,name (segment)
+ (:printer three-bytes ((op '(#x0f #xae ,last-byte))))
+ (:emitter
+ (emit-byte segment #x0f)
+ (emit-byte segment #xae)
+ (emit-byte segment ,last-byte)))))
+ (define-fence-instruction lfence #b11101000)
+ (define-fence-instruction mfence #b11110000)
+ (define-fence-instruction sfence #b11111000))
+
+(define-instruction pause (segment)
+ (:printer two-bytes ((op '(#xf3 #x90))))
(:emitter
(emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x5c)
- (emit-ea segment src (reg-tn-encoding dst))))
+ (emit-byte segment #x90)))
(define-instruction ldmxcsr (segment src)
+ (:printer ext-reg/mem-no-width ((op '(#xae 2))))
(:emitter
+ (aver (not (or (register-p src)
+ (xmm-register-p src))))
+ (aver (eq (operand-size src) :dword))
+ (maybe-emit-rex-for-ea segment src nil)
(emit-byte segment #x0f)
(emit-byte segment #xae)
(emit-ea segment src 2)))
-
+
(define-instruction stmxcsr (segment dst)
+ (:printer ext-reg/mem-no-width ((op '(#xae 3))))
(:emitter
+ (aver (not (or (register-p dst)
+ (xmm-register-p dst))))
+ (aver (eq (operand-size dst) :dword))
+ (maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment #x0f)
(emit-byte segment #xae)
(emit-ea segment dst 3)))
+(define-instruction popcnt (segment dst src)
+ (:printer-list `((f3-escape-reg-reg/mem ((op #xB8)))
+ (rex-f3-escape-reg-reg/mem ((op #xB8)))))
+ (:emitter
+ (aver (register-p dst))
+ (aver (and (register-p dst) (not (eq (operand-size dst) :byte))))
+ (aver (not (eq (operand-size src) :byte)))
+ (emit-sse-inst segment dst src #xf3 #xb8)))
+
+(define-instruction crc32 (segment dst src)
+ (:printer-list
+ `(,@(mapcan (lambda (op2)
+ (mapcar (lambda (instfmt)
+ `(,instfmt ((prefix (#xf2)) (op1 (#x38))
+ (op2 (,op2)))))
+ '(ext-rex-2byte-prefix-reg-reg/mem
+ ext-2byte-prefix-reg-reg/mem)))
+ '(#xf0 #xf1))))
+ (:emitter
+ (let ((dst-size (operand-size dst)))
+ (aver (and (register-p dst) (not (or (eq dst-size :word)
+ (eq dst-size :byte)))))
+ (if (eq (operand-size src) :byte)
+ (emit-sse-inst-2byte segment dst src #xf2 #x38 #xf0)
+ (emit-sse-inst-2byte segment dst src #xf2 #x38 #xf1)))))
+
+;;;; Miscellany
+
+(define-instruction cpuid (segment)
+ (:printer two-bytes ((op '(#b00001111 #b10100010))))
+ (:emitter
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10100010)))
+
+(define-instruction rdtsc (segment)
+ (:printer two-bytes ((op '(#b00001111 #b00110001))))
+ (:emitter
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b00110001)))
+
+;;;; Late VM definitions
+
+(defun canonicalize-inline-constant (constant &aux (alignedp nil))
+ (let ((first (car constant)))
+ (when (eql first :aligned)
+ (setf alignedp t)
+ (pop constant)
+ (setf first (car constant)))
+ (typecase first
+ (single-float (setf constant (list :single-float first)))
+ (double-float (setf constant (list :double-float first)))
+ ((complex single-float)
+ (setf constant (list :complex-single-float first)))
+ ((complex double-float)
+ (setf constant (list :complex-double-float first)))
+ #!+sb-simd-pack
+ (#+sb-xc-host nil
+ #-sb-xc-host simd-pack
+ (setf constant (list :sse (logior (%simd-pack-low first)
+ (ash (%simd-pack-high first)
+ 64)))))))
+ (destructuring-bind (type value) constant
+ (ecase type
+ ((:byte :word :dword :qword)
+ (aver (integerp value))
+ (cons type value))
+ ((:base-char)
+ (aver (base-char-p value))
+ (cons :byte (char-code value)))
+ ((:character)
+ (aver (characterp value))
+ (cons :dword (char-code value)))
+ ((:single-float)
+ (aver (typep value 'single-float))
+ (cons (if alignedp :oword :dword)
+ (ldb (byte 32 0) (single-float-bits value))))
+ ((:double-float)
+ (aver (typep value 'double-float))
+ (cons (if alignedp :oword :qword)
+ (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
+ (double-float-low-bits value)))))
+ ((:complex-single-float)
+ (aver (typep value '(complex single-float)))
+ (cons (if alignedp :oword :qword)
+ (ldb (byte 64 0)
+ (logior (ash (single-float-bits (imagpart value)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart value)))))))
+ ((:oword :sse)
+ (aver (integerp value))
+ (cons :oword value))
+ ((:complex-double-float)
+ (aver (typep value '(complex double-float)))
+ (cons :oword
+ (logior (ash (double-float-high-bits (imagpart value)) 96)
+ (ash (double-float-low-bits (imagpart value)) 64)
+ (ash (ldb (byte 32 0)
+ (double-float-high-bits (realpart value)))
+ 32)
+ (double-float-low-bits (realpart value))))))))
+
+(defun inline-constant-value (constant)
+ (let ((label (gen-label))
+ (size (ecase (car constant)
+ ((:byte :word :dword :qword) (car constant))
+ ((:oword) :qword))))
+ (values label (make-ea size
+ :disp (make-fixup nil :code-object label)))))
+
+(defun emit-constant-segment-header (segment constants optimize)
+ (declare (ignore constants))
+ (emit-long-nop segment (if optimize 64 16)))
+
+(defun size-nbyte (size)
+ (ecase size
+ (:byte 1)
+ (:word 2)
+ (:dword 4)
+ (:qword 8)
+ (:oword 16)))
+
+(defun sort-inline-constants (constants)
+ (stable-sort constants #'> :key (lambda (constant)
+ (size-nbyte (caar constant)))))
+
+(defun emit-inline-constant (constant label)
+ (let ((size (size-nbyte (car constant))))
+ (emit-alignment (integer-length (1- size)))
+ (emit-label label)
+ (let ((val (cdr constant)))
+ (loop repeat size
+ do (inst byte (ldb (byte 8 0) val))
+ (setf val (ash val -8))))))
projects / sbcl.git / blobdiff