X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Finsts.lisp;h=794c90d23ae9bab6dbeaf36f507c3e33e5e6a23f;hb=08917ec0d00a781a1089922a5419b7f136cdf08f;hp=12cc5bfa5f7545c253112efc361381f8d513c63a;hpb=0bca0cb1bf5ce5572ab5cd7ba59f87fed1f2edb0;p=sbcl.git diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 12cc5bf..794c90d 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -19,12 +19,14 @@ (setf sb!disassem:*disassem-inst-alignment-bytes* 1) (deftype reg () '(unsigned-byte 3)) + +(def!constant +default-operand-size+ :dword) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (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 *default-address-size* @@ -38,52 +40,86 @@ (defparameter *dword-reg-names* #(eax ecx edx ebx esp ebp esi edi)) +;;; Disassembling x86 code needs to take into account little things +;;; like instructions that have a byte/word length bit in their +;;; encoding, prefixes to change the default word length for a single +;;; instruction, and so on. Unfortunately, there is no easy way with +;;; this disassembler framework to handle prefixes that will work +;;; correctly in all cases, so we copy the x86-64 version which at +;;; least can handle the code output by the compiler. +;;; +;;; Width information for an instruction is stored as an inst-prop on +;;; the dstate. The inst-props are cleared automatically after each +;;; instruction, must be set by prefilters, and contain a single bit +;;; of data each (presence/absence). As such, each instruction that +;;; can emit an operand-size prefix (x66 prefix) needs to have a set +;;; of printers declared for both the prefixed and non-prefixed +;;; encodings. + +;;; Return the operand size based on the prefixes and width bit from +;;; the dstate. +(defun inst-operand-size (dstate) + (declare (type sb!disassem:disassem-state dstate)) + (cond ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-8) + :byte) + ((sb!disassem:dstate-get-inst-prop dstate 'operand-size-16) + :word) + (t + +default-operand-size+))) + +;;; Return the operand size for a "word-sized" operand based on the +;;; prefixes from the dstate. +(defun inst-word-operand-size (dstate) + (declare (type sb!disassem:disassem-state dstate)) + (if (sb!disassem:dstate-get-inst-prop dstate 'operand-size-16) + :word + :dword)) + (defun print-reg-with-width (value width stream dstate) (declare (ignore dstate)) (princ (aref (ecase width - (:byte *byte-reg-names*) - (:word *word-reg-names*) - (:dword *dword-reg-names*)) - value) - stream) + (:byte *byte-reg-names*) + (:word *word-reg-names*) + (:dword *dword-reg-names*)) + value) + stream) ;; XXX plus should do some source-var notes ) (defun print-reg (value stream dstate) (declare (type 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 - (sb!disassem:dstate-get-prop dstate 'width) - stream - dstate)) + (inst-operand-size dstate) + stream + dstate)) (defun print-word-reg (value stream dstate) (declare (type 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 - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+) - stream - dstate)) + (inst-word-operand-size dstate) + stream + dstate)) (defun print-byte-reg (value stream dstate) (declare (type 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 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)) (defun print-reg/mem (value stream dstate) (declare (type (or list reg) value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) + (type stream stream) + (type sb!disassem:disassem-state dstate)) (if (typep value 'reg) (print-reg value stream dstate) (print-mem-access value stream nil dstate))) @@ -92,20 +128,28 @@ ;; memory references. (defun print-sized-reg/mem (value stream dstate) (declare (type (or list reg) value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) + (type stream stream) + (type sb!disassem:disassem-state dstate)) (if (typep value 'reg) (print-reg value stream dstate) (print-mem-access value stream t dstate))) (defun print-byte-reg/mem (value stream dstate) (declare (type (or list reg) value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) + (type stream stream) + (type sb!disassem:disassem-state dstate)) (if (typep value 'reg) (print-byte-reg value stream dstate) (print-mem-access value stream t dstate))) +(defun print-word-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type sb!disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-word-reg value stream dstate) + (print-mem-access value stream nil dstate))) + (defun print-label (value stream dstate) (declare (ignore dstate)) (sb!disassem:princ16 value stream)) @@ -116,65 +160,66 @@ ;;; obvious default value (e.g., 1 for the index-scale). (defun prefilter-reg/mem (value dstate) (declare (type list value) - (type sb!disassem:disassem-state dstate)) + (type sb!disassem:disassem-state dstate)) (let ((mod (car value)) - (r/m (cadr value))) + (r/m (cadr value))) (declare (type (unsigned-byte 2) mod) - (type (unsigned-byte 3) r/m)) + (type (unsigned-byte 3) r/m)) (cond ((= mod #b11) - ;; registers - r/m) - ((= 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 (if (and (= mod #b00) (= base-reg #b101)) nil base-reg) - offset - (if (= index-reg #b100) nil index-reg) - (ash 1 index-scale)))))) - ((and (= mod #b00) (= r/m #b101)) - (list nil (sb!disassem:read-signed-suffix 32 dstate)) ) - ((= mod #b00) - (list r/m)) - ((= mod #b01) - (list r/m (sb!disassem:read-signed-suffix 8 dstate))) - (t ; (= mod #b10) - (list r/m (sb!disassem:read-signed-suffix 32 dstate)))))) + ;; registers + r/m) + ((= 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 (if (and (= mod #b00) (= base-reg #b101)) nil base-reg) + offset + (if (= index-reg #b100) nil index-reg) + (ash 1 index-scale)))))) + ((and (= mod #b00) (= r/m #b101)) + (list nil (sb!disassem:read-signed-suffix 32 dstate)) ) + ((= mod #b00) + (list r/m)) + ((= mod #b01) + (list r/m (sb!disassem:read-signed-suffix 8 dstate))) + (t ; (= mod #b10) + (list r/m (sb!disassem:read-signed-suffix 32 dstate)))))) ;;; This is a sort of bogus prefilter that just stores the info globally for ;;; other people to use; it probably never gets printed. (defun prefilter-width (value dstate) - (setf (sb!disassem:dstate-get-prop dstate 'width) - (if (zerop value) - :byte - (let ((word-width - ;; set by a prefix instruction - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+))) - (when (not (eql word-width +default-operand-size+)) - ;; Reset it. - (setf (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+)) - word-width)))) + (declare (type bit value) + (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)) (defun read-address (value dstate) - (declare (ignore value)) ; always nil anyway + (declare (ignore value)) ; always nil anyway (sb!disassem:read-suffix (width-bits *default-address-size*) dstate)) (defun width-bits (width) @@ -193,22 +238,22 @@ :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 word-accum :printer (lambda (value stream dstate) - (declare (ignore value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) - (print-word-reg 0 stream dstate))) + (declare (ignore value) + (type stream stream) + (type sb!disassem:disassem-state dstate)) + (print-word-reg 0 stream dstate))) (sb!disassem:define-arg-type reg :printer #'print-reg) @@ -225,40 +270,44 @@ (sb!disassem:define-arg-type imm-data :prefilter (lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-suffix - (width-bits (sb!disassem:dstate-get-prop dstate 'width)) - dstate))) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-suffix + (width-bits (inst-operand-size dstate)) + dstate))) (sb!disassem:define-arg-type signed-imm-data :prefilter (lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (let ((width (sb!disassem:dstate-get-prop dstate 'width))) - (sb!disassem:read-signed-suffix (width-bits width) dstate)))) + (declare (ignore value)) ; always nil anyway + (let ((width (inst-operand-size dstate))) + (sb!disassem:read-signed-suffix (width-bits width) dstate)))) (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 signed-imm-dword :prefilter (lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-signed-suffix 32 dstate))) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-signed-suffix 32 dstate))) (sb!disassem:define-arg-type imm-word :prefilter (lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (let ((width - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+))) - (sb!disassem:read-suffix (width-bits width) dstate)))) + (declare (ignore value)) ; always nil anyway + (let ((width (inst-word-operand-size dstate))) + (sb!disassem:read-suffix (width-bits width) dstate)))) + +(sb!disassem:define-arg-type signed-imm-word + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width (inst-word-operand-size dstate))) + (sb!disassem:read-signed-suffix (width-bits width) 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 @@ -271,9 +320,12 @@ (sb!disassem:define-arg-type byte-reg/mem :prefilter #'prefilter-reg/mem :printer #'print-byte-reg/mem) +(sb!disassem:define-arg-type word-reg/mem + :prefilter #'prefilter-reg/mem + :printer #'print-word-reg/mem) ;;; added by jrd -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun print-fp-reg (value stream dstate) (declare (ignore dstate)) (format stream "FR~D" value)) @@ -283,21 +335,19 @@ value) ) ; EVAL-WHEN (sb!disassem:define-arg-type fp-reg - :prefilter #'prefilter-fp-reg - :printer #'print-fp-reg) + :prefilter #'prefilter-fp-reg + :printer #'print-fp-reg) (sb!disassem:define-arg-type width :prefilter #'prefilter-width :printer (lambda (value stream dstate) - (if;; (zerop value) - (or (null value) - (and (numberp value) (zerop value))) ; zzz jrd - (princ 'b stream) - (let ((word-width - ;; set by a prefix instruction - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+))) - (princ (schar (symbol-name word-width) 0) stream))))) + (declare (ignore value)) + (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) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *conditions* @@ -321,7 +371,7 @@ (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 @@ -341,8 +391,8 @@ (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)) @@ -357,30 +407,61 @@ (accum :type 'accum) (imm)) +(sb!disassem:define-instruction-format (x66-simple 16) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (op :field (byte 7 9)) + (width :field (byte 1 8) :type 'width) + ;; optional fields + (accum :type 'accum) + (imm)) + +(sb!disassem:define-instruction-format (two-bytes 16 + :default-printer '(:name)) + (op :fields (list (byte 8 0) (byte 8 8)))) + ;;; Same as simple, but with direction bit (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple) (op :field (byte 6 2)) (dir :field (byte 1 1))) +(sb!disassem:define-instruction-format (x66-simple-dir 16 :include 'x66-simple) + (op :field (byte 6 10)) + (dir :field (byte 1 9))) + ;;; 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 'imm-data)) + +(sb!disassem:define-instruction-format (x66-accum-imm 16 + :include 'x66-simple + :default-printer '(:name + :tab accum ", " imm)) (imm :type '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 'word-reg) ;; optional fields (accum :type 'word-accum) (imm)) +(sb!disassem:define-instruction-format (x66-reg-no-width 16 + :default-printer '(:name :tab reg)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (op :field (byte 5 11)) + (reg :field (byte 3 8) :type 'word-reg) + ;; optional fields + (accum :type 'word-accum) + (imm)) + ;;; adds a width field to reg-no-width (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) @@ -389,52 +470,101 @@ (imm) ) +(sb!disassem:define-instruction-format (x66-reg 16 + :default-printer '(:name :tab reg)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (op :field (byte 4 12)) + (width :field (byte 1 11) :type 'width) + (reg :field (byte 3 8) :type 'reg) + ;; optional fields + (accum :type 'accum) + (imm) + ) + ;;; Same as reg, but with direction bit (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg) (op :field (byte 3 5)) (dir :field (byte 1 4))) (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 (x66-reg-reg/mem 24 + :default-printer + `(:name :tab reg ", " reg/mem)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (op :field (byte 7 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) ;; 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 (x66-reg-reg/mem-dir 24 + :include 'x66-reg-reg/mem + :default-printer + `(:name + :tab + ,(swap-if 'dir 'reg/mem ", " 'reg))) + (op :field (byte 6 10)) + (dir :field (byte 1 9))) + ;;; Same as reg-rem/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 (x66-reg/mem 24 + :default-printer '(:name :tab reg/mem)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (op :fields (list (byte 7 9) (byte 3 19))) + (width :field (byte 1 8) :type 'width) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'sized-reg/mem) ;; optional fields (imm)) ;;; 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 'imm-data)) + +(sb!disassem:define-instruction-format (x66-reg/mem-imm 24 + :include 'x66-reg/mem + :default-printer + '(:name :tab reg/mem ", " imm)) (reg/mem :type 'sized-reg/mem) (imm :type 'imm-data)) @@ -442,46 +572,89 @@ (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 (x66-accum-reg/mem 24 + :include 'x66-reg/mem + :default-printer + '(:name :tab accum ", " reg/mem)) + (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 (x66-ext-reg-reg/mem 32 + :default-printer + `(:name :tab reg ", " reg/mem)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (prefix :field (byte 8 8) :value #b00001111) + (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)) ;;; 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 (x66-ext-reg/mem 32 + :default-printer '(:name :tab reg/mem)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (prefix :field (byte 8 8) :value #b00001111) + (op :fields (list (byte 7 17) (byte 3 27))) + (width :field (byte 1 16) :type 'width) + (reg/mem :fields (list (byte 2 30) (byte 3 22)) + :type 'sized-reg/mem) ;; optional fields (imm)) + +(sb!disassem:define-instruction-format (ext-reg/mem-imm 24 + :include 'ext-reg/mem + :default-printer + '(:name :tab reg/mem ", " imm)) + (imm :type 'imm-data)) + +(sb!disassem:define-instruction-format (x66-ext-reg/mem-imm 32 + :include 'x66-ext-reg/mem + :default-printer + '(:name :tab reg/mem ", " imm)) + (imm :type 'imm-data)) ;;;; 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)) + :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)) + :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))) @@ -501,88 +674,129 @@ ;;; (added by (?) pfw) ;;; fp no operand isns (sb!disassem:define-instruction-format (floating-point-no 16 - :default-printer '(:name)) + :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)) + :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)) + :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)) + :default-printer '(:name)) (prefix :field (byte 8 0) :value #b11011111) (suffix :field (byte 3 13) :value #b111) (op :field (byte 5 8))) (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 (x66-string-op 16 + :include 'x66-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 'byte-reg/mem) - (reg :field (byte 3 19) :value #b000)) + :type 'byte-reg/mem) + (reg :field (byte 3 19) :value #b000)) + +(sb!disassem:define-instruction-format (cond-move 24 + :default-printer + '('cmov cc :tab reg ", " reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 4 12) :value #b0100) + (cc :field (byte 4 8) :type 'condition-code) + (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-cond-move 32 + :default-printer + '('cmov cc :tab reg ", " reg/mem)) + (x66 :field (byte 8 0) :type 'x66 :value #x66) + (prefix :field (byte 8 8) :value #b00001111) + (op :field (byte 4 20) :value #b0100) + (cc :field (byte 4 16) :type 'condition-code) + (reg/mem :fields (list (byte 2 30) (byte 3 24)) + :type 'reg/mem) + (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))) +(sb!disassem:define-instruction-format (prefetch 24 + :default-printer + '(:name ", " reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 8 8) :value #b00011000) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem) + (reg :field (byte 3 19) :type 'reg)) + ;;; 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))) + ;;;; primitive emitters @@ -607,16 +821,16 @@ (note-fixup segment :absolute fixup) (let ((offset (fixup-offset fixup))) (if (label-p offset) - (emit-back-patch segment - 4 ; FIXME: sb!vm:n-word-bytes - (lambda (segment posn) - (declare (ignore posn)) - (emit-dword segment - (- (+ (component-header-length) - (or (label-position offset) - 0)) - other-pointer-lowtag)))) - (emit-dword segment (or offset 0))))) + (emit-back-patch segment + 4 ; FIXME: n-word-bytes + (lambda (segment posn) + (declare (ignore posn)) + (emit-dword segment + (- (+ (component-header-length) + (or (label-position offset) + 0)) + other-pointer-lowtag)))) + (emit-dword segment (or offset 0))))) (defun emit-relative-fixup (segment fixup) (note-fixup segment :relative fixup) @@ -629,104 +843,104 @@ (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) (let ((offset (tn-offset tn))) (logior (ash (logand offset 1) 2) - (ash offset -1)))) + (ash offset -1)))) (defstruct (ea (:constructor make-ea (size &key base index scale disp)) - (:copier nil)) + (:copier nil)) (size nil :type (member :byte :word :dword)) (base nil :type (or tn null)) (index nil :type (or tn null)) (scale 1 :type (member 1 2 4 8)) - (disp 0 :type (or (signed-byte 32) fixup))) + (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-ea (segment thing reg &optional allow-constants) (etypecase thing (tn (ecase (sb-name (sc-sb (tn-sc thing))) (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 of EBP. - (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 of EBP. + (let ((disp (frame-byte-offset (tn-offset thing)))) + (cond ((<= -128 disp 127) + (emit-mod-reg-r/m-byte segment #b01 reg #b101) + (emit-byte segment disp)) + (t + (emit-mod-reg-r/m-byte segment #b10 reg #b101) + (emit-dword segment disp))))) (constant - (unless allow-constants - (error - "Constant TNs can only be directly used in MOV, PUSH, and CMP.")) - (emit-mod-reg-r/m-byte segment #b00 reg #b101) - (emit-absolute-fixup segment - (make-fixup nil - :code-object - (- (* (tn-offset thing) n-word-bytes) - other-pointer-lowtag)))))) + (unless allow-constants + (error + "Constant TNs can only be directly used in MOV, PUSH, and CMP.")) + (emit-mod-reg-r/m-byte segment #b00 reg #b101) + (emit-absolute-fixup segment + (make-fixup nil + :code-object + (- (* (tn-offset thing) n-word-bytes) + other-pointer-lowtag)))))) (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))))) (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-dword segment disp)))))) (fixup (emit-mod-reg-r/m-byte segment #b00 reg #b101) (emit-absolute-fixup segment thing)))) @@ -739,8 +953,8 @@ (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))) + (byte 3 0) + #b11000000))) (emit-ea segment thing op))) (defun byte-reg-p (thing) @@ -791,9 +1005,7 @@ ;;;; utilities -(defconstant +operand-size-prefix-byte+ #b01100110) - -(defconstant +default-operand-size+ :dword) +(def!constant +operand-size-prefix-byte+ #b01100110) (defun maybe-emit-operand-size-prefix (segment size) (unless (or (eq size :byte) (eq size +default-operand-size+)) @@ -806,18 +1018,18 @@ ;; to hack up the code (case (sc-name (tn-sc thing)) (#.*dword-sc-names* - :dword) + :dword) (#.*word-sc-names* - :word) + :word) (#.*byte-sc-names* - :byte) + :byte) ;; added by jrd: float-registers is a separate size (?) (#.*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)) (t @@ -825,17 +1037,17 @@ (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))))) + (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) (ecase size @@ -848,63 +1060,70 @@ ;;;; general data transfer -(define-instruction mov (segment dst src) +(define-instruction mov (segment dst src &optional prefix) ;; immediate to register (:printer reg ((op #b1011) (imm nil :type 'imm-data)) - '(:name :tab reg ", " imm)) + '(:name :tab reg ", " imm)) + (:printer x66-reg ((op #b1011) (imm nil :type 'imm-data)) + '(: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 "]")))) + (:printer x66-simple-dir ((op #b101000) (imm nil :type 'imm-addr)) + `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]")))) ;; register to/from register/memory (:printer reg-reg/mem-dir ((op #b100010))) + (:printer x66-reg-reg/mem-dir ((op #b100010))) ;; immediate to register/memory (:printer reg/mem-imm ((op '(#b1100011 #b000)))) + (:printer x66-reg/mem-imm ((op '(#b1100011 #b000)))) (:emitter + (emit-prefix segment prefix) (let ((size (matching-operand-size dst src))) (maybe-emit-operand-size-prefix segment size) (cond ((register-p dst) - (cond ((integerp src) - (emit-byte-with-reg segment - (if (eq size :byte) - #b10110 - #b10111) - (reg-tn-encoding dst)) - (emit-sized-immediate segment size src)) - ((and (fixup-p src) (accumulator-p dst)) - (emit-byte segment - (if (eq size :byte) - #b10100000 - #b10100001)) - (emit-absolute-fixup segment src)) - (t - (emit-byte segment - (if (eq size :byte) - #b10001010 - #b10001011)) - (emit-ea segment src (reg-tn-encoding dst) t)))) - ((and (fixup-p dst) (accumulator-p src)) - (emit-byte segment (if (eq size :byte) #b10100010 #b10100011)) - (emit-absolute-fixup segment dst)) - ((integerp src) - (emit-byte segment (if (eq size :byte) #b11000110 #b11000111)) - (emit-ea segment dst #b000) - (emit-sized-immediate segment size src)) - ((register-p src) - (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) - (emit-ea segment dst (reg-tn-encoding src))) - ((fixup-p src) - (aver (eq size :dword)) - (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) + (emit-byte-with-reg segment + (if (eq size :byte) + #b10110 + #b10111) + (reg-tn-encoding dst)) + (emit-sized-immediate segment size src)) + ((and (fixup-p src) (accumulator-p dst)) + (emit-byte segment + (if (eq size :byte) + #b10100000 + #b10100001)) + (emit-absolute-fixup segment src)) + (t + (emit-byte segment + (if (eq size :byte) + #b10001010 + #b10001011)) + (emit-ea segment src (reg-tn-encoding dst) t)))) + ((and (fixup-p dst) (accumulator-p src)) + (emit-byte segment (if (eq size :byte) #b10100010 #b10100011)) + (emit-absolute-fixup segment dst)) + ((integerp src) + (emit-byte segment (if (eq size :byte) #b11000110 #b11000111)) + (emit-ea segment dst #b000) + (emit-sized-immediate segment size src)) + ((register-p src) + (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) + (emit-ea segment dst (reg-tn-encoding src))) + ((fixup-p src) + (aver (eq size :dword)) + (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 opcode) (aver (register-p dst)) (let ((dst-size (operand-size dst)) - (src-size (operand-size src))) + (src-size (operand-size src))) (ecase dst-size (:word (aver (eq src-size :byte)) @@ -914,57 +1133,70 @@ (emit-ea segment src (reg-tn-encoding dst))) (:dword (ecase src-size - (:byte - (maybe-emit-operand-size-prefix segment :dword) - (emit-byte segment #b00001111) - (emit-byte segment opcode) - (emit-ea segment src (reg-tn-encoding dst))) - (:word - (emit-byte segment #b00001111) - (emit-byte segment (logior opcode 1)) - (emit-ea segment src (reg-tn-encoding dst)))))))) + (:byte + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:word + (emit-byte segment #b00001111) + (emit-byte segment (logior opcode 1)) + (emit-ea segment src (reg-tn-encoding dst)))))))) (define-instruction movsx (segment dst src) - (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg))) + (:printer ext-reg-reg/mem ((op #b1011111) + (reg nil :type 'word-reg) + (reg/mem nil :type 'sized-reg/mem))) + (:printer x66-ext-reg-reg/mem ((op #b1011111) + (reg nil :type 'word-reg) + (reg/mem nil :type 'sized-reg/mem))) (:emitter (emit-move-with-extension segment dst src #b10111110))) (define-instruction movzx (segment dst src) - (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg))) + (:printer ext-reg-reg/mem ((op #b1011011) + (reg nil :type 'word-reg) + (reg/mem nil :type 'sized-reg/mem))) + (:printer x66-ext-reg-reg/mem ((op #b1011011) + (reg nil :type 'word-reg) + (reg/mem nil :type 'sized-reg/mem))) (:emitter (emit-move-with-extension segment dst src #b10110110))) -(define-instruction push (segment src) +(define-instruction push (segment src &optional prefix) ;; register (:printer reg-no-width ((op #b01010))) + (:printer x66-reg-no-width ((op #b01010))) ;; register/memory (:printer reg/mem ((op '(#b1111111 #b110)) (width 1))) + (:printer x66-reg/mem ((op '(#b1111111 #b110)) (width 1))) ;; immediate (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte)) - '(:name :tab imm)) + '(:name :tab imm)) (:printer byte ((op #b01101000) (imm nil :type 'imm-word)) - '(:name :tab imm)) + '(:name :tab imm)) ;; ### segment registers? (:emitter + (emit-prefix segment prefix) (cond ((integerp src) - (cond ((<= -128 src 127) - (emit-byte segment #b01101010) - (emit-byte segment src)) - (t - (emit-byte segment #b01101000) - (emit-dword segment src)))) - ((fixup-p src) - ;; Interpret the fixup as an immediate dword to push. - (emit-byte segment #b01101000) - (emit-absolute-fixup segment src)) - (t - (let ((size (operand-size src))) - (aver (not (eq size :byte))) - (maybe-emit-operand-size-prefix segment size) - (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 + (emit-byte segment #b01101000) + (emit-dword segment src)))) + ((fixup-p src) + ;; Interpret the fixup as an immediate dword to push. + (emit-byte segment #b01101000) + (emit-absolute-fixup segment src)) + (t + (let ((size (operand-size src))) + (aver (not (eq size :byte))) + (maybe-emit-operand-size-prefix segment size) + (cond ((register-p src) + (emit-byte-with-reg segment #b01010 (reg-tn-encoding src))) + (t + (emit-byte segment #b11111111) + (emit-ea segment src #b110 t)))))))) (define-instruction pusha (segment) (:printer byte ((op #b01100000))) @@ -972,17 +1204,19 @@ (emit-byte segment #b01100000))) (define-instruction pop (segment dst) + (:printer x66-reg-no-width ((op #b01011))) (:printer reg-no-width ((op #b01011))) + (:printer x66-reg/mem ((op '(#b1000111 #b000)) (width 1))) (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) (:emitter (let ((size (operand-size dst))) (aver (not (eq size :byte))) (maybe-emit-operand-size-prefix segment size) (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 popa (segment) (:printer byte ((op #b01100001))) @@ -992,30 +1226,32 @@ (define-instruction xchg (segment operand1 operand2) ;; Register with accumulator. (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) + (:printer x66-reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) ;; Register/Memory with Register. (:printer reg-reg/mem ((op #b1000011))) + (:printer x66-reg-reg/mem ((op #b1000011))) (:emitter (let ((size (matching-operand-size operand1 operand2))) (maybe-emit-operand-size-prefix segment size) (labels ((xchg-acc-with-something (acc something) - (if (and (not (eq size :byte)) (register-p something)) - (emit-byte-with-reg segment - #b10010 - (reg-tn-encoding something)) - (xchg-reg-with-something acc something))) - (xchg-reg-with-something (reg something) - (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)) + (emit-byte-with-reg segment + #b10010 + (reg-tn-encoding something)) + (xchg-reg-with-something acc something))) + (xchg-reg-with-something (reg something) + (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 reg-reg/mem ((op #b1000110) (width 1))) @@ -1024,11 +1260,13 @@ (emit-byte segment #b10001101) (emit-ea segment src (reg-tn-encoding dst)))) -(define-instruction cmpxchg (segment dst src) +(define-instruction cmpxchg (segment dst src &optional prefix) ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg)) + (:printer x66-ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg)) (:emitter (aver (register-p src)) + (emit-prefix segment prefix) (let ((size (matching-operand-size src dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) @@ -1036,6 +1274,27 @@ (emit-ea segment dst (reg-tn-encoding src))))) +(defun emit-prefix (segment name) + (ecase name + ((nil)) + (:lock + #!+sb-thread + (emit-byte segment #xf0)) + (:fs + (emit-byte segment #x64)) + (:gs + (emit-byte segment #x65)))) + +(define-instruction fs-segment-prefix (segment) + (:printer byte ((op #b01100100))) + (:emitter + (bug "FS emitted as a separate instruction!"))) + +(define-instruction gs-segment-prefix (segment) + (:printer byte ((op #b01100101))) + (:emitter + (bug "GS emitted as a separate instruction!"))) + ;;;; flag control instructions ;;; CLC -- Clear Carry Flag. @@ -1107,38 +1366,38 @@ ;;;; 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)) - (emit-byte segment #b10000011) - (emit-ea segment dst opcode) - (emit-byte segment src)) - ((accumulator-p dst) - (emit-byte segment - (dpb opcode - (byte 3 3) - (if (eq size :byte) - #b00000100 - #b00000101))) - (emit-sized-immediate segment size src)) - (t - (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) - (emit-ea segment dst opcode) - (emit-sized-immediate segment size src)))) + (emit-byte segment #b10000011) + (emit-ea segment dst opcode allow-constants) + (emit-byte segment src)) + ((accumulator-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) + #b00000100 + #b00000101))) + (emit-sized-immediate segment size src)) + (t + (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) (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) (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))))) @@ -1146,62 +1405,78 @@ (eval-when (:compile-toplevel :execute) (defun arith-inst-printer-list (subop) `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) + (x66-accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) (reg/mem-imm ((op (#b1000000 ,subop)))) + (x66-reg/mem-imm ((op (#b1000000 ,subop)))) (reg/mem-imm ((op (#b1000001 ,subop)) - (imm nil :type signed-imm-byte))) - (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))) + (imm nil :type signed-imm-byte))) + (x66-reg/mem-imm ((op (#b1000001 ,subop)) + (imm nil :type signed-imm-byte))) + (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))) + (x66-reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))) ) -(define-instruction add (segment dst src) +(define-instruction add (segment dst src &optional prefix) (:printer-list (arith-inst-printer-list #b000)) - (:emitter (emit-random-arith-inst "ADD" segment dst src #b000))) + (:emitter + (emit-prefix segment prefix) + (emit-random-arith-inst "ADD" segment dst src #b000))) (define-instruction adc (segment dst src) (:printer-list (arith-inst-printer-list #b010)) (:emitter (emit-random-arith-inst "ADC" segment dst src #b010))) -(define-instruction sub (segment dst src) +(define-instruction sub (segment dst src &optional prefix) (:printer-list (arith-inst-printer-list #b101)) - (:emitter (emit-random-arith-inst "SUB" segment dst src #b101))) + (:emitter + (emit-prefix segment prefix) + (emit-random-arith-inst "SUB" segment dst src #b101))) (define-instruction sbb (segment dst src) (:printer-list (arith-inst-printer-list #b011)) (:emitter (emit-random-arith-inst "SBB" segment dst src #b011))) -(define-instruction cmp (segment dst src) +(define-instruction cmp (segment dst src &optional prefix) (:printer-list (arith-inst-printer-list #b111)) - (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t))) + (:emitter + (emit-prefix segment prefix) + (emit-random-arith-inst "CMP" segment dst src #b111 t))) (define-instruction inc (segment dst) ;; Register. (:printer reg-no-width ((op #b01000))) + (:printer x66-reg-no-width ((op #b01000))) ;; Register/Memory (:printer reg/mem ((op '(#b1111111 #b000)))) + (:printer x66-reg/mem ((op '(#b1111111 #b000)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (cond ((and (not (eq size :byte)) (register-p dst)) - (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst))) - (t - (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) - (emit-ea segment dst #b000)))))) + (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst))) + (t + (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) + (emit-ea segment dst #b000)))))) (define-instruction dec (segment dst) ;; Register. (:printer reg-no-width ((op #b01001))) + (:printer x66-reg-no-width ((op #b01001))) ;; Register/Memory (:printer reg/mem ((op '(#b1111111 #b001)))) + (:printer x66-reg/mem ((op '(#b1111111 #b001)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) (cond ((and (not (eq size :byte)) (register-p dst)) - (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst))) - (t - (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) - (emit-ea segment dst #b001)))))) + (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst))) + (t + (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 x66-reg/mem ((op '(#b1111011 #b011)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) @@ -1230,6 +1505,7 @@ (define-instruction mul (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b100)))) + (:printer x66-accum-reg/mem ((op '(#b1111011 #b100)))) (:emitter (let ((size (matching-operand-size dst src))) (aver (accumulator-p dst)) @@ -1239,40 +1515,50 @@ (define-instruction imul (segment dst &optional src1 src2) (:printer accum-reg/mem ((op '(#b1111011 #b101)))) + (:printer x66-accum-reg/mem ((op '(#b1111011 #b101)))) (:printer ext-reg-reg/mem ((op #b1010111))) - (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word)) - '(:name :tab reg ", " reg/mem ", " imm)) + (:printer x66-ext-reg-reg/mem ((op #b1010111))) + (:printer reg-reg/mem ((op #b0110100) (width 1) + (imm nil :type 'signed-imm-word)) + '(:name :tab reg ", " reg/mem ", " imm)) + (:printer x66-reg-reg/mem ((op #b0110100) (width 1) + (imm nil :type 'signed-imm-word)) + '(: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 x66-reg-reg/mem ((op #b0110101) (width 1) + (imm nil :type 'signed-imm-byte)) + '(:name :tab reg ", " reg/mem ", " imm)) (:emitter (flet ((r/m-with-immed-to-reg (reg r/m immed) - (let* ((size (matching-operand-size reg r/m)) - (sx (and (not (eq size :byte)) (<= -128 immed 127)))) - (maybe-emit-operand-size-prefix segment size) - (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) + (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) - (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) - (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) + (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) + (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)))) + (:printer x66-accum-reg/mem ((op '(#b1111011 #b110)))) (:emitter (let ((size (matching-operand-size dst src))) (aver (accumulator-p dst)) @@ -1282,6 +1568,7 @@ (define-instruction idiv (segment dst src) (:printer accum-reg/mem ((op '(#b1111011 #b111)))) + (:printer x66-accum-reg/mem ((op '(#b1111011 #b111)))) (:emitter (let ((size (matching-operand-size dst src))) (aver (accumulator-p dst)) @@ -1303,18 +1590,21 @@ ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL) (define-instruction cbw (segment) + (:printer two-bytes ((op '(#b01100110 #b10011000)))) (:emitter (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b10011000))) ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX) (define-instruction cwde (segment) + (:printer byte ((op #b10011000))) (:emitter (maybe-emit-operand-size-prefix segment :dword) (emit-byte segment #b10011000))) ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX) (define-instruction cwd (segment) + (:printer two-bytes ((op '(#b01100110 #b10011001)))) (:emitter (maybe-emit-operand-size-prefix segment :word) (emit-byte segment #b10011001))) @@ -1326,11 +1616,13 @@ (maybe-emit-operand-size-prefix segment :dword) (emit-byte segment #b10011001))) -(define-instruction xadd (segment dst src) +(define-instruction xadd (segment dst src &optional prefix) ;; Register/Memory with Register. (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg)) + (:printer x66-ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg)) (:emitter (aver (register-p src)) + (emit-prefix segment prefix) (let ((size (matching-operand-size src dst))) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) @@ -1344,24 +1636,30 @@ (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))) (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")) + (x66-reg/mem ((op (#b1101000 ,subop))) + (:name :tab reg/mem ", 1")) (reg/mem ((op (#b1101001 ,subop))) - (:name :tab reg/mem ", " 'cl)) + (:name :tab reg/mem ", " 'cl)) + (x66-reg/mem ((op (#b1101001 ,subop))) + (:name :tab reg/mem ", " 'cl)) (reg/mem-imm ((op (#b1100000 ,subop)) - (imm nil :type signed-imm-byte)))))) + (imm nil :type signed-imm-byte))) + (x66-reg/mem-imm ((op (#b1100000 ,subop)) + (imm nil :type signed-imm-byte)))))) (define-instruction rol (segment dst amount) (:printer-list @@ -1412,30 +1710,32 @@ (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment (dpb opcode (byte 1 3) - (if (eq amt :cl) #b10100101 #b10100100))) + (if (eq amt :cl) #b10100101 #b10100100))) #+nil (emit-ea segment dst src) - (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this + (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this (unless (eq amt :cl) (emit-byte segment amt)))) (eval-when (:compile-toplevel :execute) (defun double-shift-inst-printer-list (op) `(#+nil - (ext-reg-reg/mem-imm ((op ,(logior op #b100)) - (imm nil :type signed-imm-byte))) - (ext-reg-reg/mem ((op ,(logior op #b101))) - (:name :tab reg/mem ", " 'cl))))) + (ext-reg-reg/mem-imm ((op ,(logior op #b10)) + (imm nil :type signed-imm-byte))) + (ext-reg-reg/mem ((op ,(logior op #b10))) + (:name :tab reg/mem ", " reg ", " 'cl)) + (x66-ext-reg-reg/mem ((op ,(logior op #b10))) + (:name :tab reg/mem ", " reg ", " 'cl))))) (define-instruction shld (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) - (:printer-list (double-shift-inst-printer-list #b10100000)) + (:printer-list (double-shift-inst-printer-list #b1010000)) (:emitter (emit-double-shift segment #b0 dst src amt))) (define-instruction shrd (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) - (:printer-list (double-shift-inst-printer-list #b10101000)) + (:printer-list (double-shift-inst-printer-list #b1010100)) (:emitter (emit-double-shift segment #b1 dst src amt))) @@ -1447,49 +1747,79 @@ (define-instruction test (segment this that) (:printer accum-imm ((op #b1010100))) + (:printer x66-accum-imm ((op #b1010100))) (:printer reg/mem-imm ((op '(#b1111011 #b000)))) + (:printer x66-reg/mem-imm ((op '(#b1111011 #b000)))) (:printer reg-reg/mem ((op #b1000010))) + (:printer x66-reg-reg/mem ((op #b1000010))) (:emitter (let ((size (matching-operand-size this that))) (maybe-emit-operand-size-prefix segment size) (flet ((test-immed-and-something (immed something) - (cond ((accumulator-p something) - (emit-byte segment - (if (eq size :byte) #b10101000 #b10101001)) - (emit-sized-immediate segment size immed)) - (t - (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) - (emit-byte segment (if (eq size :byte) #b10000100 #b10000101)) - (emit-ea segment something (reg-tn-encoding reg)))) + (cond ((accumulator-p something) + (emit-byte segment + (if (eq size :byte) #b10101000 #b10101001)) + (emit-sized-immediate segment size immed)) + (t + (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) + (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))))))) - -(define-instruction or (segment dst src) + (test-immed-and-something that this)) + ((integerp this) + (test-immed-and-something this that)) + ((register-p this) + (test-reg-and-something this that)) + ((register-p that) + (test-reg-and-something that this)) + (t + (error "bogus operands for TEST: ~S and ~S" this that))))))) + +;;; Emit the most compact form of the test immediate instruction, +;;; using an 8 bit test when the immediate is only 8 bits and the +;;; value is one of the four low registers (eax, ebx, ecx, edx) or the +;;; control stack. +(defun emit-optimized-test-inst (x y) + (typecase y + ((unsigned-byte 7) + (let ((offset (tn-offset x))) + (cond ((and (sc-is x any-reg descriptor-reg) + (or (= offset eax-offset) (= offset ebx-offset) + (= offset ecx-offset) (= offset edx-offset))) + (inst test (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg) + :offset offset) + y)) + ((sc-is x control-stack) + (inst test (make-ea :byte :base ebp-tn + :disp (frame-byte-offset offset)) + y)) + (t + (inst test x y))))) + (t + (inst test x y)))) + +(define-instruction or (segment dst src &optional prefix) (:printer-list (arith-inst-printer-list #b001)) (:emitter + (emit-prefix segment prefix) (emit-random-arith-inst "OR" segment dst src #b001))) -(define-instruction xor (segment dst src) +(define-instruction xor (segment dst src &optional prefix) (:printer-list (arith-inst-printer-list #b110)) (:emitter + (emit-prefix segment prefix) (emit-random-arith-inst "XOR" segment dst src #b110))) (define-instruction not (segment dst) (:printer reg/mem ((op '(#b1111011 #b010)))) + (:printer x66-reg/mem ((op '(#b1111011 #b010)))) (:emitter (let ((size (operand-size dst))) (maybe-emit-operand-size-prefix segment size) @@ -1500,12 +1830,14 @@ (define-instruction cmps (segment size) (:printer string-op ((op #b1010011))) + (:printer x66-string-op ((op #b1010011))) (:emitter (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10100110 #b10100111)))) (define-instruction ins (segment acc) (:printer string-op ((op #b0110110))) + (:printer x66-string-op ((op #b0110110))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1514,6 +1846,7 @@ (define-instruction lods (segment acc) (:printer string-op ((op #b1010110))) + (:printer x66-string-op ((op #b1010110))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1522,12 +1855,14 @@ (define-instruction movs (segment size) (:printer string-op ((op #b1010010))) + (:printer x66-string-op ((op #b1010010))) (:emitter (maybe-emit-operand-size-prefix segment size) (emit-byte segment (if (eq size :byte) #b10100100 #b10100101)))) (define-instruction outs (segment acc) (:printer string-op ((op #b0110111))) + (:printer x66-string-op ((op #b0110111))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1536,6 +1871,7 @@ (define-instruction scas (segment acc) (:printer string-op ((op #b1010111))) + (:printer x66-string-op ((op #b1010111))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1544,6 +1880,7 @@ (define-instruction stos (segment acc) (:printer string-op ((op #b1010101))) + (:printer x66-string-op ((op #b1010101))) (:emitter (let ((size (operand-size acc))) (aver (accumulator-p acc)) @@ -1557,7 +1894,7 @@ (define-instruction rep (segment) (:emitter - (emit-byte segment #b11110010))) + (emit-byte segment #b11110011))) (define-instruction repe (segment) (:printer byte ((op #b11110011))) @@ -1573,6 +1910,8 @@ ;;;; bit manipulation (define-instruction bsf (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011110) (width 0))) + (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 0))) (:emitter (let ((size (matching-operand-size dst src))) (when (eq size :byte) @@ -1583,6 +1922,8 @@ (emit-ea segment src (reg-tn-encoding dst))))) (define-instruction bsr (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011110) (width 1))) + (:printer x66-ext-reg-reg/mem ((op #b1011110) (width 1))) (:emitter (let ((size (matching-operand-size dst src))) (when (eq size :byte) @@ -1599,26 +1940,47 @@ (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (cond ((integerp index) - (emit-byte segment #b10111010) - (emit-ea segment src opcode) - (emit-byte segment index)) - (t - (emit-byte segment (dpb opcode (byte 3 3) #b10000011)) - (emit-ea segment src (reg-tn-encoding index)))))) + (emit-byte segment #b10111010) + (emit-ea segment src opcode) + (emit-byte segment index)) + (t + (emit-byte segment (dpb opcode (byte 3 3) #b10000011)) + (emit-ea segment src (reg-tn-encoding index)))))) + +(eval-when (:compile-toplevel :execute) + (defun bit-test-inst-printer-list (subop) + `((ext-reg/mem-imm ((op (#b1011101 ,subop)) + (reg/mem nil :type word-reg/mem) + (imm nil :type imm-data) + (width 0))) + (x66-ext-reg/mem-imm ((op (#b1011101 ,subop)) + (reg/mem nil :type word-reg/mem) + (imm nil :type imm-data) + (width 0))) + (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001)) + (width 1)) + (:name :tab reg/mem ", " reg)) + (x66-ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001)) + (width 1)) + (:name :tab reg/mem ", " reg))))) (define-instruction bt (segment src index) + (:printer-list (bit-test-inst-printer-list #b100)) (:emitter (emit-bit-test-and-mumble segment src index #b100))) (define-instruction btc (segment src index) + (:printer-list (bit-test-inst-printer-list #b111)) (:emitter (emit-bit-test-and-mumble segment src index #b111))) (define-instruction btr (segment src index) + (:printer-list (bit-test-inst-printer-list #b110)) (:emitter (emit-bit-test-and-mumble segment src index #b110))) (define-instruction bts (segment src index) + (:printer-list (bit-test-inst-printer-list #b101)) (:emitter (emit-bit-test-and-mumble segment src index #b101))) @@ -1633,11 +1995,11 @@ (label (emit-byte segment #b11101000) (emit-back-patch segment - 4 - (lambda (segment posn) - (emit-dword segment - (- (label-position where) - (+ posn 4)))))) + 4 + (lambda (segment posn) + (emit-dword segment + (- (label-position where) + (+ posn 4)))))) (fixup (emit-byte segment #b11101000) (emit-relative-fixup segment where)) @@ -1647,11 +2009,11 @@ (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 @@ -1663,48 +2025,48 @@ (:printer reg/mem ((op '(#b1111111 #b100)) (width 1))) (: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)) - (emit-byte segment #b11111111) - (emit-ea segment where #b100))))) + (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)) + (emit-byte segment #b11111111) + (emit-ea segment where #b100))))) (define-instruction jmp-short (segment label) (:emitter @@ -1714,13 +2076,13 @@ (define-instruction ret (segment &optional stack-delta) (:printer byte ((op #b11000011))) (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) - '(:name :tab imm)) + '(:name :tab imm)) (:emitter - (cond (stack-delta - (emit-byte segment #b11000010) - (emit-word segment stack-delta)) - (t - (emit-byte segment #b11000011))))) + (cond ((and stack-delta (not (zerop stack-delta))) + (emit-byte segment #b11000010) + (emit-word segment stack-delta)) + (t + (emit-byte segment #b11000011))))) (define-instruction jecxz (segment target) (:printer short-jump ((op #b0011))) @@ -1731,7 +2093,7 @@ (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) @@ -1746,6 +2108,19 @@ (emit-byte segment #b11100000) (emit-byte-displacement-backpatch segment target))) +;;;; conditional move +(define-instruction cmov (segment cond dst src) + (:printer cond-move ()) + (:printer x66-cond-move ()) + (:emitter + (aver (register-p dst)) + (let ((size (matching-operand-size dst src))) + (aver (or (eq size :word) (eq size :dword))) + (maybe-emit-operand-size-prefix segment size)) + (emit-byte segment #b00001111) + (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000)) + (emit-ea segment src (reg-tn-encoding dst)))) + ;;;; conditional byte set (define-instruction set (segment dst cond) @@ -1759,7 +2134,7 @@ (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) @@ -1771,46 +2146,81 @@ (:emitter (emit-byte segment #b11001001))) +;;;; prefetch +(define-instruction prefetchnta (segment ea) + (:printer prefetch ((op #b00011000) (reg #b000))) + (:emitter + (aver (typep ea 'ea)) + (aver (eq :byte (ea-size ea))) + (emit-byte segment #b00001111) + (emit-byte segment #b00011000) + (emit-ea segment ea #b000))) + +(define-instruction prefetcht0 (segment ea) + (:printer prefetch ((op #b00011000) (reg #b001))) + (:emitter + (aver (typep ea 'ea)) + (aver (eq :byte (ea-size ea))) + (emit-byte segment #b00001111) + (emit-byte segment #b00011000) + (emit-ea segment ea #b001))) + +(define-instruction prefetcht1 (segment ea) + (:printer prefetch ((op #b00011000) (reg #b010))) + (:emitter + (aver (typep ea 'ea)) + (aver (eq :byte (ea-size ea))) + (emit-byte segment #b00001111) + (emit-byte segment #b00011000) + (emit-ea segment ea #b010))) + +(define-instruction prefetcht2 (segment ea) + (:printer prefetch ((op #b00011000) (reg #b011))) + (:emitter + (aver (typep ea 'ea)) + (aver (eq :byte (ea-size ea))) + (emit-byte segment #b00001111) + (emit-byte segment #b00011000) + (emit-ea segment ea #b011))) + ;;;; interrupt instructions (defun snarf-error-junk (sap offset &optional length-only) (let* ((length (sb!sys:sap-ref-8 sap offset)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type sb!sys:system-area-pointer sap) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) (cond (length-only - (values 0 (1+ length) nil nil)) - (t - (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset)) - vector (* n-word-bits - vector-data-offset) - (* length n-byte-bits)) - (collect ((sc-offsets) - (lengths)) - (lengths 1) ; the length byte - (let* ((index 0) - (error-number (sb!c::read-var-integer vector index))) - (lengths index) - (loop - (when (>= index length) - (return)) - (let ((old-index index)) - (sc-offsets (sb!c::read-var-integer vector index)) - (lengths (- index old-index)))) - (values error-number - (1+ length) - (sc-offsets) - (lengths)))))))) + (values 0 (1+ length) nil nil)) + (t + (sb!kernel:copy-ub8-from-system-area sap (1+ offset) + vector 0 length) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (sb!c:read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (sb!c:read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) #| (defmacro break-cases (breaknum &body cases) (let ((bn-temp (gensym))) (collect ((clauses)) (dolist (case cases) - (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) + (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) `(let ((,bn-temp ,breaknum)) - (cond ,@(clauses)))))) + (cond ,@(clauses)))))) |# (defun break-control (chunk inst stream dstate) @@ -1821,7 +2231,8 @@ ;; 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)) @@ -1839,10 +2250,17 @@ (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) @@ -1892,10 +2310,12 @@ (:emitter (emit-byte segment #b10011011))) +;;; FIXME: It would be better to make the disassembler understand the prefix as part +;;; of the instructions... (define-instruction lock (segment) (:printer byte ((op #b11110000))) (:emitter - (emit-byte segment #b11110000))) + (bug "LOCK prefix used as a standalone instruction"))) ;;;; miscellaneous hackery @@ -1913,14 +2333,14 @@ (defun emit-header-data (segment type) (emit-back-patch segment - 4 - (lambda (segment posn) - (emit-dword segment - (logior type - (ash (+ posn - (component-header-length)) - (- n-widetag-bits - word-shift))))))) + 4 + (lambda (segment posn) + (emit-dword segment + (logior type + (ash (+ posn + (component-header-length)) + (- n-widetag-bits + word-shift))))))) (define-instruction simple-fun-header-word (segment) (:emitter @@ -1966,11 +2386,11 @@ (:printer floating-point ((op '(#b001 #b010)))) (:emitter (cond ((fp-reg-tn-p dest) - (emit-byte segment #b11011101) - (emit-fp-op segment dest #b010)) - (t - (emit-byte segment #b11011001) - (emit-fp-op segment dest #b010))))) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (t + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b010))))) ;;; Store double from st(0). (define-instruction fstd (segment dest) @@ -1978,11 +2398,11 @@ (: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 - (emit-byte segment #b11011101) - (emit-fp-op segment dest #b010))))) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (t + (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 @@ -2218,7 +2638,7 @@ (:printer floating-point-fp ((op '(#b001 #b001)))) (:emitter (unless (and (tn-p source) - (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)) + (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)) (cl:break)) (emit-byte segment #b11011001) (emit-fp-op segment source #b001))) @@ -2263,11 +2683,11 @@ (:printer floating-point ((op '(#b001 #b011)))) (:emitter (cond ((fp-reg-tn-p dest) - (emit-byte segment #b11011101) - (emit-fp-op segment dest #b011)) - (t - (emit-byte segment #b11011001) - (emit-fp-op segment dest #b011))))) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011)) + (t + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b011))))) ;;; Store double from st(0) and pop. (define-instruction fstpd (segment dest) @@ -2275,11 +2695,11 @@ (: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 - (emit-byte segment #b11011101) - (emit-fp-op segment dest #b011))))) + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011)) + (t + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011))))) ;;; Store long from st(0) and pop. (define-instruction fstpl (segment dest) @@ -2417,8 +2837,7 @@ ;;; unordered comparison (define-instruction fucom (segment src) - ;; XX Printer conflicts with frstor - ;; (:printer floating-point ((op '(#b101 #b100)))) + (:printer floating-point-fp ((op '(#b101 #b100)))) (:emitter (aver (fp-reg-tn-p src)) (emit-byte segment #b11011101) @@ -2484,7 +2903,7 @@ ;;; in any VOPs that use them. See the book. ;;; st0 <- st1*log2(st0) -(define-instruction fyl2x(segment) ; pops stack +(define-instruction fyl2x(segment) ; pops stack (:printer floating-point-no ((op #b10001))) (:emitter (emit-byte segment #b11011001) @@ -2502,13 +2921,13 @@ (emit-byte segment #b11011001) (emit-byte segment #b11110000))) -(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan +(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 +(define-instruction fpatan(segment) ; POPS STACK (:printer floating-point-no ((op #b10011))) (:emitter (emit-byte segment #b11011001) @@ -2557,3 +2976,17 @@ (:emitter (emit-byte segment #b11011001) (emit-byte segment #b11101101))) + +;;;; Miscellany + +(define-instruction cpuid (segment) + (:printer two-bytes ((op '(#b00001111 #b10100010)))) + (:emitter + (emit-byte segment #b00001111) + (emit-byte segment #b10100010))) + +(define-instruction rdtsc (segment) + (:printer two-bytes ((op '(#b00001111 #b00110001)))) + (:emitter + (emit-byte segment #b00001111) + (emit-byte segment #b00110001)))