;;; I wonder whether the separation of the disassembler from the
;;; virtual machine is valid or adds value.
-;;; 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)
(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))
\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))
(declare (ignore dstate))
value)
) ; EVAL-WHEN
-(sb!disassem:define-argument-type fp-reg
- :prefilter #'prefilter-fp-reg
- :printer #'print-fp-reg)
+(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)
(defparameter *conditions*
(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)
: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.
;; 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))
;; 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
: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
(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))
(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))))
+ 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)
(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))))
-(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)
(t
(format stream "~A PTR [" (symbol-name (ea-size ea)))
(when (ea-base ea)
- (write-string (x86-location-print-name (ea-base ea)) stream)
+ (write-string (sb!c::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))
+ (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)
(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))))
+ (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))
(emit-absolute-fixup segment
(make-fixup nil
:code-object
- (- (* (tn-offset thing) word-bytes)
- other-pointer-type))))))
+ (- (* (tn-offset thing) n-word-bytes)
+ other-pointer-lowtag))))))
(ea
(let* ((base (ea-base thing))
(index (ea-index thing))
(and (eql disp 0)
(not (= (reg-tn-encoding base) #b101))))
#b00)
- ((and (target-fixnump disp) (<= -128 disp 127))
+ ((and (fixnump disp) (<= -128 disp 127))
#b01)
(t
#b10)))
\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+))
(emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
(emit-ea segment dst (reg-tn-encoding src)))
((fixup-p src)
- (assert (eq size :dword))
+ (aver (eq size :dword))
(emit-byte segment #b11000111)
(emit-ea segment dst #b000)
(emit-absolute-fixup segment src))
(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)))
(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-absolute-fixup segment src))
(t
(let ((size (operand-size src)))
- (assert (not (eq size :byte)))
+ (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)))
(: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)))
(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.
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
(emit-byte segment #b10000011)
- (emit-ea segment dst opcode)
+ (emit-ea segment dst opcode allow-constants)
(emit-byte segment src))
((accumulator-p dst)
(emit-byte segment
(emit-sized-immediate segment size src))
(t
(emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
- (emit-ea segment dst opcode)
+ (emit-ea segment dst opcode allow-constants)
(emit-sized-immediate segment size src))))
((register-p src)
(emit-byte segment
(: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))
+ (: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))
(: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)
(eval-when (:compile-toplevel :execute)
(defun double-shift-inst-printer-list (op)
`(#+nil
- (ext-reg-reg/mem-imm ((op ,(logior op #b100))
+ (ext-reg-reg/mem-imm ((op ,(logior op #b10))
(imm nil :type signed-imm-byte)))
- (ext-reg-reg/mem ((op ,(logior op #b101)))
- (:name :tab reg/mem ", " 'cl)))))
+ (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)))
(: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)
(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)))
(emit-byte segment #b11101000)
(emit-back-patch segment
4
- #'(lambda (segment posn)
- (emit-dword segment
- (- (label-position where)
- (+ posn 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)))))
+ (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
(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)
+ (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)
- #b10000000))
- (emit-dword segment disp)))))
+ #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))
- )))
+ (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))
(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)
(: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)
(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))
+ (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)))
+ (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))
+ (sc-offsets (sb!c:read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
;; 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
+ (#.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)
(logior type
(ash (+ posn
(component-header-length))
- (- type-bits
+ (- 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
;;;;
(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)))
;;; 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)))