X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Finsts.lisp;h=fef01fe38390aa6bfa5b1e4873a8ea88838f6dad;hb=a7ec2f1af6881c93585d97fb2fdcdfd98006f217;hp=1f3cc0b3091ca92d7b9c096aca28b6e1b357e852;hpb=a157ed0be79751f85b8243c06102eea95af06aa3;p=sbcl.git diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 1f3cc0b..fef01fe 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/src/compiler/x86-64/insts.lisp @@ -1124,7 +1124,8 @@ (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)) @@ -1134,7 +1135,8 @@ (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) @@ -1146,7 +1148,8 @@ (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)) @@ -1157,7 +1160,8 @@ (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) @@ -1460,6 +1464,11 @@ (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))) (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)) @@ -1875,7 +1884,7 @@ (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))))))))) @@ -2895,13 +2904,13 @@ (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)) @@ -2923,17 +2932,17 @@ (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) @@ -3537,3 +3546,91 @@ (: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))))))