;;; I wonder whether the separation of the disassembler from the
;;; virtual machine is valid or adds value.
-(file-comment
- "$Header$")
-
-;;; FIXME: In CMU CL, the code in this file seems to be fully
-;;; compiled, not byte compiled. I'm not sure that's reasonable:
-;;; there's a lot of code in this file, and considering the overall
-;;; speed of the compiler, having some byte-interpretation overhead
-;;; for every few bytes emitted doesn't seem likely to be noticeable.
-;;; I'd like to see what happens if I come back and byte-compile this
-;;; file.
-
;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
(deftype reg () '(unsigned-byte 3))
+
+(def!constant +default-operand-size+ :dword)
\f
(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*
(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))
+ (sb!disassem:dstate-get-prop dstate 'width)
+ 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))
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)
+ 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)))
;; 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))
;;; 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))))
+ (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))))
(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)
\f
;;;; disassembler argument types
-(sb!disassem:define-argument-type displacement
+(sb!disassem:define-arg-type displacement
:sign-extend t
- :use-label #'offset-next)
-
-(sb!disassem:define-argument-type accum
- :printer #'(lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-reg 0 stream dstate))
- )
-
-(sb!disassem:define-argument-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)))
-
-(sb!disassem:define-argument-type reg
+ :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: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)))
+
+(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)))
+
+(sb!disassem:define-arg-type reg
:printer #'print-reg)
-(sb!disassem:define-argument-type addr-reg
+(sb!disassem:define-arg-type addr-reg
:printer #'print-addr-reg)
-(sb!disassem:define-argument-type word-reg
+(sb!disassem:define-arg-type word-reg
:printer #'print-word-reg)
-(sb!disassem:define-argument-type imm-addr
+(sb!disassem:define-arg-type imm-addr
:prefilter #'read-address
:printer #'print-label)
-(sb!disassem:define-argument-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))
- )
-
-(sb!disassem:define-argument-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)))
- )
-
-(sb!disassem:define-argument-type signed-imm-byte
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 8 dstate)))
-
-(sb!disassem:define-argument-type signed-imm-dword
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate)))
-
-(sb!disassem:define-argument-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))))
+(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)))
+
+(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))))
+
+(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)))
+
+(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)))
+
+(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))))
+
+(sb!disassem:define-arg-type signed-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-signed-suffix (width-bits width) dstate))))
;;; needed for the ret imm16 instruction
-(sb!disassem:define-argument-type imm-word-16
- :prefilter #'(lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 16 dstate)))
+(sb!disassem:define-arg-type imm-word-16
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
-(sb!disassem:define-argument-type reg/mem
+(sb!disassem:define-arg-type reg/mem
:prefilter #'prefilter-reg/mem
:printer #'print-reg/mem)
-(sb!disassem:define-argument-type sized-reg/mem
+(sb!disassem:define-arg-type sized-reg/mem
;; Same as reg/mem, but prints an explicit size indicator for
;; memory references.
:prefilter #'prefilter-reg/mem
:printer #'print-sized-reg/mem)
-(sb!disassem:define-argument-type byte-reg/mem
+(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))
-
(defun prefilter-fp-reg (value dstate)
;; just return it
(declare (ignore dstate))
value)
-)
-(sb!disassem:define-argument-type fp-reg
- :prefilter #'prefilter-fp-reg
- :printer #'print-fp-reg)
+) ; EVAL-WHEN
+(sb!disassem:define-arg-type fp-reg
+ :prefilter #'prefilter-fp-reg
+ :printer #'print-fp-reg)
-(sb!disassem:define-argument-type width
+(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)))))
+ :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)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defconstant conditions
+(defparameter *conditions*
'((:o . 0)
(:no . 1)
(:b . 2) (:nae . 2) (:c . 2)
(:nl . 13) (:ge . 13)
(:le . 14) (:ng . 14)
(:nle . 15) (:g . 15)))
-
(defparameter *condition-name-vec*
(let ((vec (make-array 16 :initial-element nil)))
- (dolist (cond conditions)
+ (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
;;; Set assembler parameters. (In CMU CL, this was done with
;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf sb!assem:*assem-scheduler-p* nil))
-(sb!disassem:define-argument-type condition-code
+(sb!disassem:define-arg-type condition-code
:printer *condition-name-vec*)
(defun conditional-opcode (condition)
- (cdr (assoc condition conditions :test #'eq)))
+ (cdr (assoc condition *conditions* :test #'eq)))
\f
;;;; disassembler instruction formats
(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))
;;; 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 (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)
;;; 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)
(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))
;;; 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)))
;;; 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))
;;; 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
(accum-reg/mem 16
:include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
- (reg/mem :type 'reg/mem) ; don't need a size
+ (reg/mem :type 'reg/mem) ; don't need a size
(accum :type 'accum))
;;; Same as reg-reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 7 9))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
;;; 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
+ '(:name :tab reg/mem ", " imm))
+ (imm :type '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))
+ :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)))
;;; (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 (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 (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)))
+
\f
;;;; primitive emitters
(note-fixup segment :absolute fixup)
(let ((offset (fixup-offset fixup)))
(if (label-p offset)
- (emit-back-patch segment
- 4 ; FIXME: sb!vm:word-bytes
- #'(lambda (segment posn)
- (declare (ignore posn))
- (emit-dword segment
- (- (+ (component-header-length)
- (or (label-position offset)
- 0))
- other-pointer-type))))
- (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)
(defun reg-tn-encoding (tn)
(declare (type tn tn))
- (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (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)))
+(defstruct (ea (:constructor make-ea (size &key base index scale disp))
+ (: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 (x86-location-print-name (ea-base ea)) stream)
- (when (ea-index ea)
- (write-string "+" stream)))
- (when (ea-index ea)
- (write-string (x86-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)) 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 (- (* (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)))))
(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) word-bytes)
- other-pointer-type))))))
+ (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 (target-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))))
(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)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) byte-sc-names)
+ (member (sc-name (tn-sc thing)) *byte-sc-names*)
t))
(defun byte-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :byte))
(tn
- (and (member (sc-name (tn-sc thing)) byte-sc-names) t))
+ (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
(t nil)))
(defun word-reg-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) word-sc-names)
+ (member (sc-name (tn-sc thing)) *word-sc-names*)
t))
(defun word-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :word))
- (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t))
+ (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
(t nil)))
(defun dword-reg-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) dword-sc-names)
+ (member (sc-name (tn-sc thing)) *dword-sc-names*)
t))
(defun dword-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :dword))
(tn
- (and (member (sc-name (tn-sc thing)) dword-sc-names) t))
+ (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
(t nil)))
(defun register-p (thing)
\f
;;;; 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+))
(defun operand-size (thing)
(typecase thing
(tn
+ ;; FIXME: might as well be COND instead of having to use #. readmacro
+ ;; to hack up the code
(case (sc-name (tn-sc thing))
- (#.dword-sc-names
- :dword)
- (#.word-sc-names
- :word)
- (#.byte-sc-names
- :byte)
- ;; added by jrd. float-registers is a separate size (?)
- (#.float-sc-names
- :float)
- (#.double-sc-names
- :double)
+ (#.*dword-sc-names*
+ :dword)
+ (#.*word-sc-names*
+ :word)
+ (#.*byte-sc-names*
+ :byte)
+ ;; added by jrd: float-registers is a separate size (?)
+ (#.*float-sc-names*
+ :float)
+ (#.*double-sc-names*
+ :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
(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
(define-instruction mov (segment dst src)
;; immediate to register
(:printer reg ((op #b1011) (imm nil :type 'imm-data))
- '(: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)))
;; immediate to register/memory
(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)
- (assert (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)
- (assert (register-p dst))
+ (aver (register-p dst))
(let ((dst-size (operand-size dst))
- (src-size (operand-size src)))
+ (src-size (operand-size src)))
(ecase dst-size
(:word
- (assert (eq src-size :byte))
+ (aver (eq src-size :byte))
(maybe-emit-operand-size-prefix segment :word)
(emit-byte segment #b00001111)
(emit-byte segment opcode)
(emit-ea segment src (reg-tn-encoding dst)))
(:dword
(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 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
(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)))
- (assert (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)))
(:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
(:emitter
(let ((size (operand-size dst)))
- (assert (not (eq size :byte)))
+ (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)))
(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)))
(:emitter
- (assert (dword-reg-p dst))
+ (aver (dword-reg-p dst))
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
(:emitter
- (assert (register-p src))
+ (aver (register-p src))
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(emit-ea segment dst (reg-tn-encoding src)))))
\f
+
+(define-instruction fs-segment-prefix (segment)
+ (:emitter
+ (emit-byte segment #x64)))
+
;;;; flag control instructions
;;; CLC -- Clear Carry Flag.
;;;; arithmetic
(defun emit-random-arith-inst (name segment dst src opcode
- &optional allow-constants)
+ &optional allow-constants)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
- (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)))))
`((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
(reg/mem-imm ((op (#b1000000 ,subop))))
(reg/mem-imm ((op (#b1000001 ,subop))
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
)
(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.
(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 accum-reg/mem ((op '(#b1111011 #b100))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b100))))
(define-instruction imul (segment dst &optional src1 src2)
(:printer 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 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))
(: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))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b110))))
(:printer accum-reg/mem ((op '(#b1111011 #b111))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b111))))
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
(:emitter
- (assert (register-p src))
+ (aver (register-p src))
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(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"))
(reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
+ (:name :tab reg/mem ", " 'cl))
(reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type signed-imm-byte))))))
+ (imm nil :type signed-imm-byte))))))
(define-instruction rol (segment dst amount)
(:printer-list
(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)))))
(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)))
(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)))))))
+ (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 (- (* (1+ offset) n-word-bytes)))
+ y))
+ (t
+ (inst test x y)))))
+ (t
+ (inst test x y))))
(define-instruction or (segment dst src)
(:printer-list
(:printer string-op ((op #b0110110)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
(:printer string-op ((op #b1010110)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
(:printer string-op ((op #b0110111)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
(:printer string-op ((op #b1010111)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
(:printer string-op ((op #b1010101)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
;;;; bit manipulation
(define-instruction bsf (segment dst src)
+ (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
(:emitter
(let ((size (matching-operand-size dst src)))
(when (eq size :byte)
(emit-ea segment src (reg-tn-encoding dst)))))
(define-instruction bsr (segment dst src)
+ (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
(:emitter
(let ((size (matching-operand-size dst src)))
(when (eq size :byte)
(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)))
+ (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)))
(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))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment
- 1
- #'(lambda (segment posn)
- (let ((disp (- (label-position target) (1+ posn))))
- (assert (<= -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 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
(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)
(emit-byte segment #b11100000)
(emit-byte-displacement-backpatch segment target)))
\f
+;;;; conditional move
+(define-instruction cmov (segment cond dst src)
+ (:printer 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)
(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)
(:emitter
(emit-byte segment #b11001001)))
\f
+;;;; 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)))
+\f
;;;; 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 (* byte-bits (1+ offset))
- vector (* word-bits
- vector-data-offset)
- (* length 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)
;; 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)
- (#.sb!vm:error-trap
+ (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))
- (#.sb!vm:cerror-trap
+ (#.cerror-trap
(nt "cerror trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
- (#.sb!vm:breakpoint-trap
+ (#.breakpoint-trap
(nt "breakpoint trap"))
- (#.sb!vm:pending-interrupt-trap
+ (#.pending-interrupt-trap
(nt "pending interrupt trap"))
- (#.sb!vm:halt-trap
+ (#.halt-trap
(nt "halt trap"))
- (#.sb!vm:function-end-breakpoint-trap
+ (#.fun-end-breakpoint-trap
(nt "function end breakpoint trap")))))
(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)
(defun emit-header-data (segment type)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment
- (logior type
- (ash (+ posn
- (component-header-length))
- (- type-bits
- word-shift)))))))
+ 4
+ (lambda (segment posn)
+ (emit-dword segment
+ (logior type
+ (ash (+ posn
+ (component-header-length))
+ (- n-widetag-bits
+ word-shift)))))))
-(define-instruction function-header-word (segment)
+(define-instruction simple-fun-header-word (segment)
(:emitter
- (emit-header-data segment function-header-type)))
+ (emit-header-data segment simple-fun-header-widetag)))
(define-instruction lra-header-word (segment)
(:emitter
- (emit-header-data segment return-pc-header-type)))
+ (emit-header-data segment return-pc-header-widetag)))
\f
;;;; fp instructions
;;;;
(: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)
(: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
(define-instruction fadd-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b000))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (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
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b000)))
(define-instruction fsub-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b101))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (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
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b101)))
(define-instruction fsubr-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b100))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (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
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b100)))
(define-instruction fmul-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b001))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b001)))
(define-instruction fdiv-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b111))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b111)))
(define-instruction fdivr-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b110))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b110)))
(: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)))
(: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)
(: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)
;;; 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
- (assert (fp-reg-tn-p src))
+ (aver (fp-reg-tn-p src))
(emit-byte segment #b11011101)
(emit-fp-op segment src #b100)))
;;; 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)
(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)
projects / sbcl.git / blobdiff