X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Finsts.lisp;h=720ad62ee83e5cb0abc5a1126ac1b28ae76b16cc;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=39a7d09a830a036a0c2c96a9ece928d4a0cc1cdc;hpb=d3705ad6676c19417b69cf38dd3667f6b3c3d2ef;p=sbcl.git diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 39a7d09..720ad62 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -608,6 +608,13 @@ ;; optional fields (imm)) +;;; reg-no-width with #x0f prefix +(sb!disassem:define-instruction-format (ext-reg-no-width 16 + :default-printer '(:name :tab reg)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 5 11)) + (reg :field (byte 3 8) :type 'reg)) + ;;; 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)) @@ -922,6 +929,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))) (emit-mod-reg-r/m-byte segment mod reg r/m) (when (= r/m #b100) (let ((ss (1- (integer-length scale))) @@ -1273,6 +1285,11 @@ (emit-byte segment (if (eq size :byte) #b10110000 #b10110001)) (emit-ea segment dst (reg-tn-encoding src))))) +(define-instruction pause (segment) + (:printer two-bytes ((op '(#xf3 #x90)))) + (:emitter + (emit-byte segment #xf3) + (emit-byte segment #x90))) (defun emit-prefix (segment name) (ecase name @@ -1588,6 +1605,12 @@ (emit-byte segment #b11010100) (emit-byte segment #b00001010))) +(define-instruction bswap (segment dst) + (:printer ext-reg-no-width ((op #b11001))) + (:emitter + (emit-byte segment #x0f) + (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst)))) + ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL) (define-instruction cbw (segment) (:printer two-bytes ((op '(#b01100110 #b10011000)))) @@ -1796,7 +1819,7 @@ y)) ((sc-is x control-stack) (inst test (make-ea :byte :base ebp-tn - :disp (- (* (1+ offset) n-word-bytes))) + :disp (frame-byte-offset offset)) y)) (t (inst test x y))))) @@ -2078,7 +2101,7 @@ (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) '(:name :tab imm)) (:emitter - (cond (stack-delta + (cond ((and stack-delta (not (zerop stack-delta))) (emit-byte segment #b11000010) (emit-word segment stack-delta)) (t @@ -2231,8 +2254,8 @@ ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce ;; from first principles whether it's defined in some way that genesis ;; can't grok. - (case #!-darwin (byte-imm-code chunk dstate) - #!+darwin (word-imm-code chunk dstate) + (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)) @@ -2250,17 +2273,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) @@ -2637,9 +2660,8 @@ (define-instruction fxch (segment source) (:printer floating-point-fp ((op '(#b001 #b001)))) (:emitter - (unless (and (tn-p source) - (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)) - (cl:break)) + (aver (and (tn-p source) + (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))) (emit-byte segment #b11011001) (emit-fp-op segment source #b001))) @@ -2990,3 +3012,64 @@ (:emitter (emit-byte segment #b00001111) (emit-byte segment #b00110001))) + +;;;; Late VM definitions +(defun canonicalize-inline-constant (constant) + (let ((first (car constant))) + (typecase first + (single-float (setf constant (list :single-float first))) + (double-float (setf constant (list :double-float first))))) + (destructuring-bind (type value) constant + (ecase type + ((:byte :word :dword) + (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 :dword (ldb (byte 32 0) (single-float-bits value)))) + ((:double-float-bits) + (aver (integerp value)) + (cons :double-float (ldb (byte 64 0) value))) + ((:double-float) + (aver (typep value 'double-float)) + (cons :double-float + (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32) + (double-float-low-bits value)))))))) + +(defun inline-constant-value (constant) + (let ((label (gen-label)) + (size (ecase (car constant) + ((:byte :word :dword) (car constant)) + (:double-float :dword)))) + (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) + (:double-float 8))) + +(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))))))