(defparameter *sse-conditions* #(:eq :lt :le :unord :neq :nlt :nle :ord)))
(sb!disassem:define-arg-type sse-condition-code
+ ;; Inherit the prefilter from IMM-BYTE to READ-SUFFIX the byte.
+ :type 'imm-byte
:printer *sse-conditions*)
-(sb!disassem:define-instruction-format (xmm-xmm/mem-cmp 32
- :default-printer
- '(:name " " cc :tab reg ", " reg/mem))
- (x0f :field (byte 8 0) :value #x0f)
- (op :field (byte 8 8))
- (reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'xmmreg/mem)
- (reg :field (byte 3 19) :type 'xmmreg)
- (cc :field (byte 8 24) :type 'sse-condition-code))
-
-(sb!disassem:define-instruction-format (rex-xmm-xmm/mem-cmp 40
- :default-printer
- '(:name " " cc :tab reg ", " reg/mem))
- (rex :field (byte 4 4) :value #b0100)
- (wrxb :field (byte 4 0) :type 'wrxb)
- (x0f :field (byte 8 8) :value #x0f)
- (op :field (byte 8 16))
- (reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'xmmreg/mem)
- (reg :field (byte 3 27) :type 'xmmreg)
- (cc :field (byte 8 32) :type 'sse-condition-code))
-
-(sb!disassem:define-instruction-format (ext-xmm-xmm/mem-cmp 40
- :default-printer
- '(:name " " cc :tab reg ", " reg/mem))
- (prefix :field (byte 8 0))
- (x0f :field (byte 8 8) :value #x0f)
- (op :field (byte 8 16))
- (reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'xmmreg/mem)
- (reg :field (byte 3 27) :type 'xmmreg)
- (cc :field (byte 8 32) :type 'sse-condition-code))
-
-(sb!disassem:define-instruction-format (ext-rex-xmm-xmm/mem-cmp 48
- :default-printer
- '(:name " " cc :tab reg ", " reg/mem))
- (prefix :field (byte 8 0))
- (rex :field (byte 4 12) :value #b0100)
- (wrxb :field (byte 4 8) :type 'wrxb)
- (x0f :field (byte 8 16) :value #x0f)
- (op :field (byte 8 24))
- (reg/mem :fields (list (byte 2 38) (byte 3 32))
- :type 'xmmreg/mem)
- (reg :field (byte 3 35) :type 'xmmreg)
- (cc :field (byte 8 40) :type 'sse-condition-code))
-
;;; XMM instructions with 8 bit immediate data
(sb!disassem:define-instruction-format (xmm-xmm/mem-imm 24
:default-printer
- '(:name :tab reg ", " reg/mem " " imm))
+ '(:name
+ :tab reg ", " reg/mem ", " imm))
(x0f :field (byte 8 0) :value #x0f)
(op :field (byte 8 8))
(reg/mem :fields (list (byte 2 22) (byte 3 16))
(sb!disassem:define-instruction-format (rex-xmm-xmm/mem-imm 32
:default-printer
- '(:name :tab reg ", " reg/mem " " imm))
+ '(:name
+ :tab reg ", " reg/mem ", " imm))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
(x0f :field (byte 8 8) :value #x0f)
(sb!disassem:define-instruction-format (ext-xmm-xmm/mem-imm 32
:default-printer
- '(:name :tab reg ", " reg/mem " " imm))
+ '(:name
+ :tab reg ", " reg/mem ", " imm))
(prefix :field (byte 8 0))
(x0f :field (byte 8 8) :value #x0f)
(op :field (byte 8 16))
(sb!disassem:define-instruction-format (ext-rex-xmm-xmm/mem-imm 40
:default-printer
- '(:name :tab reg ", " reg/mem " " imm))
+ '(:name
+ :tab reg ", " reg/mem ", " imm))
(prefix :field (byte 8 0))
(rex :field (byte 4 12) :value #b0100)
(wrxb :field (byte 4 8) :type 'wrxb)
(format stream "+~A" (ea-disp ea))))
(write-char #\] stream))))
-(defun emit-constant-tn-rip (segment constant-tn reg)
+(defun emit-constant-tn-rip (segment constant-tn reg remaining-bytes)
;; AMD64 doesn't currently have a code object register to use as a
;; base register for constant access. Instead we use RIP-relative
;; addressing. The offset from the SIMPLE-FUN-HEADER to the instruction
;; The addressing is relative to end of instruction,
;; i.e. the end of this dword. Hence the + 4.
(emit-signed-dword segment
- (+ 4 (- (+ offset posn)))))))
+ (+ 4 remaining-bytes
+ (- (+ offset posn)))))))
(values))
-(defun emit-label-rip (segment fixup reg)
+(defun emit-label-rip (segment fixup reg remaining-bytes)
(let ((label (fixup-offset fixup)))
;; RIP-relative addressing
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-back-patch segment
4
(lambda (segment posn)
- (emit-signed-dword segment (- (label-position label)
- (+ posn 4))))))
+ (emit-signed-dword segment
+ (- (label-position label)
+ (+ posn 4 remaining-bytes))))))
(values))
-(defun emit-ea (segment thing reg &optional allow-constants)
+(defun emit-ea (segment thing reg &key allow-constants (remaining-bytes 0))
(etypecase thing
(tn
;; this would be eleganter if we had a function that would create
;; Why?
(error
"Constant TNs can only be directly used in MOV, PUSH, and CMP."))
- (emit-constant-tn-rip segment thing reg))))
+ (emit-constant-tn-rip segment thing reg remaining-bytes))))
(ea
(let* ((base (ea-base thing))
(index (ea-index thing))
(r/m (cond (index #b100)
((null base) #b101)
(t (reg-tn-encoding base)))))
+ (when (and (fixup-p disp)
+ (label-p (fixup-offset disp)))
+ (aver (null base))
+ (aver (null index))
+ (return-from emit-ea (emit-ea segment disp reg
+ :allow-constants allow-constants
+ :remaining-bytes remaining-bytes)))
(when (and (= mod 0) (= r/m #b101))
;; this is rip-relative in amd64, so we'll use a sib instead
(setf r/m #b100 scale 1))
(fixup
(typecase (fixup-offset thing)
(label
- (emit-label-rip segment thing reg))
+ (emit-label-rip segment thing reg remaining-bytes))
(t
(emit-mod-reg-r/m-byte segment #b00 reg #b100)
(emit-sib-byte segment 0 #b100 #b101)
:float)
(#.*double-sc-names*
:double)
+ (#.*complex-sc-names*
+ :complex)
(t
(error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
(ea
(if (eq size :byte)
#b10001010
#b10001011))
- (emit-ea segment src (reg-tn-encoding dst) t))))
+ (emit-ea segment src (reg-tn-encoding dst) :allow-constants t))))
((integerp src)
;; C7 only deals with 32 bit immediates even if the
;; destination is a 64-bit location. The value is
(cond (ea-p (ea-base src))
((tn-p src) src)
(t nil)))
- (emit-byte segment #x63) ;movsxd
+ (emit-byte segment (if signed-p #x63 #x8b)) ;movsxd or straight mov
;;(emit-byte segment opcode)
(emit-ea segment src (reg-tn-encoding dst)))))))))
(emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
(t
(emit-byte segment #b11111111)
- (emit-ea segment src #b110 t))))))))
+ (emit-ea segment src #b110 :allow-constants t))))))))
(define-instruction pop (segment dst)
(:printer reg-no-width-default-qword ((op #b01011)))
(cond ((and (not (eq size :byte)) (<= -128 src 127))
(maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment #b10000011)
- (emit-ea segment dst opcode allow-constants)
+ (emit-ea segment dst opcode :allow-constants allow-constants)
(emit-byte segment src))
((accumulator-p dst)
(maybe-emit-rex-for-ea segment dst nil)
(t
(maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
- (emit-ea segment dst opcode allow-constants)
+ (emit-ea segment dst opcode :allow-constants allow-constants)
(emit-sized-immediate segment size src))))
((register-p src)
(maybe-emit-rex-for-ea segment dst src)
(dpb opcode
(byte 3 3)
(if (eq size :byte) #b00000000 #b00000001)))
- (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+ (emit-ea segment dst (reg-tn-encoding src) :allow-constants allow-constants))
((register-p dst)
(maybe-emit-rex-for-ea segment src dst)
(emit-byte segment
(dpb opcode
(byte 3 3)
(if (eq size :byte) #b00000010 #b00000011)))
- (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+ (emit-ea segment src (reg-tn-encoding dst) :allow-constants allow-constants))
(t
(error "bogus operands to ~A" name)))))
(defun break-control (chunk inst stream dstate)
(declare (ignore inst))
(flet ((nt (x) (if stream (sb!disassem:note x dstate))))
- ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
- ;; map has it undefined; and it should be easier to look in the target
- ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
- ;; from first principles whether it's defined in some way that genesis
- ;; can't grok.
- (case #!-darwin (byte-imm-code chunk dstate)
- #!+darwin (word-imm-code chunk dstate)
+ ;; XXX: {BYTE,WORD}-IMM-CODE below is a macro defined by the
+ ;; DEFINE-INSTRUCTION-FORMAT for {BYTE,WORD}-IMM above. Due to
+ ;; the spectacular design for DEFINE-INSTRUCTION-FORMAT (involving
+ ;; a call to EVAL in order to define the macros at compile-time
+ ;; only) they do not even show up as symbols in the target core.
+ (case #!-ud2-breakpoints (byte-imm-code chunk dstate)
+ #!+ud2-breakpoints (word-imm-code chunk dstate)
(#.error-trap
(nt "error trap")
(sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
- #!-darwin (:printer byte-imm ((op #b11001100)) '(:name :tab code)
- :control #'break-control)
- #!+darwin (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
- :control #'break-control)
+ #!-ud2-breakpoints (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+ :control #'break-control)
+ #!+ud2-breakpoints (:printer word-imm ((op #b0000101100001111)) '(:name :tab code)
+ :control #'break-control)
(:emitter
- #!-darwin (emit-byte segment #b11001100)
+ #!-ud2-breakpoints (emit-byte segment #b11001100)
;; On darwin, trap handling via SIGTRAP is unreliable, therefore we
;; throw a sigill with 0x0b0f instead and check for this in the
;; SIGILL handler and pass it on to the sigtrap handler if
;; appropriate
- #!+darwin (emit-word segment #b0000101100001111)
+ #!+ud2-breakpoints (emit-word segment #b0000101100001111)
(emit-byte segment code)))
(define-instruction int (segment number)
\f
;;;; Instructions required to do floating point operations using SSE
-(defun emit-sse-inst (segment dst src prefix opcode &key operand-size)
+;; Return a two-element list of printers for SSE instructions. One
+;; printer is for the format without a REX prefix, the other one for the
+;; one with.
+(eval-when (:compile-toplevel :execute)
+ (defun sse-inst-printer-list (inst-format-stem prefix opcode
+ &key more-fields printer)
+ (let ((fields `(,@(when prefix
+ `((prefix ,prefix)))
+ (op ,opcode)
+ ,@more-fields))
+ (inst-formats (if prefix
+ (list (symbolicate "EXT-" inst-format-stem)
+ (symbolicate "EXT-REX-" inst-format-stem))
+ (list inst-format-stem
+ (symbolicate "REX-" inst-format-stem)))))
+ (mapcar (lambda (inst-format)
+ `(,inst-format ,fields ,@(when printer
+ (list printer))))
+ inst-formats))))
+
+(defun emit-sse-inst (segment dst src prefix opcode
+ &key operand-size (remaining-bytes 0))
(when prefix
(emit-byte segment prefix))
(if operand-size
(maybe-emit-rex-for-ea segment src dst))
(emit-byte segment #x0f)
(emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))
+ (emit-ea segment src (reg-tn-encoding dst) :remaining-bytes remaining-bytes))
;; 0110 0110:0000 1111:0111 00gg: 11 010 xmmreg:imm8
;;; Emit an SSE instruction that has an XMM register as the destination
;;; operand and for which the size of the operands is implicitly given
;;; by the instruction.
-(defun emit-regular-sse-inst (segment dst src prefix opcode)
+(defun emit-regular-sse-inst (segment dst src prefix opcode
+ &key (remaining-bytes 0))
(aver (xmm-register-p dst))
(emit-sse-inst segment dst src prefix opcode
- :operand-size :do-not-set))
+ :operand-size :do-not-set
+ :remaining-bytes remaining-bytes))
;;; Instructions having an XMM register as the destination operand
;;; and an XMM register or a memory location as the source operand.
(define-regular-sse-inst subps nil #x5c)
(define-regular-sse-inst subsd #xf2 #x5c)
(define-regular-sse-inst subss #xf3 #x5c)
+ (define-regular-sse-inst unpckhpd #x66 #x15)
+ (define-regular-sse-inst unpckhps nil #x15)
+ (define-regular-sse-inst unpcklpd #x66 #x14)
+ (define-regular-sse-inst unpcklps nil #x14)
;; integer arithmetic
(define-regular-sse-inst paddb #x66 #xfc)
(define-regular-sse-inst paddw #x66 #xfd)
(:printer rex-xmm-xmm/mem-imm ((op ,opcode)))))
(:emitter
(aver (typep pattern '(unsigned-byte 8)))
- (emit-regular-sse-inst segment dst src ,prefix ,opcode)
+ (emit-regular-sse-inst segment dst src ,prefix ,opcode
+ :remaining-bytes 1)
(emit-byte segment pattern)))))
(define-xmm-shuffle-sse-inst pshufd #x66 #x70)
(define-xmm-shuffle-sse-inst pshufhw #xf3 #x70)
(aver (xmm-register-p mask))
(emit-regular-sse-inst segment src mask #x66 #xf7)))
-(macrolet ((define-xmm-comparison-sse-inst (name prefix opcode &optional name-prefix name-suffix)
- (let ((printer (when name-prefix
- `'(,name-prefix cc ,name-suffix :tab reg ", " reg/mem))))
- `(define-instruction ,name (segment op x y)
- ,@(if prefix
- `((:printer ext-xmm-xmm/mem-cmp
- ((prefix ,prefix) (op ,opcode))
- ,@(and printer `(,printer)))
- (:printer ext-rex-xmm-xmm/mem-cmp
- ((prefix ,prefix) (op ,opcode))
- ,@(and printer `(,printer))))
- `((:printer xmm-xmm/mem-cmp ((op ,opcode))
- ,@(and printer `(,printer)))
- (:printer rex-xmm-xmm/mem-cmp ((op ,opcode))
- ,@(and printer `(,printer)))))
- (:emitter
- (let ((code (position op *sse-conditions*)))
- (aver code)
- (emit-regular-sse-inst segment x y ,prefix ,opcode)
- (emit-byte segment code)))))))
- (define-xmm-comparison-sse-inst cmppd #x66 #xc2 "CMP" "PD")
- (define-xmm-comparison-sse-inst cmpps nil #xc2 "CMP" "PS")
- (define-xmm-comparison-sse-inst cmpsd #xf2 #xc2 "CMP" "SD")
- (define-xmm-comparison-sse-inst cmpss #xf3 #xc2 "CMP" "SS"))
+(macrolet ((define-comparison-sse-inst (name prefix opcode
+ name-prefix name-suffix)
+ `(define-instruction ,name (segment op x y)
+ (:printer-list
+ ',(sse-inst-printer-list
+ 'xmm-xmm/mem-imm prefix opcode
+ :more-fields '((imm nil :type sse-condition-code))
+ :printer `(,name-prefix imm ,name-suffix
+ :tab reg ", " reg/mem)))
+ (:emitter
+ (let ((code (position op *sse-conditions*)))
+ (aver code)
+ (emit-regular-sse-inst segment x y ,prefix ,opcode
+ :remaining-bytes 1)
+ (emit-byte segment code))))))
+ (define-comparison-sse-inst cmppd #x66 #xc2 "CMP" "PD")
+ (define-comparison-sse-inst cmpps nil #xc2 "CMP" "PS")
+ (define-comparison-sse-inst cmpsd #xf2 #xc2 "CMP" "SD")
+ (define-comparison-sse-inst cmpss #xf3 #xc2 "CMP" "SS"))
;;; MOVSD, MOVSS
(macrolet ((define-movsd/ss-sse-inst (name prefix)
(:emitter
(emit-byte segment #b00001111)
(emit-byte segment #b00110001)))
+
+;;;; Late VM definitions
+
+(defun canonicalize-inline-constant (constant &aux (alignedp nil))
+ (let ((first (car constant)))
+ (when (eql first :aligned)
+ (setf alignedp t)
+ (pop constant)
+ (setf first (car constant)))
+ (typecase first
+ (single-float (setf constant (list :single-float first)))
+ (double-float (setf constant (list :double-float first)))
+ ((complex single-float)
+ (setf constant (list :complex-single-float first)))
+ ((complex double-float)
+ (setf constant (list :complex-double-float first)))))
+ (destructuring-bind (type value) constant
+ (ecase type
+ ((:byte :word :dword :qword)
+ (aver (integerp value))
+ (cons type value))
+ ((:base-char)
+ (aver (base-char-p value))
+ (cons :byte (char-code value)))
+ ((:character)
+ (aver (characterp value))
+ (cons :dword (char-code value)))
+ ((:single-float)
+ (aver (typep value 'single-float))
+ (cons (if alignedp :oword :dword)
+ (ldb (byte 32 0) (single-float-bits value))))
+ ((:double-float)
+ (aver (typep value 'double-float))
+ (cons (if alignedp :oword :qword)
+ (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32)
+ (double-float-low-bits value)))))
+ ((:complex-single-float)
+ (aver (typep value '(complex single-float)))
+ (cons (if alignedp :oword :qword)
+ (ldb (byte 64 0)
+ (logior (ash (single-float-bits (imagpart value)) 32)
+ (ldb (byte 32 0)
+ (single-float-bits (realpart value)))))))
+ ((:oword :sse)
+ (aver (integerp value))
+ (cons :oword value))
+ ((:complex-double-float)
+ (aver (typep value '(complex double-float)))
+ (cons :oword
+ (logior (ash (double-float-high-bits (imagpart value)) 96)
+ (ash (double-float-low-bits (imagpart value)) 64)
+ (ash (ldb (byte 32 0)
+ (double-float-high-bits (realpart value)))
+ 32)
+ (double-float-low-bits (realpart value))))))))
+
+(defun inline-constant-value (constant)
+ (let ((label (gen-label))
+ (size (ecase (car constant)
+ ((:byte :word :dword :qword) (car constant))
+ ((:oword) :qword))))
+ (values label (make-ea size
+ :disp (make-fixup nil :code-object label)))))
+
+(defun emit-constant-segment-header (constants optimize)
+ (declare (ignore constants))
+ (loop repeat (if optimize 64 16) do (inst byte #x90)))
+
+(defun size-nbyte (size)
+ (ecase size
+ (:byte 1)
+ (:word 2)
+ (:dword 4)
+ (:qword 8)
+ (:oword 16)))
+
+(defun sort-inline-constants (constants)
+ (stable-sort constants #'> :key (lambda (constant)
+ (size-nbyte (caar constant)))))
+
+(defun emit-inline-constant (constant label)
+ (let ((size (size-nbyte (car constant))))
+ (emit-alignment (integer-length (1- size)))
+ (emit-label label)
+ (let ((val (cdr constant)))
+ (loop repeat size
+ do (inst byte (ldb (byte 8 0) val))
+ (setf val (ash val -8))))))
projects / sbcl.git / blobdiff