;;; 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)))
;;; 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 stream dstate)))
+
+;; Same as print-xmmreg/mem, but prints an explicit size indicator for
+;; memory references.
+(defun print-sized-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 (inst-operand-size dstate) 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/mem
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-xmmreg/mem)
+
+(sb!disassem:define-arg-type sized-xmmreg/mem
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-sized-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
(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))
(imm))
;;; A one-byte instruction with a #x66 prefix, used to indicate an
-;;; operand size of :word.
+;;; operand size of :word.
(sb!disassem:define-instruction-format (x66-byte 16
:default-printer '(:name))
(x66 :field (byte 8 0) :value #x66)
;;; 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))
+ :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 'rex-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))
+ :default-printer '(:name :tab reg))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
- (op :field (byte 5 11))
+ (op :field (byte 5 11))
(reg :field (byte 3 8) :type 'reg-b)
;; optional fields
(accum :type 'accum)
;;; 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
+ :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)
+ :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))
+ :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)
+ (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 19) :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)))
+ :include 'rex-reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
(op :field (byte 6 10))
(dir :field (byte 1 9)))
+(sb!disassem:define-instruction-format (x66-reg-reg/mem-dir 24
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ (x66 :field (byte 8 0) :type 'x66 :value #x66)
+ (op :field (byte 6 10))
+ (dir :field (byte 1 9))
+ (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))
+
+(sb!disassem:define-instruction-format (x66-rex-reg-reg/mem-dir 32
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ (x66 :field (byte 8 0) :type 'x66 :value #x66)
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (op :field (byte 6 18))
+ (dir :field (byte 1 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))
+
;;; 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)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (rex-reg/mem 24
- :default-printer '(:name :tab reg/mem))
+ :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)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
:type 'sized-reg/mem)
;; optional fields
: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))
+ :type 'sized-reg/mem-default-qword))
(sb!disassem:define-instruction-format (rex-reg/mem-default-qword 24
:default-printer '(:name :tab reg/mem))
;;; 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))
+ :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 'rex-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))
(sb!disassem:define-instruction-format (rex-accum-reg/mem 24
:include 'rex-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))
+ :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))
+ :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)
+ (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)
- ;; optional fields
- (imm))
+ :type 'reg/mem)
+ (reg :field (byte 3 27) :type 'reg))
;;; 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))
\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))
+
+(sb!disassem:define-instruction-format (rex-xmm-xmm/mem 32
+ :default-printer
+ '(:name :tab reg ", " reg/mem))
+ (x0f :field (byte 8 0) :value #x0f)
+ (rex :field (byte 4 12) :value #b0100)
+ (wrxb :field (byte 4 8) :type 'wrxb)
+ (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))
+
+(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))
+
+(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))
+
+;;; 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 general-
+;;; -purpose register or a memory location as the other operand.
+
+(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))
+
+(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))
+
+;;; 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 (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 'sized-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 'sized-xmmreg/mem)
+ (reg :field (byte 3 35) :type 'reg))
(sb!disassem:define-instruction-format (string-op 8
- :include 'simple
- :default-printer '(:name width)))
+ :include 'simple
+ :default-printer '(:name width)))
(sb!disassem:define-instruction-format (rex-string-op 16
- :include 'rex-simple
- :default-printer '(:name width)))
+ :include 'rex-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 27) :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)))
+
\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))))
+ (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)
;; AMD64 doesn't currently have a code object register to use as a
;; 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 (- (+ offset posn)))))))
(values))
(defun emit-label-rip (segment fixup reg)
;; 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))))))
(values))
(defun emit-ea (segment thing reg &optional allow-constants)
;; 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 (- (* (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-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))))
(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 (= 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))
(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
;; to hack up the code
(case (sc-name (tn-sc thing))
(#.*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)
(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
;;;; 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)))
+ (:printer x66-reg-reg/mem-dir ((op #b100010)))
+ (:printer x66-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))))
(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) 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))))))
(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)))
+ (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)
+ ;; REX prefix is needed if SRC is SIL, DIL, SPL or BPL.
+ (maybe-emit-rex-for-ea segment src dst :operand-size :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)))))))))
+ (:byte
+ (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
+ (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 dst-size)
+ (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)))))))))
(define-instruction movsx (segment dst src)
(:printer ext-reg-reg/mem-no-width
(: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))))))))
+ (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 t))))))))
(define-instruction pop (segment dst)
(:printer reg-no-width-default-qword ((op #b01011)))
(: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))))))
+ (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.
(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)))
(:emitter
(aver (or (dword-reg-p dst) (qword-reg-p dst)))
(maybe-emit-rex-for-ea segment src dst
- :operand-size :qword)
+ :operand-size :qword)
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
;;;; 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)
+ (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))))
((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)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000000 #b00000001)))
(emit-ea segment dst (reg-tn-encoding src) 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)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000010 #b00000011)))
(emit-ea segment src (reg-tn-encoding dst) allow-constants))
(t
(error "bogus operands to ~A" name)))))
;; 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)))
+ (imm nil :type signed-imm-byte)))
(rex-reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
(imm nil :type signed-imm-byte)))
(reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
(: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))))
+ (:printer rex-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))))
+ (:printer rex-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))))
(: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))
+ '(: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))
+ (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))
+ '(: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))))
(maybe-emit-operand-size-prefix segment :dword)
(emit-byte segment #b10011000)))
-;;; CDQE -- Convert Word To Double Word Extended. RAX <- sign_xtnd(EAX)
+;;; CDQE -- Convert Double Word To Quad Word Extended. RAX <- sign_xtnd(EAX)
(define-instruction cdqe (segment)
(:printer rex-byte ((op #b10011000)))
(:emitter
(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"))
+ (: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))
+ (: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)))
+ (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))))
(defun double-shift-inst-printer-list (op)
`(#+nil
(ext-reg-reg/mem-imm ((op ,(logior op #b100))
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(ext-reg-reg/mem ((op ,(logior op #b101)))
- (:name :tab reg/mem ", " 'cl)))))
+ (:name :tab reg/mem ", " 'cl)))))
(define-instruction shld (segment dst src amt)
(:declare (type (or (member :cl) (mod 32)) amt))
(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)))))))
(define-instruction or (segment dst src)
(:printer-list
(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)
(: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))
(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)))))
+ (emit-byte segment #b11000010)
+ (emit-word segment stack-delta))
+ (t
+ (emit-byte segment #b11000011)))))
(define-instruction jecxz (segment target)
(:printer short-jump ((op #b0011)))
(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-ub8-from-system-area sap (1+ offset)
+ (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))))))))
+ (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)
;; 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)
+ (case #!-darwin (byte-imm-code chunk dstate)
+ #!+darwin (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)
+ #!-darwin (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+ :control #'break-control)
+ #!+darwin (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
+ :control #'break-control)
+ (:emitter
+ #!-darwin (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
+ #!+darwin (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
(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.
-
-;;; 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
- (: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))))))
-
+;;;; Instructions required to do floating point operations using SSE
+
+(defun emit-sse-inst (segment dst src prefix opcode &key operand-size)
+ (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)))
+
+;;; 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)
+ (aver (xmm-register-p dst))
+ (emit-sse-inst segment dst src prefix opcode
+ :operand-size :do-not-set))
+
+;;; 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)
+ ,@(if prefix
+ `((:printer ext-xmm-xmm/mem
+ ((prefix ,prefix) (op ,opcode)))
+ (:printer ext-rex-xmm-xmm/mem
+ ((prefix ,prefix) (op ,opcode))))
+ `((:printer xmm-xmm/mem ((op ,opcode)))
+ (:printer rex-xmm-xmm/mem ((op ,opcode)))))
+ (:emitter
+ (emit-regular-sse-inst segment dst src ,prefix ,opcode)))))
+ ;; logical
+ (define-regular-sse-inst andpd #x66 #x54)
+ (define-regular-sse-inst andps nil #x54)
+ (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)
+ ;; arithmetic
+ (define-regular-sse-inst addsd #xf2 #x58)
+ (define-regular-sse-inst addss #xf3 #x58)
+ (define-regular-sse-inst divsd #xf2 #x5e)
+ (define-regular-sse-inst divss #xf3 #x5e)
+ (define-regular-sse-inst mulsd #xf2 #x59)
+ (define-regular-sse-inst mulss #xf3 #x59)
+ (define-regular-sse-inst subsd #xf2 #x5c)
+ (define-regular-sse-inst subss #xf3 #x5c)
+ (define-regular-sse-inst sqrtsd #xf2 #x51)
+ (define-regular-sse-inst sqrtss #xf3 #x51)
+ ;; conversion
+ (define-regular-sse-inst cvtsd2ss #xf2 #x5a)
+ (define-regular-sse-inst cvtss2sd #xf3 #x5a)
+ (define-regular-sse-inst cvtdq2pd #xf3 #xe6)
+ (define-regular-sse-inst cvtdq2ps nil #x5b))
+
+;;; MOVSD, MOVSS
+(macrolet ((define-movsd/ss-sse-inst (name prefix)
+ `(define-instruction ,name (segment dst src)
+ (:printer ext-xmm-xmm/mem-dir ((prefix ,prefix)
+ (op #b0001000)))
+ (:printer ext-rex-xmm-xmm/mem-dir ((prefix ,prefix)
+ (op #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))
+
+;;; 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)
- (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 subsd (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 #x5c)
- (emit-ea segment src (reg-tn-encoding dst))))
-
-(define-instruction subss (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 #x5c)
- (emit-ea segment src (reg-tn-encoding dst))))
+ (:printer ext-xmm-xmm/mem ((prefix #xf3) (op #x7e)))
+ (:printer ext-rex-xmm-xmm/mem ((prefix #xf3) (op #x7e)))
+ (:printer ext-xmm-xmm/mem ((prefix #x66) (op #xd6))
+ '(:name :tab reg/mem ", " reg))
+ (:printer ext-rex-xmm-xmm/mem ((prefix #x66) (op #xd6))
+ '(: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 ext-xmm-reg/mem ((prefix #x66) (op #x6e)))
+ (:printer ext-rex-xmm-reg/mem ((prefix #x66) (op #x6e)))
+ (:printer ext-xmm-reg/mem ((prefix #x66) (op #x7e))
+ '(:name :tab reg/mem ", " reg))
+ (:printer ext-rex-xmm-reg/mem ((prefix #x66) (op #x7e))
+ '(: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-integer-source-sse-inst (name prefix opcode)
+ `(define-instruction ,name (segment dst src)
+ (:printer ext-xmm-reg/mem ((prefix ,prefix) (op ,opcode)))
+ (:printer ext-rex-xmm-reg/mem ((prefix ,prefix) (op ,opcode)))
+ (:emitter
+ (aver (xmm-register-p dst))
+ (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))
+
+;;; 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)
+ `(define-instruction ,name (segment dst src)
+ (:printer ext-reg-xmm/mem ((prefix ,prefix) (op ,opcode)))
+ (:printer ext-rex-reg-xmm/mem ((prefix ,prefix) (op ,opcode)))
+ (:emitter
+ (aver (register-p dst))
+ (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))
+
+;;; Other SSE instructions
(define-instruction ldmxcsr (segment src)
(:emitter
(emit-byte segment #x0f)
(emit-byte segment #xae)
(emit-ea segment src 2)))
-
+
(define-instruction stmxcsr (segment dst)
(:emitter
(emit-byte segment #x0f)
(emit-byte segment #xae)
(emit-ea segment dst 3)))
-